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' = Maybe a forall a. Maybe a Nothing tracks' :: Int tracks' = UBYTE -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (UBYTE -> Int) -> UBYTE -> Int forall a b. (a -> b) -> a -> b $ MMD0Block -> UBYTE MMD0Block.numtracks MMD0Block b lines' :: Int lines' = UBYTE -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (UBYTE -> Int) -> UBYTE -> Int forall a b. (a -> b) -> a -> b $ MMD0Block -> UBYTE MMD0Block.lines MMD0Block b UBYTE -> UBYTE -> UBYTE forall a. Num a => a -> a -> a + UBYTE 1 pages' :: Int pages' = Int 1 highlights' :: [Maybe a] highlights' = Maybe a -> [Maybe a] forall a. a -> [a] repeat Maybe a forall a. Maybe a Nothing f :: UBYTE -> Int f = UBYTE -> Int 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' = ([MMD0NoteData] -> [(Int, Int, [(Int, Int)])]) -> [[MMD0NoteData]] -> [[(Int, Int, [(Int, Int)])]] forall a b. (a -> b) -> [a] -> [b] map ((MMD0NoteData -> (Int, Int, [(Int, Int)])) -> [MMD0NoteData] -> [(Int, Int, [(Int, Int)])] 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' = [Maybe a] -> [[(Int, Int, [(Int, Int)])]] -> [(Maybe a, [(Int, Int, [(Int, Int)])])] forall a b. [a] -> [b] -> [(a, b)] zip [Maybe a] forall a. [Maybe a] highlights' [[(Int, Int, [(Int, Int)])]] notedata' in Maybe String -> Int -> Int -> Int -> [Line] -> MEDBlock MEDBlock Maybe String forall a. Maybe a name' Int tracks' Int lines' Int pages' [Line] 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' = ([UBYTE] -> String) -> Maybe [UBYTE] -> Maybe String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap [UBYTE] -> String stringFromBytes (Maybe [UBYTE] -> Maybe String) -> Maybe [UBYTE] -> Maybe String forall a b. (a -> b) -> a -> b $ BlockInfo -> Maybe [UBYTE] BlockInfo.blockname (BlockInfo -> Maybe [UBYTE]) -> Maybe BlockInfo -> Maybe [UBYTE] forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Maybe BlockInfo i tracks' :: Int tracks' = UWORD -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (UWORD -> Int) -> UWORD -> Int forall a b. (a -> b) -> a -> b $ MMD1Block -> UWORD MMD1Block.numtracks MMD1Block b lines' :: Int lines' = UWORD -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (UWORD -> Int) -> UWORD -> Int forall a b. (a -> b) -> a -> b $ MMD1Block -> UWORD MMD1Block.lines MMD1Block b UWORD -> UWORD -> UWORD forall a. Num a => a -> a -> a + UWORD 1 pages' :: Int pages' = case BlockInfo -> Maybe BlockCmdPageTable BlockInfo.pagetable (BlockInfo -> Maybe BlockCmdPageTable) -> Maybe BlockInfo -> Maybe BlockCmdPageTable 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 Int -> Int -> Int forall a. Num a => a -> a -> a + ([[[CmdPageData]]] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int length ([[[CmdPageData]]] -> Int) -> ([Maybe [[CmdPageData]]] -> [[[CmdPageData]]]) -> [Maybe [[CmdPageData]]] -> Int forall b c a. (b -> c) -> (a -> b) -> a -> c . [Maybe [[CmdPageData]]] -> [[[CmdPageData]]] forall a. [Maybe a] -> [a] catMaybes ([Maybe [[CmdPageData]]] -> Int) -> [Maybe [[CmdPageData]]] -> Int forall a b. (a -> b) -> a -> b $ BlockCmdPageTable -> [Maybe [[CmdPageData]]] BlockCmdPageTable.pages BlockCmdPageTable pt) hlbit :: a -> Int -> Bool hlbit a h Int bpos = ((a h a -> Int -> a forall a. Bits a => a -> Int -> a `shiftR` Int bpos) a -> a -> a forall a. Bits a => a -> a -> a .&. a 1) a -> a -> Bool forall a. Eq a => a -> a -> Bool == a 1 hlbits :: a -> [Bool] hlbits a h = (Int -> Bool) -> [Int] -> [Bool] forall a b. (a -> b) -> [a] -> [b] map (a -> Int -> Bool forall a. (Bits a, Num a) => a -> Int -> Bool hlbit a h) [Int 0..Int 31] highlights' :: [Maybe Bool] highlights' = case BlockInfo -> Maybe [ULONG] BlockInfo.hlmask (BlockInfo -> Maybe [ULONG]) -> Maybe BlockInfo -> Maybe [ULONG] forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Maybe BlockInfo i of Maybe [ULONG] Nothing -> Maybe Bool -> [Maybe Bool] forall a. a -> [a] repeat Maybe Bool forall a. Maybe a Nothing Just [ULONG] hl -> (Bool -> Maybe Bool) -> [Bool] -> [Maybe Bool] forall a b. (a -> b) -> [a] -> [b] map Bool -> Maybe Bool forall a. a -> Maybe a Just ([Bool] -> [Maybe Bool]) -> [Bool] -> [Maybe Bool] forall a b. (a -> b) -> a -> b $ (ULONG -> [Bool]) -> [ULONG] -> [Bool] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap ULONG -> [Bool] forall a. (Bits a, Num a) => a -> [Bool] hlbits ([ULONG] -> [Bool]) -> [ULONG] -> [Bool] forall a b. (a -> b) -> a -> b $ [ULONG] hl fI :: UBYTE -> Int fI = UBYTE -> Int 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' = ([MMD1NoteData] -> [(Int, Int, [(Int, Int)])]) -> [[MMD1NoteData]] -> [[(Int, Int, [(Int, Int)])]] forall a b. (a -> b) -> [a] -> [b] map ((MMD1NoteData -> (Int, Int, [(Int, Int)])) -> [MMD1NoteData] -> [(Int, Int, [(Int, Int)])] 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 (BlockInfo -> Maybe BlockCmdPageTable) -> Maybe BlockInfo -> Maybe BlockCmdPageTable forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Maybe BlockInfo i of Maybe BlockCmdPageTable Nothing -> [] Just BlockCmdPageTable pt -> ([[CmdPageData]] -> [[(Int, Int)]]) -> [[[CmdPageData]]] -> [[[(Int, Int)]]] forall a b. (a -> b) -> [a] -> [b] map (([CmdPageData] -> [(Int, Int)]) -> [[CmdPageData]] -> [[(Int, Int)]] forall a b. (a -> b) -> [a] -> [b] map ((CmdPageData -> (Int, Int)) -> [CmdPageData] -> [(Int, Int)] forall a b. (a -> b) -> [a] -> [b] map CmdPageData -> (Int, Int) cv)) ([Maybe [[CmdPageData]]] -> [[[CmdPageData]]] 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 [(a, b)] -> [(a, b)] -> [(a, b)] forall a. [a] -> [a] -> [a] ++ [(a c,b v)]) ncdata' :: [[(Int, Int, [(Int, Int)])]] ncdata' = ([[(Int, Int)]] -> [[(Int, Int, [(Int, Int)])]] -> [[(Int, Int, [(Int, Int)])]]) -> [[(Int, Int, [(Int, Int)])]] -> [[[(Int, Int)]]] -> [[(Int, Int, [(Int, Int)])]] forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (([(Int, Int)] -> [(Int, Int, [(Int, Int)])] -> [(Int, Int, [(Int, Int)])]) -> [[(Int, Int)]] -> [[(Int, Int, [(Int, Int)])]] -> [[(Int, Int, [(Int, Int)])]] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (((Int, Int) -> (Int, Int, [(Int, Int)]) -> (Int, Int, [(Int, Int)])) -> [(Int, Int)] -> [(Int, Int, [(Int, Int)])] -> [(Int, Int, [(Int, Int)])] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (Int, Int) -> (Int, Int, [(Int, Int)]) -> (Int, Int, [(Int, Int)]) 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' = [Maybe Bool] -> [[(Int, Int, [(Int, Int)])]] -> [Line] forall a b. [a] -> [b] -> [(a, b)] zip [Maybe Bool] 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' = String -> (String -> String) -> Maybe String -> String forall b a. b -> (a -> b) -> Maybe a -> b maybe String "" (Char ' 'Char -> String -> String forall a. a -> [a] -> [a] :) (Maybe String -> String) -> Maybe String -> String 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' = String -> Int -> Int -> Int -> String 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 ((Int -> Line -> String) -> [Int] -> [Line] -> [String] 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' String -> String -> String forall a. [a] -> [a] -> [a] ++ String name' String -> String -> String forall a. [a] -> [a] -> [a] ++ String "\n" String -> String -> String forall a. [a] -> [a] -> [a] ++ String seq' highlightLine :: Int -> Line -> String highlightLine :: Int -> Line -> String highlightLine Int i (Maybe Bool 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 Bool highlight Maybe Bool -> Maybe Bool -> Bool forall a. Eq a => a -> a -> Bool == Bool -> Maybe Bool forall a. a -> Maybe a Just Bool 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 = (String -> String) -> [String] -> String forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap (Char ' 'Char -> String -> String forall a. a -> [a] -> [a] :) ([String] -> String) -> ([a] -> [String]) -> [a] -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . (a -> String) -> [a] -> [String] forall a b. (a -> b) -> [a] -> [b] map a -> String fmt hCV :: (t, t) -> t hCV (t c, t v) = String -> t -> t -> t 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) = String -> String -> t -> String -> t forall r. PrintfType r => String -> r printf String "%s %02X%s" ([String] notes[String] -> Int -> String forall a. [a] -> Int -> a !!Int n) t j (((t, t) -> String) -> [(t, t)] -> String forall a. (a -> String) -> [a] -> String mapWords (t, t) -> String forall t t t. (PrintfArg t, PrintfArg t, PrintfType t) => (t, t) -> t hCV [(t, t)] cvs) in String -> Int -> String -> String forall r. PrintfType r => String -> r printf String "%04X:%s" Int i (((Int, Int, [(Int, Int)]) -> String) -> [(Int, Int, [(Int, Int)])] -> String forall a. (a -> String) -> [a] -> String mapWords (Int, Int, [(Int, Int)]) -> String 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 "---" String -> [String] -> [String] forall a. a -> [a] -> [a] : (Int -> String -> String) -> [Int] -> [String] -> [String] forall (m :: * -> *) a1 a2 r. Monad m => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r liftM2 ((String -> Int -> String) -> Int -> String -> String forall a b c. (a -> b -> c) -> b -> a -> c flip (String -> String -> Int -> String 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-"]