boomwhacker 0.0.1 → 0.0.2
raw patch · 3 files changed
+711/−150 lines, 3 filesdep +non-negativedep +timedep +transformersdep ~HPDFdep ~containersdep ~event-list
Dependencies added: non-negative, time, transformers
Dependency ranges changed: HPDF, containers, event-list, filepath, non-empty, optparse-applicative
Files
- ShakeRules.hs +164/−0
- boomwhacker.cabal +13/−7
- src/Main.hs +534/−143
+ ShakeRules.hs view
@@ -0,0 +1,164 @@+module ShakeRules where++import Development.Shake+import Development.Shake.FilePath+import Control.Monad (guard, when)+import Text.Printf (printf)+import qualified Data.List as List++++data Configuration =+ Configuration {+ useBackground :: Bool,+ frameRate :: Integer,+ resolution :: Integer,+ antialias :: [String],+ pages :: [String]+ }++defaultConfig :: Configuration+defaultConfig =+ Configuration {+ useBackground = True,+ frameRate = 50,+ resolution = 108,+ antialias = ["-dTextAlphaBits=2", "-dGraphicsAlphaBits=2"],+ pages = []+ }++previewConfig :: Configuration+previewConfig =+ Configuration {+ useBackground = False,+ frameRate = 25,+ resolution = 54,+ antialias = [],+ pages = []+ }++tmpRoot :: FilePath+tmpRoot = "/tmp"++tmpFramesDir :: String -> FilePath+tmpFramesDir stem = tmpRoot </> stem <> "-frames"+++{-+tif24nc and ppmraw are much faster than png16m,+but occupy more temporary space.+-}+framePattern :: FilePath; frameFormat :: String+(framePattern, frameFormat) =+ case id '_' of+ 'p' -> ("%04d.png", "png16m")+ 't' -> ("%04d.tif", "tif24nc")+ _ -> ("%04d.ppm", "ppmraw")++require :: FilePath -> Action FilePath+require path = do+ need [path]+ return path++whenAvailable :: FilePath -> (FilePath -> Action ()) -> Action ()+whenAvailable path act = do+ available <- doesFileExist path+ when available $ act path+++chooseAudioSource :: FilePath -> [String] -> Action FilePath+chooseAudioSource stem audioFormats = do+ let audioSrcs = map (stem <.>) audioFormats+ available <- traverse doesFileExist audioSrcs+ case filter fst $ zip available audioSrcs of+ (_,audioSrc):_ -> return audioSrc+ _ -> fail "No audio source available"+++configured :: Configuration -> FilePath -> Rules ()+configured config prefix = do+ prefix <> "*.pdf" %> \dst -> do+ let base = takeBaseName dst+ midi <- require $ base <.> "mid"+ let background = base <.> "jpeg"+ backgroundAvailable <-+ if useBackground config+ then doesFileExist background+ else return False+ let optionsFile = base <.> "options"+ optionsAvailable <- doesFileExist optionsFile+ options <-+ if optionsAvailable+ then readFile' optionsFile+ else return ""+ let titleFile = base <.> "title"+ titleAvailable <- doesFileExist titleFile+ title <-+ if titleAvailable+ then fmap (\str -> ["--title", str]) $ readFile' titleFile+ else return []+ cmd_ "boomwhacker" title options "--rate" (show $ frameRate config)+ (guard backgroundAvailable >> ["--background", background])+ [midi, dst]++ tmpRoot </> prefix <> "*.frames" %> \dst -> do+ let stem =+ maybe+ (error "cannot strip temporary directory prefix")+ (dropExtension . dropWhile (pathSeparator==))+ (List.stripPrefix tmpRoot dst)+ pdf <- require $ stem <.> "pdf"+ let framesDir = tmpFramesDir stem+ cmd_ "mkdir" "-p" [framesDir] -- avoid failure of 'rm -r'+ cmd_ "rm" "-r" [framesDir]+ cmd_ "mkdir" "-p" [framesDir]+ cmd_ "gs-parallel" "-j6"+ (pages config) pdf (framesDir </> framePattern) "--"+ "-dNOPAUSE" "-dBATCH"+ ("-sDEVICE="++frameFormat) (antialias config)+ [printf "-dDEVICEHEIGHT=%d" (resolution config * 10) :: String]+ [printf "-r%d" (resolution config) :: String]+ cmd_ "touch" [dst]++ prefix <> "*.flv" %> \dst -> do+ let stem = dropExtension dst+ need [tmpRoot </> stem <.> "frames"]+ let framesDir = tmpFramesDir stem+ audioSrc <- chooseAudioSource (takeBaseName dst) ["mp3", "aac", "wav"]+ cmd_ "ffmpeg" "-r" (show $ frameRate config) "-f" "image2"+ "-i" [framesDir </> framePattern]+ "-i" [audioSrc]+ "-vcodec" "flashsv" "-acodec" "copy" "-y" [dst]++ prefix <> "*.mp4" %> \dst -> do+ let stem = dropExtension dst+ need [tmpRoot </> stem <.> "frames"]+ let framesDir = tmpFramesDir stem+ audioSrc <-+ chooseAudioSource (takeBaseName dst) ["mp3", "aac", "flac", "wav"]+ cmd_ "ffmpeg" "-r" (show $ frameRate config) "-f" "image2"+ "-i" [framesDir </> framePattern]+ "-i" [audioSrc]+ "-b:v" "8000k" "-acodec" "copy" "-y" [dst]+++generic :: Rules ()+generic = do+ "//*.inspect-csv" %> \dst -> do+ let Just stem = stripExtension "inspect-csv" dst+ src <- require $ stem <.> "mid"+ cmd_ "midicsv" [src, dst]++ "//*.mid" %> \dst ->+ whenAvailable (dst -<.> "csv") $ \src -> do+ cmd_ "csvmidi" [src, dst]++ "//*.csv" %> \dst ->+ whenAvailable (dst -<.> "fods") $ \src -> do+ Stdout csvUtf8 <- cmd "ods2csv" "--sheetnumber" "1" [src]+ cmd_ "iconv" "-f" "utf8" "-t" "latin1"+ (StdinBS csvUtf8) (FileStdout dst)++ "//*.wav" %> \dst ->+ whenAvailable (dst -<.> "mid") $ \src -> do+ cmd_ "timidity" "--preserve-silence" "-A300" "-Ow" [src]
boomwhacker.cabal view
@@ -1,5 +1,5 @@ Name: boomwhacker-Version: 0.0.1+Version: 0.0.2 Synopsis: Convert MIDI file to play-along boomwhacker animation Description: Convert MIDI file to play-along boomwhacker animation:@@ -24,8 +24,11 @@ Extra-Source-Files: Makefile +Data-Files:+ ShakeRules.hs+ Source-Repository this- Tag: 0.0.1+ Tag: 0.0.2 Type: darcs Location: https://hub.darcs.net/thielema/boomwhacker @@ -35,14 +38,17 @@ Executable boomwhacker Build-Depends:- HPDF >=1.6 && <1.7,+ HPDF >=1.7 && <1.8,+ time >=1.8 && <1.14, shell-utility >=0.1 && <0.2, optparse-applicative >=0.11 && <0.19, midi >=0.2.2 && <0.3,- event-list >=0.1.1 && <0.2,- filepath >=1.3 && <1.5,- non-empty >=0.2 && <0.4,- containers >=0.4 && <0.7,+ event-list >=0.1.3 && <0.2,+ non-negative >=0.1.2 && <0.2,+ filepath >=1.3 && <1.6,+ transformers >=0.3 && <0.7,+ non-empty >=0.3.4 && <0.4,+ containers >=0.4 && <0.8, array >=0.4 && <0.6, utility-ht >=0.0.10 && <0.1, base >=4.5 && <5
src/Main.hs view
@@ -4,39 +4,54 @@ 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.NonEmpty as NonEmpty-import qualified Data.Empty as Empty+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.Tuple.HT (mapTriple, thd3)-import Data.NonEmpty ((!:))+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 Control.Monad (join, when)-import Control.Applicative ((<$>), (<*>))+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.@@ -64,17 +79,16 @@ farewellEvents time (terminated, unterminated) = (thd3 $ Map.splitLookup time terminated, unterminated) -layoutTubes ::+filterNotes :: (Query.C ev) =>- Double -> VoiceMsg.Pitch ->- AbsEventList.T Double ev -> [(Double, (Int, Bool))]-layoutTubes timeStep zeroKey =- AbsEventList.toPairList .+ VoiceMsg.Pitch ->+ AbsEventList.T Double ev -> AbsEventList.T Double (Int, Bool)+filterNotes zeroKey = AbsEventList.mapMaybe (\ev -> do- (_c, (_v, p, noteOn)) <- Query.noteExplicitOff ev- return (VoiceMsg.subtractPitch zeroKey p, noteOn)) .- AbsEventList.mapTime (/timeStep)+ (c, (_v, p, noteOn)) <- Query.noteExplicitOff ev+ guard $ c /= GeneralMidi.drumChannel+ return (VoiceMsg.subtractPitch zeroKey p, noteOn)) windowInitialize :: Double -> [(Double, (Int, Bool))] ->@@ -97,31 +111,180 @@ newDisplayed, remaining) -windowLayout :: VisibleTubes -> [(Double, Maybe Double, Int)]+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) -> (from, Just to, pitch)))+ (\to -> map (\(from, pitch) -> Tube from (Just to) pitch)) terminated) ++ map- (\(pitch, from) -> (from, Nothing, pitch))+ (\(pitch, from) -> Tube from Nothing pitch) (IntMap.toList unterminated) -minimalDistanceToTubeHeads :: [(Double, Maybe Double, Int)] -> IntMap Double+minimalDistanceToTubeHeads :: [Tube] -> IntMap Double minimalDistanceToTubeHeads = IntMap.fromListWith min .- map (\(from, _mTo, pitch) -> (pitch, abs from))+ map (\(Tube from _mTo pitch) -> (pitch, -from)) .+ filter (\(Tube from _mTo _pitch) -> from<=0) -mergeTracksToAbsolute :: MidiFile.T -> AbsEventList.T Double MidiEvent.T-mergeTracksToAbsolute (MidiFile.Cons typ division tracks) =+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.mergeTracks typ $- map (MidiFile.secondsFromTicks division) tracks+ 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']@@ -134,73 +297,85 @@ noteNames = listArray (0, length noteNameList - 1) noteNameList -type List3 = NonEmpty.T (NonEmpty.T (NonEmpty.T Empty.T))+type List3 = FL.T3 type RGB = List3 Double noteColors :: Array Int RGB noteColors =- let xs =- (,,) 90 0 0 :- (,,) 90 15 0 :- (,,) 95 35 0 :- (,,) 95 60 5 :- (,,) 95 100 10 :- (,,) 25 100 25 :- (,,) 5 70 20 :- (,,) 5 45 20 :- (,,) 0 20 65 :- (,,) 35 0 70 :- (,,) 55 0 55 :- (,,) 75 35 75 :- (,,) 90 0 0 :+ 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 (\(r,g,b) -> 0.01*r !: 0.01*g !: 0.01*b !: Empty.Cons) xs---uncurry3 ::- (a -> a -> a -> b) ->- NonEmpty.T (NonEmpty.T (NonEmpty.T Empty.T)) a -> b-uncurry3 f- (NonEmpty.Cons x0 (NonEmpty.Cons x1 (NonEmpty.Cons x2 Empty.Cons))) =- f x0 x1 x2+ 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 :: (Int,Int) -> Double -> Int -> RGB-colorFromPitch pitchRange brightness pitch =- if Array.inRange pitchRange pitch- then fmap (brightness*) $- noteColors ! mod pitch (snd $ Array.bounds noteColors)- else NonEmptyC.repeat $ brightness*0.5+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 -> Int -> PDF.FontName -> Int ->- IntSet -> [[(Double, Maybe Double, Int)]] -> IO ()-writePDF path heightPoints fontName fontHeight_ usedCups blocks = do- let fontHeight = fromIntegral fontHeight_- lowestPitch = maybe 0 (min 0 . fst) $ IntSet.minView usedCups- highestPitch = maybe 12 (max 12 . fst) $ IntSet.maxView usedCups- pitchRange = (lowestPitch, highestPitch)- width = fromIntegral (highestPitch-lowestPitch+1) * fontHeight+ 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- flashVelocity = 1.5 gradientHeight = height- boxLeftFromPitch pitch = fromIntegral (pitch - lowestPitch) * fontHeight rect = PDF.PDFRect 0 0 width height let (bowHeight, tube) = if True then (0.2,- \l b r t -> do+ \(l:+b) (r:+t) -> do let b1 = b - bowHeight*fontHeight let t1 = t - bowHeight*fontHeight PDF.beginPath (l:+b)@@ -208,99 +383,282 @@ PDF.lineto (r:+t) PDF.curveto (r:+t1) (l:+t1) (l:+t) )- else (0, \l b r t -> PDF.addShape $ PDF.Rectangle (l:+b) (r:+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 $- Fold.for_ blocks $ \block -> do+ 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_ block $ \(from,mTo,pitch) -> do- let boxLeft = boxLeftFromPitch pitch- let to = maybe height ((fontHeight*) . subtract 0.1) mTo- PDF.paintWithShading- (PDF.AxialShading- boxLeft (bottom+fontHeight*(from-bowHeight))- boxLeft (bottom+fontHeight*from+gradientHeight)- (uncurry3 PDF.Rgb $- colorFromPitch pitchRange 1 pitch)- PDF.black) $- tube- (boxLeft+fontHeight*0.1) (bottom+fontHeight*from)- (boxLeft+fontHeight*0.9) (bottom+to)- let headDistances = minimalDistanceToTubeHeads block- Fold.for_ (Array.range pitchRange) $ \pitch -> do- let (brightness, flashShift) =- if IntSet.member pitch usedCups- then (1.0, maybe 1- (\dist -> min 1 $ flashVelocity*dist) $- IntMap.lookup pitch headDistances)- else (0.2, 1)- PDF.fillColor $ uncurry3 PDF.Rgb $- interpolateColor flashShift (NonEmptyC.repeat 1) $- colorFromPitch pitchRange brightness pitch- let boxLeft = boxLeftFromPitch pitch- let bowHalf = bowHeight/2- tube- (boxLeft+fontHeight*0.1) (bottom+fontHeight*(bowHalf-0.1))- (boxLeft+fontHeight*0.9) (bottom+fontHeight*(bowHalf+0.9))- PDF.fillPath+ 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.fillColor $ grey $ brightness*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 fontHeight_ textColumns)- let upperText = fromString upper- let lowerText = fromString lower- let textWidth =- max- (PDF.textWidth font upperText)- (PDF.textWidth font lowerText)- let textLeft = boxLeft + (fontHeight - textWidth) / 2- when (not $ null upper) $ PDF.drawText $ do- PDF.setFont font- PDF.renderMode PDF.FillAndStrokeText- PDF.textStart textLeft (bottom + fontHeight * 0.4)- PDF.displayText upperText- PDF.drawText $ do- PDF.setFont font- PDF.renderMode PDF.FillAndStrokeText- PDF.textStart textLeft bottom- PDF.displayText lowerText+ 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 ->- Int -> Int ->+ Double -> Integer -> VoiceMsg.Pitch -> Bool -> Bool ->+ FilePath -> Maybe (String, Maybe Double) -> Int -> Int -> [Int] -> FilePath -> FilePath -> IO ()-animate timeStep frameRate zeroKey heightPoints fontHeight input output = do- midi <- MidiLoad.fromFile input- let track = mergeTracksToAbsolute midi- let duration = maybe 0 (fst.snd) $ AbsEventList.viewR track+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 tubes = layoutTubes timeStep zeroKey track+ 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 ts = map (/timeStep) [0, recip (fromInteger frameRate) .. duration]+ 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 (\t -> (t-bottom, t+height)) ts- writePDF output heightPoints PDF.Helvetica_Bold fontHeight usedCups $- zipWith- (\t ->- map (mapTriple (subtract t, fmap (subtract t), id)) .- windowLayout . fst)- ts+ 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 @@ -319,7 +677,7 @@ (OP.long "timestep" <> OP.metavar "SECONDS" <> OP.value 0.2 <>- OP.help "time step between lines")+ OP.help "time step between virtual character rows") <*> OP.option OP.auto (OP.long "rate" <>@@ -334,6 +692,32 @@ 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" <>@@ -345,6 +729,13 @@ 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" <>