med-module-0.0: example/Animate.hs

module Main where

import qualified Animate.Option as Option
import qualified Options.Applicative as OP
import System.FilePath(dropExtension, (<.>))

import qualified Sound.MED.Generic as MED
import qualified Sound.MED.Generic.Block as MEDBlock
import qualified Sound.MED.Generic.Tempo as MEDTempo
import qualified Sound.MED.Generic.PlaySeq as MEDPlaySeq
import Sound.MED.Generic.Block(Cmd,Val)
import Sound.MED.Basic.Human(human)

import qualified Graphics.PS as PS
import Graphics.PS ((+++))

import qualified Data.Array as Array
import qualified Data.Foldable as Fold
import qualified Data.NonEmpty as NonEmpty
import qualified Data.List.Match as Match
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Array (Array, listArray, (!))
import Data.Maybe.HT (toMaybe)
import Data.Maybe (fromMaybe, isJust)
import Data.Tuple.HT (thd3)
import Text.Printf (printf)
import Data.Monoid (Any(Any,getAny))

import qualified Control.Monad.Trans.Writer as MW
import qualified Control.Monad.Trans.Class as MT
import Control.Monad(when, void, msum)
import Control.Applicative((<$>), (<|>))

main :: IO ()
main = do
  (options, mmds) <- OP.execParser $ Option.info Option.parser
  mapM_ (animate options) mmds

animate :: Option.Option -> FilePath -> IO ()
animate opt file = do
    med <- MED.load file
    let initTempo = MED.tempo med
    void $ printf "tempo primary: %d, secondary %d\n"
      (MEDTempo.primary initTempo) (MEDTempo.secondary initTempo)
    sequ <-
      case MED.playseqs med of
        sequ:_ -> return sequ
        [] -> ioError $ userError "no play sequence available"
    putStrLn $ human sequ
    let blocks = map MEDBlock.seqdata $ MED.blocks med
    let loop = Option.repeatUntil opt
    let allLines = flattenLines (isJust loop) blocks $ MEDPlaySeq.indices sequ
    let durations =
          maybe id takeUntilTime loop $ map MEDTempo.toTime $
          NonEmpty.tail $ NonEmpty.scanl (foldl MEDTempo.update) initTempo $
          map (concatMap thd3 . snd . snd . snd) allLines
    let formattedLines = map highlightLine allLines
    let pre = Option.contextSize opt
    let post = Option.contextSize opt
    let textWidth =
          maximum $ map (length . snd) $
          take (length durations + post) formattedLines
    writePostscript (dropExtension file <.> "ps")
        (Option.height opt) (pre,post) textWidth $
      zip (brightnesses (Option.fadeOut opt) durations) $
      map (take (pre+1+post)) $ ListHT.tails $
      replicate pre ((False,False),"") ++ formattedLines
    when (not $ null $ Option.framePattern opt) $
      writeFile (dropExtension file <.> "cue") $ concat $
        zipWith (printf "file '%s'\nduration %.5f\n")
          (map (formatFramePath $ Option.framePattern opt) [1 ..])
          durations

brightnesses :: Double -> [Double] -> [Double]
brightnesses fadeOutDur durations =
  let totalTime = sum durations
      fadeOutStart = totalTime - fadeOutDur
  in  map
        (\time ->
          if time < fadeOutStart || fadeOutDur <= 0
            then 1
            else (totalTime-time) / fadeOutDur) $
      NonEmpty.init $ NonEmpty.scanl (+) 0 durations

takeUntilTime :: Double -> [Double] -> [Double]
takeUntilTime =
  let go _ [] = []
      go end (dur:durs) = if dur>=end then [end] else dur : go (end-dur) durs
  in  go

{- |
Traverse playing sequence but ignore control commands.
If the playing sequence is finite, the flattened list of lines will be, too.
-}
flattenLinesSimple :: Bool -> [[line]] -> [Int] -> [(Bool,(Int,line))]
flattenLinesSimple loop blocks =
  let blockArr = arrayFromList blocks
  in  (if loop then cycle else id) .
      concatMap (addTrailingTrue . zip [0..] . (blockArr !))

flattenLinesArr :: Bool -> [[line]] -> [Int] -> [(Bool,(Int,line))]
flattenLinesArr loop blocks =
  let blockArr = arrayFromList $ map arrayFromList blocks
  in  (if loop then cycle else id) .
      concatMap (addTrailingTrue . Array.assocs . (blockArr !))

addTrailingTrue :: [a] -> [(Bool,a)]
addTrailingTrue xs = zip (Match.replicate (drop 1 xs) False ++ [True]) xs

flattenLines ::
  Bool -> [[MEDBlock.Line]] -> [Int] -> [(Bool,(Int,MEDBlock.Line))]
flattenLines loop blocks sequ =
  let blockArr = arrayFromList $ map arrayFromList blocks
      sequArr = arrayFromList sequ
      sequLength = length sequ
      accessLine (SongPos sequIdx line) =
        let block = blockArr!(sequArr!sequIdx)
        in  ((line, block!line), Array.rangeSize $ Array.bounds block)
  in  List.unfoldr
        (fmap $ \pos ->
          let (line,blockLength) = accessLine pos
              (endOfBlock, newSongPos) =
                nextSongPos loop sequLength blockLength pos $
                concatMap thd3 $ snd $ snd line
          in  ((endOfBlock, line), newSongPos))
        (Just $ SongPos 0 0)

data SongPos = SongPos {posSequ, posLine :: Int}

nextSongPos ::
  Bool -> Int -> Int -> SongPos -> [(Cmd, Val)] -> (Bool, Maybe SongPos)
nextSongPos loop sequLength blockLength pos cmds =
  let newSongPos =
        MW.runWriterT $
          adjustSongPos loop sequLength blockLength =<<
          cumulatedSongPosUpdate loop pos cmds
  in  (maybe False (getAny.snd) newSongPos, fst<$>newSongPos)

data SongPosCmds =
  SongPosCmds {
    posCmd0F00, posCmd0FFE :: Bool,
    posCmd1Dxx :: Maybe Int,
    posCmd0Bxx :: Maybe Int
  }

{-
If there are multiple flow control commands in a line
then the behavior of MED is complex and undocumented.
Here is, what I found out:
@0FFE@ overrides all other three flow control commands.
@1Dxx@ overrides @0F00@,
@0Bxx@ and @1Dxx@ are combined, as well as @0Bxx@ and @0F00@.
If there are multiple @0Bxx@ commands in a line
then the right-most and then the deep-most wins
(deep with respect to command pages).
The same applies to multiple @1Dxx@ commands.
-}
cumulatedSongPosUpdate ::
  Bool -> SongPos -> [(Cmd, Val)] -> MW.WriterT Any Maybe SongPos
cumulatedSongPosUpdate loop pos@(SongPos sequIdx _line) cmds0 =
  let cum = foldl update start cmds0
      start =
        SongPosCmds {
          posCmd0F00 = False, posCmd0FFE = False,
          posCmd1Dxx = Nothing, posCmd0Bxx = Nothing
        }
      update cmds cmdVal =
        case cmdVal of
          (0x0F, 0x00) -> cmds{posCmd0F00 = True}
          (0x0F, 0xFE) -> cmds{posCmd0FFE = True}
          (0x1D, line) -> cmds{posCmd1Dxx = Just line}
          (0x0B, idx ) -> cmds{posCmd0Bxx = Just idx}
          _ -> cmds
      continue = flip (,) (Any False); break_ = flip (,) (Any True)
      breakBlock =
        case (posCmd0Bxx cum, posCmd1Dxx cum <|> toMaybe (posCmd0F00 cum) 0) of
          (Nothing, Nothing) -> Just $ continue $ incSongPos pos
          (Just idx, Nothing) -> toMaybe loop $ break_ $ SongPos idx 0
          (Nothing, Just line) -> Just $ break_ $ SongPos (sequIdx+1) line
          (Just idx, Just line) -> toMaybe loop $ break_ $ SongPos (idx+1) line
  in  if posCmd0FFE cum
        then MT.lift Nothing
        else MW.WriterT breakBlock


{- |
Simpler alternative to 'cumulatedSongPosUpdate'.
-}
leftMostSongPosUpdate ::
  Bool -> SongPos -> [(Cmd, Val)] -> MW.WriterT Any Maybe SongPos
leftMostSongPosUpdate loop pos =
  fromMaybe (return $ incSongPos pos) . msum . map (updateSongPos loop pos)

adjustSongPos :: Bool -> Int -> Int -> SongPos -> MW.WriterT Any Maybe SongPos
adjustSongPos loop sequLength blockLength pos0 =
  let endOfBlock = posLine pos0 >= blockLength
      pos1 = if endOfBlock then SongPos (posSequ pos0 + 1) 0 else pos0
  in  MW.WriterT $
        toMaybe (posSequ pos1 < sequLength) (pos1, Any endOfBlock)
        <|>
        toMaybe loop (SongPos 0 0, Any True)

incSongPos :: SongPos -> SongPos
incSongPos (SongPos sequIdx line) = SongPos sequIdx (line+1)

updateSongPos ::
  Bool -> SongPos -> (Cmd, Val) -> Maybe (MW.WriterT Any Maybe SongPos)
updateSongPos loop (SongPos sequIdx _line) cmdVal =
  fmap (MW.WriterT . fmap (flip (,) (Any True))) $
  case cmdVal of
    (0x0F, 0xFE) -> Just Nothing
    (0x0F, 0x00) -> Just $ Just $ SongPos (sequIdx+1) 0
    (0x1D, line) -> Just $ Just $ SongPos (sequIdx+1) line
    (0x0B, idx ) -> Just $ toMaybe loop $ SongPos idx 0
    _ -> Nothing


arrayFromList :: [a] -> Array Int a
arrayFromList xs = listArray (0, length xs - 1) xs

formatFramePath :: String -> Int -> FilePath
formatFramePath = printf


highlightLine :: (Bool, (Int, MEDBlock.Line)) -> ((Bool,Bool),String)
highlightLine (endOfBlock, (i, (highlight, ds))) =
  ((Fold.or highlight, endOfBlock), MEDBlock.humanLine i ds)

writePostscript ::
  FilePath -> Int -> (Int,Int) -> Int ->
  [(Double, [((Bool,Bool),String)])] -> IO ()
writePostscript path heightInt (pre,post) textWidth blocks =
  let height = fromIntegral heightInt
      width = fromIntegral textWidth * fontWidth + 2*left
      top = height - fontHeight - (height - fontHeight*(preR+1+postR))/2
      left = 80
      barWidth n = fromIntegral n * fontWidth + 2*barBorderH
      fontWidth = fontHeight*(3/5)
      fontHeight = 17
      barBorderH = 5
      barBorderV = 3
      postR = fromIntegral post
      preR = fromIntegral pre
      mmFromPt :: Double -> Int
      mmFromPt pt = round $ pt / PS.mm_pt 1
  in  PS.ps path (PS.Paper (mmFromPt width) (mmFromPt height)) $
      map
        (\(brightness,block) ->
          flip PS.over
            (PS.Fill (PS.greyGS brightness) $
             PS.rectangle (PS.Pt 0 0) width height) $
          foldr PS.over
            (PS.Fill (PS.greyGS (0.8*brightness))
              (PS.rectangle
                (PS.Pt (left-barBorderH) (top-preR*fontHeight-barBorderV))
                (barWidth $ length $ snd $ block!!pre) fontHeight)) $
          zipWith
            (\y ((highlight,endOfBlock),line) ->
              let font = if highlight then "Courier-Bold" else "Courier"
                  hline =
                    PS.Stroke (PS.greyGS 0) $
                    PS.line [PS.Pt (left-barBorderH) (y-barBorderV),
                             PS.Pt (left-barBorderH+barWidth(length line))
                                                    (y-barBorderV)]
              in  (if endOfBlock then PS.over hline else id) $
                  (PS.Fill (PS.greyGS 0) $
                    PS.MoveTo (PS.Pt left y) +++
                    PS.Text (PS.Font font fontHeight) line))
            (iterate (subtract fontHeight) top) block)
        blocks