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