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-"]