diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,6 +5,3 @@ Limitations: * Ignores the rarely used looping commands `16` and `1E` without notice. - - * Columns of adjacent blocks are not aligned - if the number of command pages changes. diff --git a/example/Animate.hs b/example/Animate.hs --- a/example/Animate.hs +++ b/example/Animate.hs @@ -8,7 +8,7 @@ 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.Generic.Block(Note,Inst,Cmd,Val) import Sound.MED.Basic.Human(human) import qualified Graphics.PS as PS @@ -17,13 +17,15 @@ import qualified Data.Array as Array import qualified Data.Foldable as Fold import qualified Data.NonEmpty as NonEmpty +import qualified Data.List.Reverse.StrictSpine as ListRev import qualified Data.List.Match as Match import qualified Data.List.HT as ListHT import qualified Data.List as List +import qualified Data.Monoid.HT as Mn import Data.Array (Array, listArray, (!)) import Data.Maybe.HT (toMaybe) import Data.Maybe (fromMaybe, isJust) -import Data.Tuple.HT (thd3) +import Data.Tuple.HT (mapSnd, fst3, thd3) import Text.Printf (printf) import Data.Monoid (Any(Any,getAny)) @@ -55,14 +57,32 @@ 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 + let numLines = length durations + post + let usedTracks = + foldl (zipWithPad (||)) [] $ + map (notePattern . snd . snd) $ take numLines allLines + void $ putStrLn $ "used tracks: " ++ + unwords (map (\b -> if b then "X" else "_") usedTracks) + let stripLine = map snd . filter fst . zip usedTracks + let strippedLines = + if Option.stripNotelessTracks opt + then map (mapSnd (mapSnd (mapSnd stripLine))) allLines + else allLines + let countCommands = + if Option.stripZeroCommands opt + then numNonZeroCommands else numCommands + let maxCmdsPerTrack = + map (max 1) $ foldl (zipWithPad max) [] $ + map (countCommands . snd . snd) $ take numLines strippedLines + void $ putStrLn $ + "maximum commands per track: " ++ + List.intercalate ", " (map show maxCmdsPerTrack) + let formattedLines = map (highlightLine maxCmdsPerTrack) strippedLines + let textWidth = maximum $ map (length . snd) $ take numLines formattedLines writePostscript (dropExtension file <.> "ps") - (Option.height opt) (pre,post) textWidth $ + (Option.font opt) (Option.height opt) (pre,post) textWidth $ zip (brightnesses (Option.fadeOut opt) durations) $ map (take (pre+1+post)) $ ListHT.tails $ replicate pre ((False,False),"") ++ formattedLines @@ -223,21 +243,51 @@ formatFramePath = printf -highlightLine :: (Bool, (Int, MEDBlock.Line)) -> ((Bool,Bool),String) -highlightLine (endOfBlock, (i, (highlight, ds))) = - ((Fold.or highlight, endOfBlock), MEDBlock.humanLine i ds) +numCommands :: MEDBlock.Line -> [Int] +numCommands = map (length . thd3) . snd +numNonZeroCommands :: MEDBlock.Line -> [Int] +numNonZeroCommands = + map (length . ListRev.dropWhile ((0,0) ==) . thd3) . snd + +notePattern :: MEDBlock.Line -> [Bool] +notePattern = map ((/=0) . fst3) . snd + +zipWithPad :: (a -> a -> a) -> [a] -> [a] -> [a] +zipWithPad f = + let go xs [] = xs + go [] ys = ys + go (x:xs) (y:ys) = f x y : go xs ys + in go + + +highlightLine :: [Int] -> (Bool, (Int, MEDBlock.Line)) -> ((Bool,Bool),String) +highlightLine maxCmdsPerTrack (endOfBlock, (i, (highlight, ds))) = + ((Fold.or highlight, endOfBlock), humanLine maxCmdsPerTrack i ds) + +humanLine :: [Int] -> Int -> [(Note, Inst, [(Cmd, Val)])] -> String +humanLine maxCmdsPerTrack i ds = + let punwords = concatMap (' ':) + hCV = maybe " " (uncurry $ printf "%02X%02X") + hTrack maxCmds (n, j, cvs) = + printf "%s %02X%s" + (MEDBlock.notes!!n) j + (punwords $ map hCV $ + ListHT.padRight Nothing maxCmds $ map Just cvs) + in printf "%04X:%s" i $ punwords $ zipWith hTrack maxCmdsPerTrack ds + + writePostscript :: - FilePath -> Int -> (Int,Int) -> Int -> + FilePath -> Option.Font -> Int -> (Int,Int) -> Int -> [(Double, [((Bool,Bool),String)])] -> IO () -writePostscript path heightInt (pre,post) textWidth blocks = +writePostscript path font 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 + fontWidth = fontHeight * Option.fontRelativeWidth font + fontHeight = Option.fontHeight font barBorderH = 5 barBorderV = 3 postR = fromIntegral post @@ -257,7 +307,7 @@ (barWidth $ length $ snd $ block!!pre) fontHeight)) $ zipWith (\y ((highlight,endOfBlock),line) -> - let font = if highlight then "Courier-Bold" else "Courier" + let fontName = Option.fontName font ++ Mn.when highlight "-Bold" hline = PS.Stroke (PS.greyGS 0) $ PS.line [PS.Pt (left-barBorderH) (y-barBorderV), @@ -266,6 +316,6 @@ 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)) + PS.Text (PS.Font fontName fontHeight) line)) (iterate (subtract fontHeight) top) block) blocks diff --git a/example/Animate/Option.hs b/example/Animate/Option.hs --- a/example/Animate/Option.hs +++ b/example/Animate/Option.hs @@ -50,6 +50,13 @@ OP.metavar "POINTS" <> OP.value 720 <> OP.help "Height of the paper in typographical points") + <*> (OP.switch $ + OP.long "strip-zero-commands" <> + OP.help "Strip trailing command columns consisting entirely of 0000") + <*> (OP.switch $ + OP.long "strip-noteless-tracks" <> + OP.help "Strip tracks without notes") + <*> fontParser {- | Also allow numbers like @.123@ instead of @0.123@. @@ -70,5 +77,34 @@ repeatUntil :: Maybe Double, fadeOut :: Double, contextSize :: Int, - height :: Int + height :: Int, + stripZeroCommands, stripNotelessTracks :: Bool, + font :: Font + } + + +fontParser :: OP.Parser Font +fontParser = + pure Font + <*> (OP.strOption $ + OP.long "font" <> + OP.metavar "NAME" <> + OP.value "Courier" <> + OP.help "PostScript Font name") + <*> (OP.option readNonNeg $ + OP.long "font-height" <> + OP.metavar "POINTS" <> + OP.value 17 <> + OP.help "Font height") + <*> (OP.option readNonNeg $ + OP.long "font-relative-width" <> + OP.metavar "RATIO" <> + OP.value (3/5) <> + OP.help "Font width relative to font height") + +data Font = + Font { + fontName :: String, + fontHeight :: Double, + fontRelativeWidth :: Double } diff --git a/med-module.cabal b/med-module.cabal --- a/med-module.cabal +++ b/med-module.cabal @@ -1,5 +1,5 @@ Name: med-module -Version: 0.1 +Version: 0.1.1 Synopsis: Parse song module files from Amiga MED and OctaMED Description: MED (Music EDitor) and its successor OctaMED @@ -29,7 +29,7 @@ Cabal-Version: >=1.10 Source-Repository this - Tag: 0.1 + Tag: 0.1.1 Type: darcs Location: http://hub.darcs.net/thielema/med-module