boomwhacker 0.0 → 0.0.1
raw patch · 3 files changed
+135/−44 lines, 3 filesdep +non-emptydep +shell-utility
Dependencies added: non-empty, shell-utility
Files
- Makefile +4/−4
- boomwhacker.cabal +4/−2
- src/Main.hs +127/−38
Makefile view
@@ -4,15 +4,15 @@ #RATE = 25 #RATE = 10 -RESOLUTION = -g1920x1080 -r540-#RESOLUTION = -g1280x720 -r360-#RESOLUTION = -g960x540 -r270+RESOLUTION = -dDEVICEHEIGHT=1080 -r108+#RESOLUTION = -dDEVICEHEIGHT=720 -r72+#RESOLUTION = -dDEVICEHEIGHT=540 -r54 %.pdf: %.mid cabal run boomwhacker -- --rate $(RATE) $< $@ %.wav: %.mid- timidity -A300 -Ow $<+ timidity --preserve-silence -A300 -Ow $< # Resolution is one Postscript point (1/72 inch). %.frames: %.pdf
boomwhacker.cabal view
@@ -1,5 +1,5 @@ Name: boomwhacker-Version: 0.0+Version: 0.0.1 Synopsis: Convert MIDI file to play-along boomwhacker animation Description: Convert MIDI file to play-along boomwhacker animation:@@ -25,7 +25,7 @@ Makefile Source-Repository this- Tag: 0.0+ Tag: 0.0.1 Type: darcs Location: https://hub.darcs.net/thielema/boomwhacker @@ -36,10 +36,12 @@ Executable boomwhacker Build-Depends: HPDF >=1.6 && <1.7,+ 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, array >=0.4 && <0.6, utility-ht >=0.0.10 && <0.1,
src/Main.hs view
@@ -4,6 +4,8 @@ import qualified Graphics.PDF as PDF +import Shell.Utility.ParseArgument (parseNumber)+ import qualified Sound.MIDI.Message.Class.Query as Query import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.File.Load as MidiLoad@@ -16,15 +18,21 @@ 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.Foldable as Fold+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Empty as Empty import Data.IntMap (IntMap)+import Data.IntSet (IntSet) import Data.Map (Map) import Data.Array (Array, listArray, (!)) import Data.Tuple.HT (mapTriple, thd3)+import Data.NonEmpty ((!:)) import Data.String (fromString) import Data.Complex (Complex((:+))) -import Control.Monad (join)+import Control.Monad (join, when) import Control.Applicative ((<$>), (<*>)) @@ -100,7 +108,12 @@ (\(pitch, from) -> (from, Nothing, pitch)) (IntMap.toList unterminated) +minimalDistanceToTubeHeads :: [(Double, Maybe Double, Int)] -> IntMap Double+minimalDistanceToTubeHeads =+ IntMap.fromListWith min .+ map (\(from, _mTo, pitch) -> (pitch, abs from)) + mergeTracksToAbsolute :: MidiFile.T -> AbsEventList.T Double MidiEvent.T mergeTracksToAbsolute (MidiFile.Cons typ division tracks) = AbsEventList.mapTime realToFrac $@@ -109,11 +122,22 @@ map (MidiFile.secondsFromTicks division) tracks -noteNames :: [Char]-noteNames =- ['C', '#', 'D', '#', 'E', 'F', '#', 'G', '#', 'A', '#', 'H', 'C']+noteLetters :: [Char]+noteLetters =+ ['C', '#', 'D', '#', 'E', 'F', '#', 'G', '#', 'A', '#', 'B', 'C'] -noteColors :: Array Int PDF.Color+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 = NonEmpty.T (NonEmpty.T (NonEmpty.T Empty.T))+type RGB = List3 Double++noteColors :: Array Int RGB noteColors = let xs = (,,) 90 0 0 :@@ -131,28 +155,46 @@ (,,) 90 0 0 : [] in listArray (0, length xs - 1) $- map (\(r,g,b) -> PDF.Rgb (0.01*r) (0.01*g) (0.01*b)) xs+ 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++ grey :: Double -> PDF.Color grey brightness = PDF.Rgb brightness brightness brightness -colorFromPitch :: Int -> PDF.Color-colorFromPitch pitch =- if Array.inRange (Array.bounds noteColors) pitch- then noteColors ! pitch- else grey 0.5 +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 +interpolateColor :: Double -> RGB -> RGB -> RGB+interpolateColor k = NonEmptyC.zipWith (\x y -> (1-k)*x + k*y)++ writePDF ::- FilePath -> PDF.FontName -> Int -> [[(Double, Maybe Double, Int)]] -> IO ()-writePDF path fontName fontHeight_ blocks = do+ FilePath -> Int -> PDF.FontName -> Int ->+ IntSet -> [[(Double, Maybe Double, Int)]] -> IO ()+writePDF path heightPoints fontName fontHeight_ usedCups blocks = do let fontHeight = fromIntegral fontHeight_- width = 16 * fontHeight- height = 9 * fontHeight- bottom = 0.5 * fontHeight- left = 20- gradientHeight = 9- boxLeftFromPitch pitch = left + fromIntegral pitch * 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+ 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@@ -180,45 +222,80 @@ PDF.paintWithShading (PDF.AxialShading boxLeft (bottom+fontHeight*(from-bowHeight))- boxLeft (bottom+fontHeight*(from+gradientHeight))- (colorFromPitch pitch) PDF.black) $+ 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)- Fold.for_ (zip [0..] noteNames) $ \(pitch,char) -> do- PDF.fillColor $ colorFromPitch pitch+ 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- PDF.fillColor PDF.white++ PDF.fillColor $ grey $ brightness*flashShift PDF.setWidth 0.5- PDF.strokeColor (grey 0.1)- PDF.drawText $ do- let font = PDF.PDFFont stdFont fontHeight_- PDF.setFont font- let label = fromString [char]- let leftOffset = (fontHeight - PDF.textWidth font label) / 2- PDF.textStart (boxLeft + leftOffset) bottom- PDF.renderMode PDF.FillAndStrokeText- PDF.displayText label+ 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 -animate :: Double -> Integer -> VoiceMsg.Pitch -> FilePath -> FilePath -> IO ()-animate timeStep frameRate zeroKey input output = do+animate ::+ Double -> Integer -> VoiceMsg.Pitch ->+ 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 let bottom = 0.5- let height = 9- let start = windowInitialize height $ layoutTubes timeStep zeroKey track+ let height = fromIntegral heightPoints / fromIntegral fontHeight+ let tubes = layoutTubes timeStep zeroKey track+ let usedCups = IntSet.fromList $ map (fst.snd) tubes+ let start = windowInitialize height tubes let ts = map (/timeStep) [0, recip (fromInteger frameRate) .. duration] let frames = scanl (\display times -> windowMove times display) start $ map (\t -> (t-bottom, t+height)) ts- writePDF output PDF.Helvetica_Bold 16 $+ writePDF output heightPoints PDF.Helvetica_Bold fontHeight usedCups $ zipWith (\t -> map (mapTriple (subtract t, fmap (subtract t), id)) .@@ -256,6 +333,18 @@ OP.metavar "INT" <> OP.value 60 <> OP.help "MIDI key for the left-most tube"))+ <*>+ (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.strArgument (OP.metavar "INPUT" <>