module Main where import Utility (resample) import qualified Options.Applicative as OP import qualified Graphics.PDF as PDF import qualified Shell.Utility.Verbosity as Verbosity import qualified Shell.Utility.Log as Log import Shell.Utility.ParseArgument (parseNumber) import Shell.Utility.Exit (exitFailureMsg) import qualified System.Directory as Dir import System.FilePath (()) import qualified Sound.MIDI.Message.Class.Query as Query import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.General as GeneralMidi import qualified Sound.MIDI.File.Load as MidiLoad import qualified Sound.MIDI.File.Event.Meta as MetaEvent import qualified Sound.MIDI.File.Event as MidiEvent import qualified Sound.MIDI.File as MidiFile import qualified Data.EventList.Absolute.TimeBody as AbsEventList import qualified Data.EventList.Relative.TimeBody as EventList import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Data.Time.Format as TimeFmt import qualified Data.Time as Time import qualified Data.Array as Array import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map import qualified Data.IntSet as IntSet import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold import qualified Data.FixedLengthList as FL import qualified Data.NonEmpty.Class as NonEmptyC import qualified Data.NonEmpty as NonEmpty import qualified Data.Sequence as Seq -- could be te-configuration/crawler:Dequeue import qualified Data.List.HT as ListHT import qualified Data.List as List import Data.IntMap (IntMap) import Data.IntSet (IntSet) import Data.Map (Map) import Data.Sequence (Seq) import Data.Array (Array, listArray, (!)) import Data.Semigroup ((<>)) import Data.Tuple.HT (thd3) import Data.Tuple.Strict (mapFst, mapPair, swap) -- import Data.Maybe.HT (maybePlus) import Data.Maybe (listToMaybe, fromMaybe) import Data.String (fromString) import Data.Complex (Complex((:+))) -- import qualified Control.Monad.Exception.Synchronous as ME import qualified Control.Monad.Trans.State as MS import Control.Monad (join, when, guard, mfilter) import Control.Applicative (liftA2, (<$>), (<*>), (<|>)) import Text.Printf (printf) {- | Terminated tubes sorted with respect to upper boundary and unterminated tubes sorted with respect to note. -} type VisibleTubes = (Map Double [(Double, Int)], IntMap Double) {- | This also handles three kinds of corruption: NoteOff without NoteOn, NoteOn without NoteOff, duplicate NoteOn (which is kind of special case of NoteOn without NoteOff) -} welcomeNextEvent :: (Double, (Int, Bool)) -> VisibleTubes -> VisibleTubes welcomeNextEvent (timeStamp, (pitch, noteOn)) (terminated, unterminated) = (case IntMap.lookup pitch unterminated of Nothing -> terminated Just timeStart -> Map.insertWith (++) timeStamp [(timeStart, pitch)] terminated , if noteOn then IntMap.insert pitch timeStamp unterminated else IntMap.delete pitch unterminated) farewellEvents :: Double -> VisibleTubes -> VisibleTubes farewellEvents time (terminated, unterminated) = (thd3 $ Map.splitLookup time terminated, unterminated) filterNotes :: (Query.C ev) => VoiceMsg.Pitch -> AbsEventList.T Double ev -> AbsEventList.T Double (Int, Bool) filterNotes zeroKey = AbsEventList.mapMaybe (\ev -> do (c, (_v, p, noteOn)) <- Query.noteExplicitOff ev guard $ c /= GeneralMidi.drumChannel return (VoiceMsg.subtractPitch zeroKey p, noteOn)) windowInitialize :: Double -> [(Double, (Int, Bool))] -> (VisibleTubes, [(Double, (Int, Bool))]) windowInitialize time events = case span ((<=time) . fst) events of (displayed, remaining) -> (foldl (flip welcomeNextEvent) (Map.empty, IntMap.empty) displayed, remaining) windowMove :: (Double, Double) -> (VisibleTubes, [(Double, (Int, Bool))]) -> (VisibleTubes, [(Double, (Int, Bool))]) windowMove (newFrom, newTo) (currentDisplay, events) = case span ((<=newTo) . fst) events of (newDisplayed, remaining) -> (foldl (flip welcomeNextEvent) (farewellEvents newFrom currentDisplay) newDisplayed, remaining) data Tube = Tube { tubeFrom :: Double, tubeTo :: Maybe Double, tubePitch :: Int } shiftTube :: Double -> Tube -> Tube shiftTube d (Tube from mTo pitch) = (Tube (from+d) (fmap (+d) mTo) pitch) windowLayout :: VisibleTubes -> [Tube] windowLayout (terminated, unterminated) = Fold.fold (Map.mapWithKey (\to -> map (\(from, pitch) -> Tube from (Just to) pitch)) terminated) ++ map (\(pitch, from) -> Tube from Nothing pitch) (IntMap.toList unterminated) minimalDistanceToTubeHeads :: [Tube] -> IntMap Double minimalDistanceToTubeHeads = IntMap.fromListWith min . map (\(Tube from _mTo pitch) -> (pitch, -from)) . filter (\(Tube from _mTo _pitch) -> from<=0) defaultTitleDuration :: (Fractional t) => t defaultTitleDuration = 2 titleFadeDuration :: (Fractional t) => t titleFadeDuration = 1 alphaForTitle :: (RealFrac a) => a -> a -> a alphaForTitle titleDuration t = min 1 ((titleDuration-t)/titleFadeDuration) layoutTitle :: (RealFrac t) => t -> t -> [[(t, text)]] -> [[(t, t, text)]] layoutTitle frameRate titleDuration = map (map (\(t,text) -> (1, alphaForTitle titleDuration t, text))) . addCaptionTails (ceiling (titleDuration*frameRate)) (recip frameRate) layoutCounters :: (RealFrac t) => t -> [[(t, text)]] -> [[(t, t, text)]] layoutCounters frameRate = map (map (\(t,text) -> let dt = max 0 (t-0.05) z = 1 + dt * 2 in (5/z, 1 - dt/1.0, text))) . addCaptionTails (ceiling (1.0*frameRate)) (recip frameRate) zipSemi :: (Semigroup a) => [a] -> [a] -> [a] zipSemi (x:xs) (y:ys) = (x<>y) : zipSemi xs ys zipSemi [] ys = ys zipSemi xs [] = xs addCaptionTails :: (Num t) => Int -> t -> [[(t,a)]] -> [[(t,a)]] addCaptionTails numFrames d = foldr (\cs xs -> flip zipSemi ([]:xs) $ List.transpose $ map (\(t,a) -> map (\ti -> (ti,a)) $ take numFrames $ iterate (d+) t) cs) [] chop :: (Ord t) => [t] -> [(t,a)] -> [[(t,a)]] chop ts evs0 = snd $ Trav.mapAccumL (\evs t -> swap $ span (( [(Double, String)] filterTitle = AbsEventList.toPairList . AbsEventList.mapMaybe (\ev -> case ev of MidiEvent.MetaEvent (MetaEvent.TrackName str) -> Just str _ -> Nothing) filterLyrics :: AbsEventList.T Double MidiEvent.T -> [(Double, String)] filterLyrics = AbsEventList.toPairList . AbsEventList.mapMaybe (\ev -> case ev of MidiEvent.MetaEvent (MetaEvent.Lyric str) -> Just str _ -> Nothing) seqViewL :: Seq a -> Maybe (a, Seq a) seqViewL xs = case Seq.viewl xs of Seq.EmptyL -> Nothing y Seq.:< ys -> Just (y,ys) formatPitch :: VoiceMsg.Pitch -> String formatPitch p = case divMod (fromEnum p) (snd $ Array.bounds noteNames) of (octave, pitchClass) -> printf "%s%d" (noteNames ! pitchClass) octave formatSeconds :: Double -> String formatSeconds = TimeFmt.formatTime TimeFmt.defaultTimeLocale "%T%03Q" . Time.timeToTimeOfDay . realToFrac detectCorruptNotes :: (Num time) => (time -> String) -> AbsEventList.T time MidiEvent.T -> AbsEventList.T time String detectCorruptNotes formatTimeStamp = flip MS.evalState IntMap.empty . AbsEventList.traverseWithTime (\t (p,noteOn) -> do noteOns <- MS.get let pInt = fromEnum p let prompt :: String prompt = printf "%s, pitch %d (%s)" (formatTimeStamp t) pInt (formatPitch p) if noteOn then case mfilter (not . Fold.null) $ IntMap.lookup pInt noteOns of Nothing -> do MS.put $ IntMap.insert pInt (Seq.singleton t) noteOns return "" Just startTimes -> do MS.put $ IntMap.insert pInt (startTimes <> Seq.singleton t) noteOns return $ printf "%s: NoteOn after unfinished NoteOns at %s" prompt (List.intercalate ", " $ Fold.toList $ fmap formatTimeStamp startTimes) else case IntMap.lookup pInt noteOns >>= seqViewL of Nothing -> return $ printf "%s: NoteOff without NoteOn" prompt Just (_startTime, startTimes) -> do MS.put $ IntMap.insert pInt startTimes noteOns return "") . AbsEventList.mapMaybe (\ev -> do (c, (_v, p, noteOn)) <- Query.noteExplicitOff ev guard $ c /= GeneralMidi.drumChannel return (p, noteOn)) mergeTracksToAbsoluteTicks :: MidiFile.T -> AbsEventList.T Integer MidiEvent.T mergeTracksToAbsoluteTicks (MidiFile.Cons typ _division tracks) = AbsEventList.mapTime NonNegW.toNumber $ EventList.toAbsoluteEventList 0 $ MidiFile.mergeTracks typ tracks mergeTracksToAbsoluteSeconds :: MidiFile.T -> AbsEventList.T Double MidiEvent.T mergeTracksToAbsoluteSeconds (MidiFile.Cons typ division tracks) = AbsEventList.mapTime realToFrac $ EventList.toAbsoluteEventList 0 $ MidiFile.secondsFromTicks division $ MidiFile.mergeTracks typ tracks selectTracks :: [Int] -> MidiFile.T -> Either String MidiFile.T selectTracks [] midi = Right midi selectTracks trackNos (MidiFile.Cons typ division tracks) = MidiFile.Cons typ division <$> let trackSet = IntSet.fromList trackNos in Trav.forM (zip [1..] tracks) $ \(trackNo,track) -> Right $ -- ToDo: check for multiple and non-existing tracks in trackNos if IntSet.member trackNo trackSet then track else EventList.filter isTempoEvent track isTempoEvent :: MidiEvent.T -> Bool isTempoEvent ev = case ev of MidiEvent.MetaEvent (MetaEvent.SetTempo _microsPerQN) -> True _ -> False selectTracks_ :: [Int] -> MidiFile.T -> Either String MidiFile.T selectTracks_ [] midi = Right midi selectTracks_ trackNos (MidiFile.Cons typ division tracks) = MidiFile.Cons typ division <$> let trackMap = IntMap.fromList $ zip [1..] tracks in Trav.forM trackNos $ \trackNo -> maybe (Left $ printf "track %d not available" trackNo) Right $ IntMap.lookup trackNo trackMap noteLetters :: [Char] noteLetters = ['C', '#', 'D', '#', 'E', 'F', '#', 'G', '#', 'A', '#', 'B', 'C'] noteNameList :: [String] noteNameList = ["C", "C#", "D", "D#", "E", "F", "F#", "G", "G#", "A", "A#", "B=H", "C"] noteNames :: Array Int String noteNames = listArray (0, length noteNameList - 1) noteNameList type List3 = FL.T3 type RGB = List3 Double noteColors :: Array Int RGB noteColors = let rgb = FL.consAll3 xs = rgb 90 0 0 : rgb 90 15 0 : rgb 95 35 0 : rgb 95 60 5 : rgb 100 75 0 : rgb 25 100 25 : rgb 5 70 20 : rgb 5 45 20 : rgb 0 20 65 : rgb 35 0 70 : rgb 55 0 55 : rgb 75 35 75 : rgb 90 0 0 : [] in listArray (0, length xs - 1) $ map (fmap (0.01*)) xs greyRGB :: Double -> RGB greyRGB = NonEmptyC.repeat grey :: Double -> PDF.Color grey brightness = PDF.Rgb brightness brightness brightness colorFromPitch :: Bool -> Int -> RGB colorFromPitch fullRange pitch = if fullRange || Array.inRange (0,12) pitch then noteColors ! mod pitch (snd $ Array.bounds noteColors) else greyRGB 0.5 selectDisplayedCups :: Bool -> Bool -> IntSet -> IntMap (RGB, Bool) selectDisplayedCups fullRange usedCupsOnly usedCups = let pitchRange = fromMaybe (0,0) $ liftA2 (,) (fst <$> IntSet.minView usedCups) (fst <$> IntSet.maxView usedCups) in IntMap.mapWithKey (\pitch used -> (colorFromPitch fullRange pitch, used)) $ IntMap.union (IntMap.fromSet (const True) usedCups) $ if usedCupsOnly then IntMap.empty else IntMap.fromSet (const False) $ IntSet.fromList $ Array.range pitchRange interpolateColor :: Double -> RGB -> RGB -> RGB interpolateColor k = NonEmptyC.zipWith (\x y -> (1-k)*x + k*y) {- overlapLoop abcdef abcdef abcdef abcdef abcdef abcdef abcdef abcdef abcdef abcdef abcdef abcdef -} -- ToDo: make hardwired parameters configurable -- ToDo: respect velocity -- ToDo: support a second instrument with different graphics on another MIDI channel (e.g. Klangbausteine) -- ToDo: process OctaMED input or convert OctaMED to MIDI writePDF :: FilePath -> [PDF.JpegFile] -> (Maybe Integer, Integer) -> Double -> Int -> PDF.FontName -> Int -> IntMap (RGB,Bool) -> [([Tube], [(Double, Double, String)])] -> IO () writePDF path backgroundFrames (bgRate,rate) bgOverlap heightPoints fontName fontHeightInt displayedCups blocks = do let fontHeight = fromIntegral fontHeightInt mBackgroundExtent = mapPair (fromIntegral, fromIntegral) . PDF.jpegBounds <$> listToMaybe backgroundFrames mBackgroundWidth = fmap (\(w,h) -> let k = height / h in (w * k, k)) mBackgroundExtent cupsBarWidth = fromIntegral (IntMap.size displayedCups) * fontHeight width = maybe cupsBarWidth (max cupsBarWidth . fst) mBackgroundWidth height = fromIntegral heightPoints bottom = 0.5 * fontHeight gradientHeight = height rect = PDF.PDFRect 0 0 width height -- printf "pitchrange: %d - %d\n" lowestPitch highestPitch let (bowHeight, tube) = if True then (0.2, \(l:+b) (r:+t) -> do let b1 = b - bowHeight*fontHeight let t1 = t - bowHeight*fontHeight PDF.beginPath (l:+b) PDF.curveto (l:+b1) (r:+b1) (r:+b) PDF.lineto (r:+t) PDF.curveto (r:+t1) (l:+t1) (l:+t) ) else (0, \lb rt -> PDF.addShape $ PDF.Rectangle lb rt) stdFont <- either (fail . show) return =<< PDF.mkStdFont fontName PDF.runPdf path PDF.standardDocInfo rect $ do backgroundObjs <- Trav.traverse PDF.createPDFJpeg backgroundFrames let backgrounds = let bgOverlapInt = round (bgOverlap * fromInteger (fromMaybe rate bgRate)) in let n = min bgOverlapInt $ div (length backgroundObjs) 2 in let (intro, extro) = ListHT.splitAtRev n backgroundObjs in let plain = map (\frame -> (Just frame, 0, Nothing)) in let loopOverlap = zipWith3 (\k tailFrame headFrame -> (Just tailFrame, if n == 0 then 0 else fromIntegral k / fromIntegral n, Just headFrame)) [(0::Int) ..] extro intro in case NonEmpty.fetch (loopOverlap ++ plain (drop n intro)) of Nothing -> repeat (Nothing, 0, Nothing) Just loopBody -> maybe id (flip resample rate) bgRate $ plain intro ++ NonEmpty.flatten (NonEmpty.cycle loopBody) fadingMask <- do let maskRect = PDF.Rectangle (0:+(-bowHeight*fontHeight)) (fontHeight:+gradientHeight) PDF.createSoftMask maskRect (PDF.paintWithShading (PDF.AxialShading 0 0 0 gradientHeight (PDF.ColorFunction1 PDF.GraySpace $ PDF.Interpolated1 1 1 0)) (PDF.addShape maskRect)) let cupRect = PDF.Rectangle (0:+(-bowHeight*fontHeight)) (fontHeight:+fontHeight) unusedCupMask <- do PDF.createSoftMask cupRect $ do PDF.fillColor $ grey 0.2 PDF.fill cupRect cupObjs <- Trav.sequence $ flip IntMap.mapWithKey displayedCups $ \pitch (color,used) -> fmap (flip (,) (color,used)) $ PDF.createTransparencyGroup PDF.RGBSpace cupRect $ drawCup (bowHeight, tube) stdFont fontHeightInt color pitch 1 Fold.for_ (zip blocks backgrounds) $ \((block, captions), (mBackgroundObj0, bgBlend, mBackgroundObj1)) -> do page <- PDF.addPage Nothing PDF.drawWithPage page $ do PDF.fillColor PDF.black PDF.fill $ PDF.Rectangle (0:+0) (width:+height) Fold.for_ (liftA2 (,) mBackgroundObj0 mBackgroundWidth) $ \(backgroundObj0, (w,sc)) -> PDF.withNewContext $ do let t = (width - w) / 2 PDF.applyMatrix $ PDF.translate (t:+0) PDF.applyMatrix $ PDF.scale sc sc PDF.drawXObject backgroundObj0 Fold.for_ mBackgroundObj1 $ \backgroundObj1 -> do PDF.setFillAlpha bgBlend PDF.drawXObject backgroundObj1 PDF.withNewContext $ do PDF.applyMatrix $ PDF.translate ((width - cupsBarWidth) / 2 :+ bottom) drawScene (bowHeight, tube) (fadingMask, unusedCupMask, cupObjs) stdFont fontHeightInt (width,height) block drawCaptions stdFont fontHeightInt (width,height) captions tubeShading :: PDF.PDFFloat -> RGB -> PDF.PDFShading tubeShading width rgb = PDF.AxialShading 0 0 width 0 (PDF.ColorFunction1 PDF.RGBSpace $ let triple = FL.uncurry3 (,,) in PDF.linearStitched (triple $ interpolateColor 0.8 (greyRGB 0) rgb) [(0.15, triple rgb), (0.30, triple $ interpolateColor 0.8 (greyRGB 1) rgb), (0.50, triple rgb) ] (triple $ greyRGB 0)) drawCup :: (PDF.PDFFloat, Complex PDF.PDFFloat -> Complex PDF.PDFFloat -> PDF.Draw ()) -> PDF.AnyFont -> Int -> RGB -> Int -> Double -> PDF.Draw () drawCup (bowHeight, tube) stdFont fontHeightInt color pitch flashShift = do let fontHeight = fromIntegral fontHeightInt let bowHalf = bowHeight/2 PDF.paintWithShading (tubeShading fontHeight $ interpolateColor flashShift (greyRGB 1) color) (tube (fontHeight*0.1 :+ fontHeight*(bowHalf-0.1)) (fontHeight*0.9 :+ fontHeight*(bowHalf+0.9))) PDF.fillColor $ grey flashShift PDF.setWidth 0.5 PDF.strokeColor PDF.black do let label = noteNames ! mod pitch (snd $ Array.bounds noteNames) let (upper, lower) = case break ('='==) label of (xs, "") -> ("", xs) (xs, ys) -> (xs, ys) let textColumns = max (length upper) (length lower) let font = PDF.PDFFont stdFont (div fontHeightInt textColumns) let upperText = fromString upper let lowerText = fromString lower let textWidth = max (PDF.textWidth font upperText) (PDF.textWidth font lowerText) let textLeft = (fontHeight - textWidth) / 2 when (not $ null upper) $ PDF.drawText $ do PDF.setFont font PDF.renderMode PDF.FillAndStrokeText PDF.textStart textLeft (fontHeight * 0.4) PDF.displayText upperText PDF.drawText $ do PDF.setFont font PDF.renderMode PDF.FillAndStrokeText PDF.textStart textLeft 0 PDF.displayText lowerText flashPos :: Double flashPos = 1 drawScene :: (PDF.PDFFloat, Complex PDF.PDFFloat -> Complex PDF.PDFFloat -> PDF.Draw ()) -> (PDF.SoftMask, PDF.SoftMask, IntMap (PDF.PDFReference PDF.PDFXForm, (RGB, Bool))) -> PDF.AnyFont -> Int -> (PDF.PDFFloat, PDF.PDFFloat) -> [Tube] -> PDF.Draw () drawScene (bowHeight, tube) (fadingMask, unusedCupMask, cupObjs) stdFont fontHeightInt (_width,height) block = do let flashVelocity = 1.1 let fontHeight = fromIntegral fontHeightInt let intMapFindIndex k m = IntMap.size $ fst $ IntMap.split k m let boxLeftFromPitch pitch = fromIntegral (intMapFindIndex pitch cupObjs) * fontHeight Fold.for_ block $ \(Tube from mTo pitch) -> do let boxLeft = boxLeftFromPitch pitch let boxBottom = fontHeight*from let boxTop = maybe height ((fontHeight*) . subtract 0.1) mTo PDF.withNewContext $ do PDF.applyMatrix $ PDF.translate (boxLeft:+(boxBottom+flashPos*fontHeight)) PDF.paintWithTransparency fadingMask $ PDF.paintWithShading (tubeShading fontHeight $ fst $ snd $ cupObjs IntMap.! pitch) (tube (fontHeight*0.1 :+ 0) (fontHeight*0.9 :+ (boxTop-boxBottom))) let headDistances = minimalDistanceToTubeHeads block Fold.sequence_ $ flip IntMap.mapWithKey cupObjs $ \pitch (cupObj, (color, used)) -> PDF.withNewContext $ do PDF.applyMatrix $ PDF.translate (boxLeftFromPitch pitch :+ 0) let flashShift = fromMaybe 1 $ do guard used dist <- IntMap.lookup pitch headDistances return $ min 1 $ flashVelocity*dist (if used then id else PDF.paintWithTransparency unusedCupMask) $ if flashShift == 1 then PDF.drawXObject cupObj else drawCup (bowHeight, tube) stdFont fontHeightInt color pitch flashShift drawCaptions :: PDF.AnyFont -> Int -> (PDF.PDFFloat, PDF.PDFFloat) -> [(PDF.PDFFloat, Double, String)] -> PDF.Draw () drawCaptions stdFont fontHeightInt (width,height) captions = do let fontHeight = fromIntegral fontHeightInt Fold.for_ captions $ \(k,alpha,caption) -> PDF.withNewContext $ do let captionLines = map fromString $ lines caption let font = PDF.PDFFont stdFont fontHeightInt PDF.fillColor PDF.white PDF.setWidth 0.5 PDF.strokeColor PDF.black PDF.applyMatrix $ PDF.translate $ (width :+ height)/2 PDF.applyMatrix $ PDF.scale k k PDF.applyMatrix $ PDF.translate $ (0 :+ fromIntegral (length captionLines) * fontHeight)/2 PDF.setStrokeAlpha alpha PDF.setFillAlpha alpha Fold.for_ captionLines $ \captionText -> do PDF.applyMatrix $ PDF.translate $ 0 :+ (-fontHeight) PDF.withNewContext $ do PDF.applyMatrix $ PDF.translate $ -(PDF.textWidth font captionText :+ 0)/2 PDF.drawText $ do PDF.setFont font PDF.renderMode PDF.FillAndStrokeText PDF.displayText captionText substituteWhiteSpace :: String -> String substituteWhiteSpace = map (\c -> case c of '\160' -> ' '; '\9252' -> '\n'; _ -> c) -- ToDo: import from utility-ht:Data.Maybe.HT maybePlus :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a maybePlus f mx my = liftA2 f mx my <|> mx <|> my animate :: Double -> Integer -> VoiceMsg.Pitch -> Bool -> Bool -> Background FilePath FilePath -> Maybe Integer -> Double -> Maybe (String, Maybe Double) -> Int -> Int -> [Int] -> FilePath -> FilePath -> IO () animate timeStep frameRate zeroKey fullRange usedCupsOnly backgroundPath backgroundRate backgroundOverlap forcedTitle heightPoints fontHeight trackNos input output = do let readJpegFile path = either (\msg -> exitFailureMsg $ printf "background image %s failed: %s" path msg) return =<< PDF.readJpegFile path background <- case backgroundPath of NoBackground -> return [] StillBackground path -> (:[]) <$> readJpegFile path AnimatedBackground dirPath -> do files <- Dir.listDirectory dirPath case List.sort files of [] -> exitFailureMsg $ printf "background image directory %s is empty" dirPath sortedFiles -> Trav.traverse (readJpegFile . (dirPath )) sortedFiles midi <- either fail return . selectTracks trackNos =<< MidiLoad.fromFile input let tickTrack = mergeTracksToAbsoluteTicks midi Fold.for_ (detectCorruptNotes show tickTrack) $ \warning -> when (not $ null warning) $ Log.warn Verbosity.normal $ warning ++ "\n" let origTrack = mergeTracksToAbsoluteSeconds midi Fold.for_ (detectCorruptNotes formatSeconds origTrack) $ \warning -> when (not $ null warning) $ Log.warn Verbosity.normal $ warning ++ "\n" let mTitleDuration = snd =<< forcedTitle let track = maybe origTrack (flip AbsEventList.delay origTrack) mTitleDuration {- FixMe: Unfortunately MidiFile.parse removes the trailing EndOfTrack. Thus we cannot easily add a pause at the end. -} let duration = AbsEventList.duration track -- printf "song duration: %f\n" duration let bottom = 0.5 let height = fromIntegral heightPoints / fromIntegral fontHeight let noteEvents = filterNotes zeroKey track let tubes = AbsEventList.toPairList $ AbsEventList.mapTime (/timeStep) noteEvents let usedCups = IntSet.fromList $ map (fst.snd) tubes -- when (IntSet.null usedCups) $ exitFailureMsg "no note found" let start = windowInitialize height tubes let frameRateFloat = fromInteger frameRate let ts = [0, recip frameRateFloat .. duration] let rows = map (/timeStep) ts let frames = scanl (\display times -> windowMove times display) start $ map (\row -> (row-bottom-flashPos, row+height-flashPos)) rows let lyrics = filterLyrics track let firstEventTime = fromMaybe defaultTitleDuration $ mTitleDuration <|> maybePlus min (listToMaybe $ AbsEventList.getTimes noteEvents) (listToMaybe $ map fst lyrics) -- print firstEventTime writePDF output background (backgroundRate,frameRate) backgroundOverlap heightPoints PDF.Helvetica_Bold fontHeight (selectDisplayedCups fullRange usedCupsOnly usedCups) $ zipWith3 (\row captions -> flip (,) captions . map (shiftTube (-row)) . windowLayout . fst) rows (zipWith (++) (layoutTitle frameRateFloat firstEventTime $ zipWith (\t -> map (mapFst (subtract t))) ts $ chop (drop 1 ts) $ -- ToDo: forcedTitle should replace any other titles in the file maybe id (\(title,_dur) -> ((0, substituteWhiteSpace title):)) forcedTitle $ filterTitle track) (layoutCounters frameRateFloat $ zipWith (\t -> map (mapFst (subtract t))) ts $ chop (drop 1 ts) lyrics)) frames info :: OP.Parser a -> OP.ParserInfo a info p = OP.info (OP.helper <*> p) (OP.fullDesc <> OP.progDesc "Generate boomwhacker animation from MIDI file.") data Background still anim = NoBackground | StillBackground still | AnimatedBackground anim deriving (Show) backgroundParser :: OP.Parser (Background FilePath FilePath) backgroundParser = pure NoBackground <|> (fmap StillBackground $ OP.strOption $ OP.long "background" <> OP.metavar "JPEG" <> OP.help "Background image") <|> (fmap AnimatedBackground $ OP.strOption $ OP.long "background-frames" <> OP.metavar "DIR" <> OP.help "Directory with frames of background video") parser :: OP.Parser (IO ()) parser = pure animate <*> OP.option OP.auto (OP.long "timestep" <> OP.metavar "SECONDS" <> OP.value 0.2 <> OP.help "time step between virtual character rows") <*> OP.option OP.auto (OP.long "rate" <> OP.metavar "FPS" <> OP.value 25 <> OP.help "frame rate") <*> (VoiceMsg.toPitch <$> OP.option OP.auto (OP.long "zerokey" <> OP.metavar "INT" <> OP.value 60 <> OP.help "MIDI key for the left-most tube")) <*> (OP.switch $ OP.long "full-range" <> OP.help "Draw all bars and cups with colors") <*> (OP.switch $ OP.long "used-cups-only" <> OP.help "Display only cups that are actually played somewhen") <*> backgroundParser <*> OP.option (Just <$> OP.auto) (OP.long "background-frame-rate" <> OP.metavar "FPS" <> OP.value Nothing <> OP.help "frame rate of background frames (default: same as --rate)") <*> OP.option OP.auto (OP.long "background-loop-overlap" <> OP.metavar "SECONDS" <> OP.value 0 <> OP.help "") <*> (OP.optional $ liftA2 (,) (OP.strOption $ OP.long "title" <> OP.metavar "TEXT" <> OP.help "Override title in MIDI file") (OP.optional $ OP.option (OP.eitherReader $ parseNumber "duration" (0<) "positive") $ OP.long "title-duration" <> OP.metavar "SECONDS" <> OP.help "Duration of title appearance including fading")) <*> (OP.option (OP.eitherReader $ parseNumber "height" (0<) "positive") $ OP.long "height" <> OP.metavar "POINTS" <> OP.value 720 <> OP.help "Height of the paper in typographical points") <*> (OP.option (OP.eitherReader $ parseNumber "font height" (0<) "positive") $ OP.long "font-height" <> OP.metavar "POINTS" <> OP.value 80 <> OP.help "Font height") <*> OP.many (OP.option (OP.eitherReader $ parseNumber "track number" (0<) "positive") $ OP.long "track" <> OP.metavar "ONEBASED" <> OP.help "Select input track") <*> OP.strArgument (OP.metavar "INPUT" <> OP.help "Input MIDI file") <*> OP.strArgument (OP.metavar "OUTPUT" <> OP.help "Output PDF file") main :: IO () main = join $ OP.execParser $ info parser