module Main where
import qualified Options.Applicative as OP
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
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.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, when)
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)
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 $
EventList.toAbsoluteEventList 0 $
MidiFile.mergeTracks typ $
map (MidiFile.secondsFromTicks division) tracks
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 = NonEmpty.T (NonEmpty.T (NonEmpty.T Empty.T))
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 :
[]
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
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
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
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
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)
(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
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
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 = 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 heightPoints PDF.Helvetica_Bold fontHeight usedCups $
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.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" <>
OP.help "Input MIDI file")
<*>
OP.strArgument
(OP.metavar "OUTPUT" <>
OP.help "Output PDF file")
main :: IO ()
main = join $ OP.execParser $ info parser