module Sound.MED.Generic.Block where import qualified Sound.MED.Raw.MMD0Block as MMD0Block import qualified Sound.MED.Raw.MMD0NoteData as MMD0NoteData import qualified Sound.MED.Raw.MMD1Block as MMD1Block import qualified Sound.MED.Raw.MMD1NoteData as MMD1NoteData import qualified Sound.MED.Raw.BlockInfo as BlockInfo import qualified Sound.MED.Raw.BlockCmdPageTable as BlockCmdPageTable import qualified Sound.MED.Raw.CmdPageData as CmdPageData import Sound.MED.Basic.Human(Human(human),bold) import Sound.MED.Basic.Utility(stringFromBytes) import Text.Printf(printf) import Control.Monad(liftM2) import Data.Bits(shiftR, (.&.)) import Data.Maybe(catMaybes) type Note = Int type Inst = Int type Cmd = Int type Val = Int type Highlight = Bool type Line = ( Maybe Highlight, [ ( Note, Inst, [ ( Cmd, Val ) ] ) ]) data MEDBlock = MEDBlock { MEDBlock -> Maybe String name :: Maybe String , MEDBlock -> Int tracks :: Int , MEDBlock -> Int lines :: Int , MEDBlock -> Int pages :: Int , MEDBlock -> [Line] seqdata :: [ Line ] } medblock0 :: MMD0Block.MMD0Block -> MEDBlock medblock0 :: MMD0Block -> MEDBlock medblock0 MMD0Block b = let name' :: Maybe a name' = forall a. Maybe a Nothing tracks' :: Int tracks' = forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ MMD0Block -> UBYTE MMD0Block.numtracks MMD0Block b lines' :: Int lines' = forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ MMD0Block -> UBYTE MMD0Block.lines MMD0Block b forall a. Num a => a -> a -> a + UBYTE 1 pages' :: Int pages' = Int 1 highlights' :: [Maybe a] highlights' = forall a. a -> [a] repeat forall a. Maybe a Nothing f :: UBYTE -> Int f = forall a b. (Integral a, Num b) => a -> b fromIntegral g :: MMD0NoteData -> (Int, Int, [(Int, Int)]) g (MMD0NoteData.MMD0NoteData UBYTE n UBYTE i UBYTE c UBYTE v) = (UBYTE -> Int f UBYTE n, UBYTE -> Int f UBYTE i, [(UBYTE -> Int f UBYTE c, UBYTE -> Int f UBYTE v)]) notedata' :: [[(Int, Int, [(Int, Int)])]] notedata' = forall a b. (a -> b) -> [a] -> [b] map (forall a b. (a -> b) -> [a] -> [b] map MMD0NoteData -> (Int, Int, [(Int, Int)]) g) (MMD0Block -> [[MMD0NoteData]] MMD0Block.notedata MMD0Block b) seqdata' :: [(Maybe a, [(Int, Int, [(Int, Int)])])] seqdata' = forall a b. [a] -> [b] -> [(a, b)] zip forall {a}. [Maybe a] highlights' [[(Int, Int, [(Int, Int)])]] notedata' in Maybe String -> Int -> Int -> Int -> [Line] -> MEDBlock MEDBlock forall a. Maybe a name' Int tracks' Int lines' Int pages' forall {a}. [(Maybe a, [(Int, Int, [(Int, Int)])])] seqdata' medblock1 :: MMD1Block.MMD1Block -> MEDBlock medblock1 :: MMD1Block -> MEDBlock medblock1 MMD1Block b = let i :: Maybe BlockInfo i = MMD1Block -> Maybe BlockInfo MMD1Block.info MMD1Block b name' :: Maybe String name' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap [UBYTE] -> String stringFromBytes forall a b. (a -> b) -> a -> b $ BlockInfo -> Maybe [UBYTE] BlockInfo.blockname forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Maybe BlockInfo i tracks' :: Int tracks' = forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ MMD1Block -> UWORD MMD1Block.numtracks MMD1Block b lines' :: Int lines' = forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ MMD1Block -> UWORD MMD1Block.lines MMD1Block b forall a. Num a => a -> a -> a + UWORD 1 pages' :: Int pages' = case BlockInfo -> Maybe BlockCmdPageTable BlockInfo.pagetable forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Maybe BlockInfo i of Maybe BlockCmdPageTable Nothing -> Int 1 Just BlockCmdPageTable pt -> Int 1 forall a. Num a => a -> a -> a + (forall (t :: * -> *) a. Foldable t => t a -> Int length forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [Maybe a] -> [a] catMaybes forall a b. (a -> b) -> a -> b $ BlockCmdPageTable -> [Maybe [[CmdPageData]]] BlockCmdPageTable.pages BlockCmdPageTable pt) hlbit :: a -> Int -> Highlight hlbit a h Int bpos = ((a h forall a. Bits a => a -> Int -> a `shiftR` Int bpos) forall a. Bits a => a -> a -> a .&. a 1) forall a. Eq a => a -> a -> Highlight == a 1 hlbits :: a -> [Highlight] hlbits a h = forall a b. (a -> b) -> [a] -> [b] map (forall {a}. (Bits a, Num a) => a -> Int -> Highlight hlbit a h) [Int 0..Int 31] highlights' :: [Maybe Highlight] highlights' = case BlockInfo -> Maybe [ULONG] BlockInfo.hlmask forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Maybe BlockInfo i of Maybe [ULONG] Nothing -> forall a. a -> [a] repeat forall a. Maybe a Nothing Just [ULONG] hl -> forall a b. (a -> b) -> [a] -> [b] map forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap forall {a}. (Bits a, Num a) => a -> [Highlight] hlbits forall a b. (a -> b) -> a -> b $ [ULONG] hl fI :: UBYTE -> Int fI = forall a b. (Integral a, Num b) => a -> b fromIntegral nd :: MMD1NoteData -> (Int, Int, [(Int, Int)]) nd (MMD1NoteData.MMD1NoteData UBYTE n UBYTE j UBYTE c UBYTE v) = (UBYTE -> Int fI UBYTE n, UBYTE -> Int fI UBYTE j, [(UBYTE -> Int fI UBYTE c, UBYTE -> Int fI UBYTE v)]) notedata' :: [[(Int, Int, [(Int, Int)])]] notedata' = forall a b. (a -> b) -> [a] -> [b] map (forall a b. (a -> b) -> [a] -> [b] map MMD1NoteData -> (Int, Int, [(Int, Int)]) nd) (MMD1Block -> [[MMD1NoteData]] MMD1Block.notedata MMD1Block b) cv :: CmdPageData -> (Int, Int) cv (CmdPageData.CmdPageData UBYTE c UBYTE v) = (UBYTE -> Int fI UBYTE c, UBYTE -> Int fI UBYTE v) cmddata' :: [[[(Int, Int)]]] cmddata' = case BlockInfo -> Maybe BlockCmdPageTable BlockInfo.pagetable forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Maybe BlockInfo i of Maybe BlockCmdPageTable Nothing -> [] Just BlockCmdPageTable pt -> forall a b. (a -> b) -> [a] -> [b] map (forall a b. (a -> b) -> [a] -> [b] map (forall a b. (a -> b) -> [a] -> [b] map CmdPageData -> (Int, Int) cv)) (forall a. [Maybe a] -> [a] catMaybes (BlockCmdPageTable -> [Maybe [[CmdPageData]]] BlockCmdPageTable.pages BlockCmdPageTable pt)) p :: (a, b) -> (a, b, [(a, b)]) -> (a, b, [(a, b)]) p (a c,b v) (a n,b j,[(a, b)] cvs) = (a n, b j, [(a, b)] cvs forall a. [a] -> [a] -> [a] ++ [(a c,b v)]) ncdata' :: [[(Int, Int, [(Int, Int)])]] ncdata' = forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith forall {a} {b} {a} {b}. (a, b) -> (a, b, [(a, b)]) -> (a, b, [(a, b)]) p)) [[(Int, Int, [(Int, Int)])]] notedata' [[[(Int, Int)]]] cmddata' seqdata' :: [Line] seqdata' = forall a b. [a] -> [b] -> [(a, b)] zip [Maybe Highlight] highlights' [[(Int, Int, [(Int, Int)])]] ncdata' in Maybe String -> Int -> Int -> Int -> [Line] -> MEDBlock MEDBlock Maybe String name' Int tracks' Int lines' Int pages' [Line] seqdata' instance Human MEDBlock where human :: MEDBlock -> String human MEDBlock b = let name' :: String name' = forall b a. b -> (a -> b) -> Maybe a -> b maybe String "" (Char ' 'forall a. a -> [a] -> [a] :) forall a b. (a -> b) -> a -> b $ MEDBlock -> Maybe String name MEDBlock b blocklines :: MEDBlock -> Int blocklines = MEDBlock -> Int Sound.MED.Generic.Block.lines dim' :: String dim' = forall r. PrintfType r => String -> r printf String "%d*%d*%d" (MEDBlock -> Int blocklines MEDBlock b) (MEDBlock -> Int tracks MEDBlock b) (MEDBlock -> Int pages MEDBlock b) seq' :: String seq' = [String] -> String unlines (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith Int -> Line -> String highlightLine [Int 0..] (MEDBlock -> [Line] seqdata MEDBlock b)) in String dim' forall a. [a] -> [a] -> [a] ++ String name' forall a. [a] -> [a] -> [a] ++ String "\n" forall a. [a] -> [a] -> [a] ++ String seq' highlightLine :: Int -> Line -> String highlightLine :: Int -> Line -> String highlightLine Int i (Maybe Highlight highlight, [(Int, Int, [(Int, Int)])] ds) = let bLine :: String bLine = Int -> [(Int, Int, [(Int, Int)])] -> String humanLine Int i [(Int, Int, [(Int, Int)])] ds in if Maybe Highlight highlight forall a. Eq a => a -> a -> Highlight == forall a. a -> Maybe a Just Highlight True then String -> String bold String bLine else String bLine humanLine :: Int -> [ ( Note, Inst, [ ( Cmd, Val ) ] ) ] -> String humanLine :: Int -> [(Int, Int, [(Int, Int)])] -> String humanLine Int i [(Int, Int, [(Int, Int)])] ds = let mapWords :: (a -> String) -> [a] -> String mapWords a -> String fmt = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap (Char ' 'forall a. a -> [a] -> [a] :) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map a -> String fmt hCV :: (t, t) -> t hCV (t c, t v) = forall r. PrintfType r => String -> r printf String "%02X%02X" t c t v hTrack :: (Int, t, [(t, t)]) -> t hTrack (Int n, t j, [(t, t)] cvs) = forall r. PrintfType r => String -> r printf String "%s %02X%s" ([String] notesforall a. [a] -> Int -> a !!Int n) t j (forall {a}. (a -> String) -> [a] -> String mapWords forall {t} {t} {t}. (PrintfArg t, PrintfArg t, PrintfType t) => (t, t) -> t hCV [(t, t)] cvs) in forall r. PrintfType r => String -> r printf String "%04X:%s" Int i (forall {a}. (a -> String) -> [a] -> String mapWords forall {t} {t} {t} {t}. (PrintfType t, PrintfArg t, PrintfArg t, PrintfArg t) => (Int, t, [(t, t)]) -> t hTrack [(Int, Int, [(Int, Int)])] ds) notes :: [String] notes :: [String] notes = String "---" forall a. a -> [a] -> [a] : forall (m :: * -> *) a1 a2 r. Monad m => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r liftM2 (forall a b c. (a -> b -> c) -> b -> a -> c flip (forall r. PrintfType r => String -> r printf String "%s%1X")) [(Int 1::Int) ..] [String "C-",String "C#",String "D-",String "D#",String "E-",String "F-",String "F#",String "G-",String "G#",String "A-",String "A#",String "B-"]