module Main where
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 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 as IntMap
import qualified Data.Map 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.Sequence as Seq
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 (mapFst, mapPair, swap, thd3)
import Data.Maybe (listToMaybe, fromMaybe)
import Data.String (fromString)
import Data.Complex (Complex((:+)))
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 ((<t).fst) evs) evs0 ts
filterTitle :: AbsEventList.T Double MidiEvent.T -> [(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 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)
writePDF ::
FilePath -> Maybe PDF.JpegFile -> Int -> PDF.FontName -> Int ->
IntMap (RGB,Bool) -> [([Tube], [(Double, Double, String)])] -> IO ()
writePDF
path mBackground heightPoints fontName fontHeightInt
displayedCups blocks = do
let fontHeight = fromIntegral fontHeightInt
mBackgroundExtent =
fmap (mapPair (fromIntegral, fromIntegral) . PDF.jpegBounds)
mBackground
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
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
mBackgroundObj <- Trav.traverse PDF.createPDFJpeg mBackground
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_ blocks $ \(block, captions) -> do
page <- PDF.addPage Nothing
PDF.drawWithPage page $ do
PDF.fillColor PDF.black
PDF.fill $ PDF.Rectangle (0:+0) (width:+height)
Fold.for_ (liftA2 (,) mBackgroundObj mBackgroundWidth) $
\(backgroundObj, (w,sc)) ->
PDF.withNewContext $ do
let t = (width - w) / 2
PDF.applyMatrix $ PDF.translate (t:+0)
PDF.applyMatrix $ PDF.scale sc sc
PDF.drawXObject backgroundObj
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 ->
FilePath -> Maybe (String, Maybe Double) -> Int -> Int -> [Int] ->
FilePath -> FilePath -> IO ()
animate
timeStep frameRate zeroKey fullRange usedCupsOnly
backgroundPath forcedTitle heightPoints fontHeight trackNos
input output = do
background <-
if null backgroundPath
then return Nothing
else
either
(\msg ->
exitFailureMsg $
printf "background image %s failed: %s" backgroundPath msg)
(return . Just)
=<< PDF.readJpegFile backgroundPath
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
let duration = AbsEventList.duration track
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
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)
writePDF output
background 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) $
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.")
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")
<*>
(OP.strOption $
OP.long "background" <>
OP.metavar "JPEG" <>
OP.value "" <>
OP.help "Background image")
<*>
(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