med-module 0.1 → 0.1.1
raw patch · 4 files changed
+105/−22 lines, 4 filesdep ~optparse-applicative
Dependency ranges changed: optparse-applicative
Files
- README.md +0/−3
- example/Animate.hs +66/−16
- example/Animate/Option.hs +37/−1
- med-module.cabal +2/−2
README.md view
@@ -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.
example/Animate.hs view
@@ -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
example/Animate/Option.hs view
@@ -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 }
med-module.cabal view
@@ -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