Block.hs

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.Amiga(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
  { name    :: Maybe String
  , tracks  :: Int
  , lines   :: Int
  , pages   :: Int
  , seqdata :: [ Line ]
  }

medblock0 :: MMD0Block.MMD0Block -> MEDBlock
medblock0 b =
  let name'       = Nothing
      tracks'     = fromIntegral $ MMD0Block.numtracks b
      lines'      = fromIntegral $ MMD0Block.lines     b + 1
      pages'      = 1
      highlights' = repeat Nothing
      f           = fromIntegral
      g (MMD0NoteData.MMD0NoteData n i c v) = (f n, f i, [(f c, f v)])
      notedata'   = map (map g) (MMD0Block.notedata b)
      seqdata'    = zip highlights' notedata'
  in MEDBlock name' tracks' lines' pages' seqdata'


medblock1 :: MMD1Block.MMD1Block -> MEDBlock
medblock1 b =
  let i           = MMD1Block.info b
      name'       = fmap stringFromBytes $ BlockInfo.blockname =<< i
      tracks'     = fromIntegral $ MMD1Block.numtracks b
      lines'      = fromIntegral $ MMD1Block.lines     b + 1
      pages'      = case BlockInfo.pagetable =<< i of
        Nothing -> 1
        Just pt -> 1 + (length . catMaybes $ BlockCmdPageTable.pages pt)
      hlbit h bpos = ((h `shiftR` bpos) .&. 1) == 1
      hlbits h    = map (hlbit h) [0..31]
      highlights' = case BlockInfo.hlmask =<< i of
        Nothing -> repeat Nothing
        Just hl -> map Just $ concatMap hlbits $ hl
      fI          = fromIntegral
      nd (MMD1NoteData.MMD1NoteData n j c v) = (fI n, fI j, [(fI c, fI v)])
      notedata'   = map (map nd) (MMD1Block.notedata b)
      cv (CmdPageData.CmdPageData c v) = (fI c, fI v)
      cmddata'    = case BlockInfo.pagetable =<< i of
        Nothing -> []
        Just pt -> map (map (map cv)) (catMaybes (BlockCmdPageTable.pages pt))
      p (c,v) (n,j,cvs) = (n, j, cvs ++ [(c,v)])
      ncdata'     = foldr (zipWith (zipWith p)) notedata' cmddata'
      seqdata'    = zip highlights' ncdata'
  in MEDBlock name' tracks' lines' pages' seqdata'


instance Human MEDBlock where
  human b =
    let name' = maybe "" (' ':) $ name b
        blocklines = Sound.MED.Generic.Block.lines
        dim'  = printf "%d*%d*%d" (blocklines b) (tracks b) (pages b)
        seq'  = unlines (zipWith highlightLine [0..] (seqdata b))
    in dim' ++ name' ++ "\n" ++ seq'

highlightLine :: Int -> Line -> String
highlightLine i (highlight, ds) =
  let bLine = humanLine i ds
  in if highlight == Just True then bold bLine else bLine

humanLine :: Int -> [ ( Note, Inst, [ ( Cmd, Val ) ] ) ] -> String
humanLine i ds =
  let mapWords fmt = concatMap (' ':) . map fmt
      hCV (c, v) = printf "%02X%02X" c v
      hTrack (n, j, cvs) = printf "%s %02X%s" (notes!!n) j (mapWords hCV cvs)
  in  printf "%04X:%s" i (mapWords hTrack ds)

notes :: [String]
notes =
  "---" :
  liftM2 (flip (printf "%s%1X"))
    [(1::Int) ..]
    ["C-","C#","D-","D#","E-","F-","F#","G-","G#","A-","A#","B-"]