boomwhacker (empty) → 0.0
raw patch · 5 files changed
+387/−0 lines, 5 filesdep +HPDFdep +arraydep +basesetup-changed
Dependencies added: HPDF, array, base, containers, event-list, filepath, midi, optparse-applicative, utility-ht
Files
- LICENSE +30/−0
- Makefile +35/−0
- Setup.lhs +3/−0
- boomwhacker.cabal +50/−0
- src/Main.hs +269/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Henning Thielemann++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Henning Thielemann nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Makefile view
@@ -0,0 +1,35 @@+.SECONDARY: %.frames++RATE = 50+#RATE = 25+#RATE = 10++RESOLUTION = -g1920x1080 -r540+#RESOLUTION = -g1280x720 -r360+#RESOLUTION = -g960x540 -r270++%.pdf: %.mid+ cabal run boomwhacker -- --rate $(RATE) $< $@++%.wav: %.mid+ timidity -A300 -Ow $<++# Resolution is one Postscript point (1/72 inch).+%.frames: %.pdf+ mkdir -p /tmp/$*-frames+ rm -f /tmp/$*-frames/*+ gs -sDEVICE=png16m -sOutputFile=/tmp/$*-frames/%04d.png \+ -dNOPAUSE -dBATCH -dTextAlphaBits=2 -dGraphicsAlphaBits=2 \+ $(RESOLUTION) $<+ touch $@++%.flv: %.frames %.wav+ ffmpeg -r $(RATE) -f image2 -i /tmp/$*-frames/%04d.png -i $*.wav \+ -vcodec flashsv -acodec copy -y $@++Roboter.flv: Roboter.frames Roboter.aac+ ffmpeg -r $(RATE) -f image2 -i /tmp/Roboter-frames/%04d.png -i Roboter.aac \+ -vcodec flashsv -acodec copy -y $@++README.html: README.md+ pandoc --standalone $< --output $@
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ boomwhacker.cabal view
@@ -0,0 +1,50 @@+Name: boomwhacker+Version: 0.0+Synopsis: Convert MIDI file to play-along boomwhacker animation+Description:+ Convert MIDI file to play-along boomwhacker animation:+ .+ Run it like so:+ .+ > boomwhacker song.mid song.pdf+ .+ @song.mid@ is the input file that must be a MIDI file.+ @song.pdf@ is the output file, a PDF file.+ You can convert the PDF to a series of PNG files using @ghostscript@+ and this one to a video using @ffmpeg@.+ See @Makefile@ for example command calls.+Homepage: https://hub.darcs.net/thielema/boomwhacker+License: BSD3+License-File: LICENSE+Author: Henning Thielemann+Maintainer: haskell@henning-thielemann.de+Category: Music, Sound+Build-Type: Simple+Cabal-Version: >=1.10+Extra-Source-Files:+ Makefile++Source-Repository this+ Tag: 0.0+ Type: darcs+ Location: https://hub.darcs.net/thielema/boomwhacker++Source-Repository head+ Type: darcs+ Location: https://hub.darcs.net/thielema/boomwhacker++Executable boomwhacker+ Build-Depends:+ HPDF >=1.6 && <1.7,+ optparse-applicative >=0.11 && <0.19,+ midi >=0.2.2 && <0.3,+ event-list >=0.1.1 && <0.2,+ filepath >=1.3 && <1.5,+ containers >=0.4 && <0.7,+ array >=0.4 && <0.6,+ utility-ht >=0.0.10 && <0.1,+ base >=4.5 && <5+ Hs-Source-Dirs: src+ Main-Is: Main.hs+ Default-Language: Haskell2010+ GHC-Options: -Wall -fwarn-incomplete-uni-patterns -fwarn-tabs
+ src/Main.hs view
@@ -0,0 +1,269 @@+module Main where++import qualified Options.Applicative as OP++import qualified Graphics.PDF as PDF++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+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 Data.Array as Array+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import qualified Data.Foldable as Fold+import Data.IntMap (IntMap)+import Data.Map (Map)+import Data.Array (Array, listArray, (!))+import Data.Tuple.HT (mapTriple, thd3)+import Data.String (fromString)+import Data.Complex (Complex((:+)))++import Control.Monad (join)+import Control.Applicative ((<$>), (<*>))++++{- |+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)++layoutTubes ::+ (Query.C ev) =>+ Double -> VoiceMsg.Pitch ->+ AbsEventList.T Double ev -> [(Double, (Int, Bool))]+layoutTubes timeStep zeroKey =+ AbsEventList.toPairList .+ AbsEventList.mapMaybe+ (\ev -> do+ (_c, (_v, p, noteOn)) <- Query.noteExplicitOff ev+ return (VoiceMsg.subtractPitch zeroKey p, noteOn)) .+ AbsEventList.mapTime (/timeStep)++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)++windowLayout :: VisibleTubes -> [(Double, Maybe Double, Int)]+windowLayout (terminated, unterminated) =+ Fold.fold+ (Map.mapWithKey+ (\to -> map (\(from, pitch) -> (from, Just to, pitch)))+ terminated)+ +++ map+ (\(pitch, from) -> (from, Nothing, pitch))+ (IntMap.toList unterminated)+++mergeTracksToAbsolute :: MidiFile.T -> AbsEventList.T Double MidiEvent.T+mergeTracksToAbsolute (MidiFile.Cons typ division tracks) =+ AbsEventList.mapTime realToFrac $+ EventList.toAbsoluteEventList 0 $+ MidiFile.mergeTracks typ $+ map (MidiFile.secondsFromTicks division) tracks+++noteNames :: [Char]+noteNames =+ ['C', '#', 'D', '#', 'E', 'F', '#', 'G', '#', 'A', '#', 'H', 'C']++noteColors :: Array Int PDF.Color+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 :+ []+ in listArray (0, length xs - 1) $+ map (\(r,g,b) -> PDF.Rgb (0.01*r) (0.01*g) (0.01*b)) xs++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+++writePDF ::+ FilePath -> PDF.FontName -> Int -> [[(Double, Maybe Double, Int)]] -> IO ()+writePDF path fontName fontHeight_ 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+ 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, \l b r t -> PDF.addShape $ PDF.Rectangle (l:+b) (r:+t))+ stdFont <- either (fail . show) return =<< PDF.mkStdFont fontName+ PDF.runPdf path PDF.standardDocInfo rect $+ Fold.for_ blocks $ \block -> 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))+ (colorFromPitch 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 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.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+++animate :: Double -> Integer -> VoiceMsg.Pitch -> FilePath -> FilePath -> IO ()+animate timeStep frameRate zeroKey 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 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 $+ zipWith+ (\t ->+ map (mapTriple (subtract t, fmap (subtract t), id)) .+ windowLayout . fst)+ ts+ 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 lines")+ <*>+ 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.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