diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/boomwhacker.cabal b/boomwhacker.cabal --- a/boomwhacker.cabal +++ b/boomwhacker.cabal @@ -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, diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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" <>