{-# LANGUAGE
     NoMonomorphismRestriction
    ,DoRec
    ,ExtendedDefaultRules
    ,TypeFamilies
    ,TypeOperators
    ,DeriveDataTypeable
    ,DeriveFunctor
    ,GeneralizedNewtypeDeriving
    ,ScopedTypeVariables
    ,MultiParamTypeClasses
    ,FlexibleInstances
    ,TupleSections
    ,OverlappingInstances
    ,UndecidableInstances
    ,TypeSynonymInstances #-}

module Language.XDsp.Implementations.Csound (
  S (..)
 ,BusType (..)
 ,HostOut (..)
 ,RType
 ,defaultRType
 ,unifyCsd
 ,writeHeader
 ,makeInstrument
 ,TList
 ,unTList'
 ,mkTbl
 ,writeCard
 ,module Language.XDsp.Semantics.CsoundExt
)

where

import           Language.XDsp.Semantics
import           Language.XDsp.Semantics.CsoundExt hiding (CsOscil (..), CsOscili (..), CsSum (..))
import qualified Language.XDsp.Semantics.CsoundExt as CSE

import           Data.Char
import           Data.Data
import           Data.List (intersperse, intercalate)
import qualified Data.Map as M
import           Data.Maybe (fromMaybe, catMaybes)
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import           Data.TypeLevel.Num ((:>=:), Nat, toInt)
import           Control.Monad.RWS
import           Control.Applicative
import           Control.Arrow

import           Text.Printf

-- ---------------------------------
-- ---------------------------------

-- |Initial csound pretty-printer

data CVar =
    Cnst Double
  | CStr String
  | CVar String
  deriving (Eq, Ord, Show, Read)

data VarType =
    A                  -- A-rate signal
  | K                  -- K-rate signal
  | I                  -- i-time value
  | F                  -- fsig
  | T                  -- function table
  | IC                 -- score i-statement
  | St                 -- String
  | U                  -- Unit
  | Tp VarType VarType -- tuple
  | T3 VarType VarType VarType         -- 3-tuple
  | T4 VarType VarType VarType VarType -- 4-element tuple
  | CList VarType      -- list
  deriving (Eq, Ord, Read, Show)

-- | get the initial character of a csound var from a VarType
mkChr :: VarType -> Char
mkChr T  = 'f'
mkChr IC = 'i'
mkChr St = 'i'  -- string type stored in ivals
mkChr x = toLower . head . show $ x

getLbl :: CVar -> String
getLbl (Cnst x)   = show x
getLbl (CStr s)   = show s
getLbl (CVar s)   = s

-- |Polyvariadic support for building argument lists
class ArgListBuilder r where
  appendToList :: [String] -> r

instance ArgListBuilder [String] where
  appendToList = reverse

instance (Varable a, ArgListBuilder r) => ArgListBuilder (a -> r) where
  appendToList arg = appendToList . (\acc a -> getVarLbl a : acc) arg

mkOp0 :: Varable out => String -> S n out
mkOp0 opname = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s\n" outName opname
  return out

-- |helper function to create a 1-argument opcode instance.
-- I should make these with TH, but that would require having "genName" in scope
-- which means S would need to be in scope, but then all the S instances
-- would be orphans, which I don't want either...
mkOp1 :: (Varable a, Varable out) => String -> a -> S n out
mkOp1 opname a1 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname (getVarLbl a1)
  return out

mkOp2 opname a1 a2 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2)
  return out

mkOp3 opname a1 a2 a3 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2 a3)
  return out

mkOp4 opname a1 a2 a3 a4 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2 a3 a4)
  return out

mkOp5 opname a1 a2 a3 a4 a5 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2 a3 a4 a5)
  return out

mkOp6 opname a1 a2 a3 a4 a5 a6 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2 a3 a4 a5 a6)
  return out

mkOp7 opname a1 a2 a3 a4 a5 a6 a7 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2 a3 a4 a5 a6 a7)
  return out

mkOp8 opname a1 a2 a3 a4 a5 a6 a7 a8 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2 a3 a4 a5 a6 a7 a8)
  return out

mkOp9 opname a1 a2 a3 a4 a5 a6 a7 a8 a9 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2 a3 a4 a5 a6 a7 a8 a9)
  return out

mkOp10 opname a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
  return out

mkOp11 opname a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
  return out

mkOp12 opname a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  return out

mkOp13 opname a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13)
  return out

mkOp17 opname a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 = do
  (out, outName) <- genName
  tellOrc $ printf "%s %s %s\n" outName opname
    (argCleaner $ appendToList [] a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17)
  return out

-- | remove null arguments; these appear when a list of arguments is empty.
argCleaner :: [String] -> String
argCleaner = intercalate ", " . filter (Prelude.not . null)

mkOp14 = error "mkOp14"
mkOp15 = error "mkOp15"
mkOp16 = error "mkOp16"
mkOp18 = error "mkOp18"
mkOp19 = error "mkOp19"
mkOp22 = error "mkOp22"
mkOp26 = error "mkOp26"
mkOp32 = error "mkOp32"
mkOp83 = error "mkOp83"
mkOp99 = error "mkOp99"
mkOp51 = error "mkOp51"
mkOp34 = error "mkOp34"
mkOp43 = error "mkOp43"

-- ------------------------------------------
-- ------------------------------------------
-- sco helpers

-- | A score item.  The "Card" name is old-school
data Card = Card VarType [String] deriving (Eq, Read, Show)

card2str :: Card -> String
card2str (Card typ args) = mkChr typ : unwords args ++ "\n"

writeCard :: Card -> S n ()
writeCard = tellSco . card2str

mkTbl :: Int -> Double -> Int -> Int -> [Double] -> Card
mkTbl nm time sz gen args = Card T $
  show nm:show time:show sz:show gen:map show args

-- |Create a 0-filled f-statement in the score section.
mkScoreBuf :: Int -> Int -> S n ()
mkScoreBuf nm sz = writeCard $ mkTbl nm 0 sz 17 [0,0]

-- | Holds data on a score item for memoization purposes.
data CardM = CardM VarType String String deriving (Eq, Ord, Show)

cacheBuf :: String -> Int -> CardM
cacheBuf lbl = CardM T lbl . show

-- ------------------------------------------
-- ------------------------------------------
-- external interface helpers

data BusType = KBus | TblBus Int deriving (Eq, Read, Show)

-- |Specifies details for a Host output described within the language.
-- First string is a host-specified label.  Second is an auto-generated
-- name (e.g. tablenum)
data HostOut = HostOut {
  busType :: BusType,
  busLbl  :: String,
  busName :: String } deriving (Eq, Read, Show)

-- ------------------------------------------
-- ------------------------------------------

data CacheKey =
 CKC CardM    -- score cache
 deriving (Eq, Ord, Show)

type WCache  = M.Map CacheKey CVar
type GenMap  = M.Map VarType Int
type ICache = S.Set Int
data SState  = SState {
  wcache :: WCache
 ,genMap :: GenMap
 ,iCache :: ICache}

type ScoType = TL.Text
type OrcType = TL.Text
type HostType = [HostOut]

type WType = (ScoType, OrcType, HostType)
type RType = (Integer, Integer) -- SR and ksmps

defaultRType = (44100,16)

newtype S n a = S { unS :: RWS RType WType SState a }
  deriving (Functor, Applicative, Monad, Typeable)

instance MonadFix (S n) where
  mfix f = S $ mfix (unS . f)

instance MonadState (S n) where
  type StateType (S n) = SState
  get = S get
  put = S . put

instance MonadWriter (S n) where
  type WriterType (S n) = WType
  tell   = S . tell
  listen = S . listen . unS
  pass   = S . pass . unS

instance MonadReader (S n) where
  type EnvType (S n) = RType
  ask   = S ask
  local f = S . local f . unS

csdHeader =
  "<CsoundSynthesizer>\n\
  \<CsOptions>\n\
  \%s\n\
  \</CsOptions>\n"

-- -------------------------
-- helpers for working with states

getGen :: S n GenMap
getGen = fmap genMap get

putGen :: GenMap -> S n ()
putGen newstate = modify (\ss -> ss {genMap = newstate})

cache  :: CacheKey -> CVar -> S n ()
cache key val = do
  SState cmap gen imap <- get
  put $ SState (M.insert key val cmap) gen imap

cacheInstr :: Int -> S n ()
cacheInstr n = modify (\ss -> let ic' = S.insert n (iCache ss) in ss { iCache = ic' })

instrInCache :: Int -> S n Bool
instrInCache n = do
  (SState _ _ imap) <- get
  return $ S.member n imap

tellOrc :: String -> S n ()
tellOrc s = tell (TL.pack s,mempty, mempty)

tellSco :: String -> S n ()
tellSco s = tell (mempty,TL.pack s,mempty)

tellHost :: HostOut -> S n ()
tellHost s = tell (mempty,mempty, [s])

runS :: S n a -> RType -> (a, SState, WType)
runS e rt = runRWS (unS e) rt (SState M.empty M.empty S.empty)

evalS :: S n a -> RType -> a
evalS e rt = let (a,_,_) = runS e rt in a

getWritten :: RType -> S n x -> WType
getWritten rt e = let (_,_,w) = runS e rt in w

-- |Creates a CSD formatted String from args and an x-dsp expression.
unifyCsd :: [String] -> RType -> S n x -> (TL.Text, [HostOut])
unifyCsd args r = unifyCsd' args . getWritten r

-- |Creates a CSD file from an argument list and Writer output
unifyCsd' :: [String] -> WType -> (TL.Text, [HostOut])
unifyCsd' args (orc, sco, host) = (csd, host)
 where
  oH = TL.pack "<CsInstruments>\n"
  oF = TL.pack "\n</CsInstruments>\n"
  sH = TL.pack "<CsScore>\n"
  sF = TL.pack "\ne\n</CsScore>\n</CsoundSynthesizer>\n"

  csd = TL.concat [TL.pack (printf csdHeader (unwords args))
                  ,oH ,orc ,oF ,sH ,sco ,sF]

class Varable s where
  genName   :: S n (s, String)
  getVarLbl :: s -> String

instance Varable s => Var s where
  type VarRep s = String
  getVarRep s = getVarLbl s

class Varable s => PVar s where

class Varable s => KVar s where

-- |Create a new number of the appropriate type.
-- This can be made into a name by prepending the type character.
mkName :: VarType -> S n Int
mkName typ = do
  gen <- getGen
  let num = fromMaybe 1 $ M.lookup typ gen
  putGen $ M.alter (const $ Just (succ num)) typ gen
  return num


-- ---------------------------------
-- ---------------------------------
-- Instances

instance Dsp (S n) where
  data (ASig (S n)) = S_A CVar
  data (KSig (S n)) = S_K CVar
  data (INum (S n)) = S_I CVar
  getSr    = fst <$> ask
  getKsmps = snd <$> ask

instance Constants (S n) where
  cnst = return . S_I . Cnst
  ckig = return . S_K . Cnst
  csig = return . S_A . Cnst

instance Cast (S n) where
  ik ivar = mkOp1 "=" ivar
  ia ivar = mkOp1 "=" ivar
  ki kvar = do
    (out, outname) <- genName
    tellOrc $ printf "%s = i(%s)\n" outname (getVarLbl kvar)
    return out

instance Varable (ASig (S n)) where
  genName = do
    SState omap gen imap <- get
    let num = fromMaybe 1 $ M.lookup A gen
        nm  = 'a' : show num
    put $ SState omap (M.alter (const $ Just (succ num)) A gen) imap
    return (S_A $ CVar nm, nm)
  getVarLbl (S_A c) = getLbl c

instance PVar (ASig (S n)) where

instance Varable (KSig (S n)) where
  genName = do
    SState omap gen imap <- get
    let num = fromMaybe 1 $ M.lookup K gen
        nm  = 'k' : show num
    put $ SState omap (M.alter (const $ Just (succ num)) K gen) imap
    return (S_K $ CVar nm, nm)
  getVarLbl (S_K c) = getLbl c

instance PVar (KSig (S n)) where
instance KVar (KSig (S n)) where

instance Varable (INum (S n)) where
  genName = do
    SState omap gen imap <- get
    let num = fromMaybe 1 $ M.lookup I gen
        nm  = 'i' : show num
    put $ SState omap (M.alter (const $ Just (succ num)) I gen) imap
    return (S_I $ CVar nm, nm)
  getVarLbl (S_I c) = getLbl c

instance Varable () where
  genName            = return ((), "")
  getVarLbl _        = "()"

instance Varable String where
  genName = error "Can't call 'genName' on String directly"
  getVarLbl s = '"' : s ++ "\""

instance Varable (VString (S n)) where
  genName = do
    SState omap gen imap <- get
    let num = fromMaybe 1 $ M.lookup St gen
        nm  = 'S' : show num
    put $ SState omap (M.alter (const $ Just (succ num)) St gen) imap
    return (S_VS $ CVar nm, nm)
  getVarLbl (S_VS c) = getLbl c

instance KVar (VString (S n)) where

instance (Varable a, Varable b) => Varable (a,b) where
  genName = do
    (o1,nm1) <- genName
    (o2,nm2) <- genName
    return ((o1,o2), nm1 ++ ", " ++ nm2)
  getVarLbl (a,b)      = getVarLbl a ++ ", " ++ getVarLbl b

instance (Varable a, Varable b, Varable c) =>
 Varable (a,b,c) where
  genName = do
    (o1,nm1) <- genName
    (o2,nm2) <- genName
    (o3,nm3) <- genName
    return ((o1,o2,o3), intercalate ", " [nm1, nm2, nm3])
  getVarLbl (a,b,c) =
    intercalate ", " [getVarLbl a, getVarLbl b,getVarLbl c]

instance (Varable a, Varable b, Varable c, Varable d) => Varable (a,b,c,d) where
  genName = do
    (o1,nm1) <- genName
    (o2,nm2) <- genName
    (o3,nm3) <- genName
    (o4,nm4) <- genName
    return ((o1,o2,o3,o4), intercalate ", " [nm1, nm2, nm3, nm4])
  getVarLbl (a,b,c,d) =
    intercalate ", " [getVarLbl a, getVarLbl b,getVarLbl c, getVarLbl d]

instance Varable a => Varable [a] where
  genName             = error "Can't generate names for arbitrary lists"
  getVarLbl           = intercalate ", " . map getVarLbl

instance forall d a. (Varable a, Nat d) => Varable (TList d a) where
  genName = do
    outss <- replicateM (toInt (undefined :: d)) genName
    return (TList $ map fst outss, intercalate ", " $ map snd outss)
  getVarLbl           = intercalate ", " . map getVarLbl . unTList

instance KVar (INum (S n)) where

instance PVS (S n) where
  data FSig (S n) = S_FSig CVar

instance Varable (FSig (S n)) where
  genName = do
    SState omap gen imap <- get
    let num = fromMaybe 1 $ M.lookup F gen
        nm  = 'f' : show num
    put $ SState omap (M.alter (const $ Just (succ num)) F gen) imap
    return (S_FSig $ CVar nm, nm)
  getVarLbl (S_FSig c) = getLbl c

-- | need this to directly use numeric literals as arguments.
instance Varable Double where
  genName   = error "genName shouldn't be called with Doubles"
  getVarLbl = show

instance StringVar (S n) where
  data VString (S n) = S_VS CVar
  fromStr = S_VS . CStr

-- ---------------------------------
-- ---------------------------------
-- The csound class
instance CsoundClass (S n) where
  nchnls n   = tellOrc (printf "nchnls = %i\n" n) >> return n
  set0dbfs n = tellOrc (printf "0dbfs = %f\n" n) >> return n

instance CsFunctions (ASig (S n)) where
  octcps (S_A a) = S_A . CVar $ printf "(octcps(%s))" (getLbl a)
  octpch (S_A a) = S_A . CVar $ printf "(octpch(%s))" (getLbl a)
  cpspch (S_A a) = S_A . CVar $ printf "(cpspch(%s))" (getLbl a)
  cpsoct (S_A a) = S_A . CVar $ printf "(cpsoct(%s))" (getLbl a)
  pchoct (S_A a) = S_A . CVar $ printf "(pchoct(%s))" (getLbl a)
  pchcps (S_A a) = S_A . CVar $ printf "(pchcps(%s))" (getLbl a)

instance CsFunctions (KSig (S n)) where
  octcps (S_K a) = S_K . CVar $ printf "(octcps(%s))" (getLbl a)
  octpch (S_K a) = S_K . CVar $ printf "(octpch(%s))" (getLbl a)
  cpspch (S_K a) = S_K . CVar $ printf "(cpspch(%s))" (getLbl a)
  cpsoct (S_K a) = S_K . CVar $ printf "(cpsoct(%s))" (getLbl a)
  pchoct (S_K a) = S_K . CVar $ printf "(pchoct(%s))" (getLbl a)
  pchcps (S_K a) = S_K . CVar $ printf "(pchcps(%s))" (getLbl a)

instance CsFunctions (INum (S n)) where
  octcps (S_I a) = S_I . CVar $ printf "(octcps(%s))" (getLbl a)
  octpch (S_I a) = S_I . CVar $ printf "(octpch(%s))" (getLbl a)
  cpspch (S_I a) = S_I . CVar $ printf "(cpspch(%s))" (getLbl a)
  cpsoct (S_I a) = S_I . CVar $ printf "(cpsoct(%s))" (getLbl a)
  pchoct (S_I a) = S_I . CVar $ printf "(pchoct(%s))" (getLbl a)
  pchcps (S_I a) = S_I . CVar $ printf "(pchcps(%s))" (getLbl a)

-- ---------------------------------
-- ---------------------------------
-- Numeric support for signals
instance Show (ASig (S n)) where
  show (S_A s) = show s

instance Eq (ASig (S n)) where
  (S_A a) == (S_A b) = a == b

instance Num (ASig (S n)) where
  (S_A a) + (S_A b) = S_A . CVar $ printf "(%s + %s)" (getLbl a) (getLbl b)
  (S_A a) - (S_A b) = S_A . CVar $ printf "(%s - %s)" (getLbl a) (getLbl b)
  (S_A a) * (S_A b) = S_A . CVar $ printf "(%s * %s)" (getLbl a) (getLbl b)
  abs (S_A a)       = S_A . CVar $ printf "(abs %s)" (getLbl a)
  signum      = error "signum called on (ASig (S n))"
  fromInteger = S_A . Cnst . fromInteger

instance Fractional (ASig (S n)) where
  (S_A a) / (S_A b) = S_A . CVar $ printf "(%s / %s)" (getLbl a) (getLbl b)
  fromRational = S_A . Cnst . fromRational

instance Show (KSig (S n)) where
  show (S_K s) = show s

instance Eq (KSig (S n)) where
  (S_K a) == (S_K b) = a == b

instance Num (KSig (S n)) where
  (S_K a) + (S_K b) = S_K . CVar $ printf "(%s + %s)" (getLbl a) (getLbl b)
  (S_K a) - (S_K b) = S_K . CVar $ printf "(%s - %s)" (getLbl a) (getLbl b)
  (S_K a) * (S_K b) = S_K . CVar $ printf "(%s * %s)" (getLbl a) (getLbl b)
  abs (S_K a)       = S_K . CVar $ printf "(abs %s)" (getLbl a)
  signum      = error "signum called on (KSig (S n))"
  fromInteger = S_K . Cnst . fromInteger

instance Fractional (KSig (S n)) where
  (S_K a) / (S_K b) = S_K . CVar $ printf "(%s / %s)" (getLbl a) (getLbl b)
  fromRational = S_K . Cnst . fromRational

instance Show (INum (S n)) where
  show (S_I s) = show s

instance Eq (INum (S n)) where
  (S_I a) == (S_I b) = a == b

instance Num (INum (S n)) where
  (S_I (Cnst a)) + (S_I (Cnst b)) = S_I $ Cnst (a+b)
  (S_I a) + (S_I b) = S_I . CVar $ printf "(%s + %s)" (getLbl a) (getLbl b)
  (S_I (Cnst a)) - (S_I (Cnst b)) = S_I $ Cnst (a-b)
  (S_I a) - (S_I b) = S_I . CVar $ printf "(%s - %s)" (getLbl a) (getLbl b)
  (S_I (Cnst a)) * (S_I (Cnst b)) = S_I $ Cnst (a*b)
  (S_I a) * (S_I b) = S_I . CVar $ printf "(%s * %s)" (getLbl a) (getLbl b)
  abs (S_I a)        = S_I . CVar $ printf "(abs %s)" (getLbl a)
  signum      = error "signum called on (INum (S n))"
  fromInteger = S_I . Cnst . fromInteger

instance Fractional (INum (S n)) where
  (S_I (Cnst a)) / (S_I (Cnst b)) = S_I . Cnst $ a/b
  (S_I a) / (S_I b) = S_I . CVar $ printf "(%s / %s)" (getLbl a) (getLbl b)
  fromRational = S_I . Cnst . fromRational

instance Show s => Show ((S n) s) where
  show s = show $ evalS s defaultRType

instance Eq e => Eq ((S n) e) where
  e1 == e2 = evalS ((==) <$> e1 <*> e2) defaultRType

instance Num e => Num ((S n) e) where
  e1 + e2     = (+) <$> e1 <*> e2
  e1 - e2     = (-) <$> e1 <*> e2
  e1 * e2     = (*) <$> e1 <*> e2
  abs         = fmap Prelude.abs
  signum      = fmap signum
  fromInteger = pure . fromInteger

instance Fractional e => Fractional ((S n) e) where
  e1 / e2 = (/) <$> e1 <*> e2
  recip   = fmap recip
  fromRational = pure . fromRational

-- ---------------------------------
-- ---------------------------------
-- Csound functions


-- ---------------------------------
-- ---------------------------------
-- core language extensions

-- | supports assignment
instance Varable a => Asn (S n) a where
  asn = mkOp1 "="

-- | supports output
instance Out (S n) where
  out = tellOrc . printf "       out %s\n" . getVarLbl
  outs a1 a2 = do
    (tellOrc $ printf "       outs %s, %s\n" (getVarLbl a1) (getVarLbl a2))
  outq a1 a2 a3 a4 = do
    (tellOrc $ printf "       outs %s, %s, %s, %s\n"
      (getVarLbl a1) (getVarLbl a2) (getVarLbl a3) (getVarLbl a4))
  outo a1 a2 a3 a4 a5 a6 a7 a8 = do
    (tellOrc $ printf "       outs %s, %s, %s, %s, %s, %s, %s, %s\n"
      (getVarLbl a1) (getVarLbl a2) (getVarLbl a3) (getVarLbl a4)
      (getVarLbl a5) (getVarLbl a6) (getVarLbl a7) (getVarLbl a8))

-- ---------------------------------
-- ---------------------------------
-- Buffers (function tables)

-- | creation of buffers
instance Buffer (S n) where
  type Buf (S n) = INum (S n)
  emptyBuffer sz = do
    bufNum <- mkName T
    mkScoreBuf bufNum sz
    return $ fromIntegral bufNum

instance (Varable a) => BufferR (S n) a a where
  lookupAt = flip (mkOp2 "tablei")

-- | creation of host-variable buffers
instance VBuf (S n) where
  vbuf lbl sz = do
    (SState cmap gen imap) <- get
    case M.lookup (CKC $ cacheBuf lbl sz) cmap of
      Just nm -> return $ S_I nm
      Nothing -> do
        bufNum <- mkName T
        mkScoreBuf bufNum sz
        tellHost . HostOut (TblBus sz) lbl $ show bufNum
        let res = Cnst $ fromIntegral bufNum
        cache (CKC $ cacheBuf lbl sz) res
        return $ S_I res

mkOp str l r = printf ("(%s " ++ str ++ " %s)") (getLbl l) (getLbl r)

instance RCmpr (KSig (S n)) where
  data RBool (KSig (S n)) = K_Bool String
  req (S_K l) (S_K r) = K_Bool $ mkOp "==" l r
  rne (S_K l) (S_K r) = K_Bool $ mkOp "!=" l r
  rlt (S_K l) (S_K r) = K_Bool $ mkOp "<" l r
  rle (S_K l) (S_K r) = K_Bool $ mkOp "<=" l r
  rgt (S_K l) (S_K r) = K_Bool $ mkOp ">" l r
  rge (S_K l) (S_K r) = K_Bool $ mkOp ">=" l r

instance RCmpr (INum (S n)) where
  data RBool (INum (S n)) = I_Bool String
  req (S_I l) (S_I r) = I_Bool $ mkOp "==" l r
  rne (S_I l) (S_I r) = I_Bool $ mkOp "!=" l r
  rlt (S_I l) (S_I r) = I_Bool $ mkOp "<" l r
  rle (S_I l) (S_I r) = I_Bool $ mkOp "<=" l r
  rgt (S_I l) (S_I r) = I_Bool $ mkOp ">" l r
  rge (S_I l) (S_I r) = I_Bool $ mkOp ">=" l r

instance Varable a => RCtrl (S n) (KSig (S n)) a where
  rIf (K_Bool b) m = runIf1 b m
  rIfElse (K_Bool b) m1 m2 = runIf b m1 m2

instance Varable a => RCtrl (S n) (INum (S n)) a where
  rIf (I_Bool b) m = runIf1 b m
  rIfElse (I_Bool b) m1 m2 = runIf b m1 m2

runIf1 test m1 = do
  tellOrc $ printf "if %s then\n" test
  a <- m1
  tellOrc "endif\n"
  return a

runIf test m1 m2 = do
  tellOrc $ printf "if %s then\n" test
  a <- m1
  let aLbl = getVarRep a
  tellOrc "else\n"
  b <- m2
  let bLbl = getVarRep b
  tellOrc $ printf "%s = %s\n" aLbl bLbl
  tellOrc "endif\n"
  return a

-- ---------------------------------
-- ---------------------------------
-- Instruments

instance (Nat m, Nat n, Show n, m :>=: n) => NumArgs S m n where
  getArg n = return . S_I . CVar $ 'p': show n

-- | Labelled blocks (basic instrument creation)
instance LblBlock (S n) where
  type ArgTag (S n) = n
  type ArgTyp (S n) = Either String Double
  data Block (S n) = Instr Int
  lblBlock num e = do
    isCached <- instrInCache num
    when (Prelude.not isCached) $ do
      tellOrc (printf "instr %d\n" num) >> e >> tellOrc "endin\n\n"
      clearBlockData
      cacheInstr num
    return $ Instr num
  runBlock = runBlock'

getArgVal :: Either String Double -> String
getArgVal = either show show

makeInstrument :: S n () -> S n (Block (S n))
makeInstrument e = do
  SState _ _ imap <- get
  maybe (lblBlock 1 e) (\(n, _) -> lblBlock (n+1) e) $ S.maxView imap

-- | After labelling a block (csound instr), we need to clear the opcode
-- caches, otherwise code could be invalidly shared between instruments.
-- We can clear the name generator too (except for table nums).
clearBlockData :: S n ()
clearBlockData = do
  (SState cmap genmap imap) <- get
  let cmap' = M.mapMaybeWithKey cmf cmap
      genmap' = M.mapMaybeWithKey gmf genmap
  put $ SState cmap' genmap' imap
 where
  cmf k       v = Just v
  gmf T n       = Just n
  gmf _ _       = Nothing

-- | Runs a block (instr).
runBlock' ::
  Block (S n)
  -> Double
  -> Double
  -> TList m (Either String Double)
  -> S n ()
runBlock' (Instr blkLbl) startIn dur args =
  writeCard . Card IC $ [show blkLbl, show startIn, show dur]
                        ++ map getArgVal (unTList args)

-- runBlock' should have the constraint (n :>=: m), but that doesn't work
-- because the constraint isn't passed through the LblBlock class.
-- It's not a problem because the constraint is enforced by "getArg", so
-- only valid arguments will be used.

-- | Writes the header data
writeHeader :: Int -> Double -> S n ()
writeHeader nc dbfs = do
  (sr,ksmps) <- ask
  setSR sr
  setKSmps ksmps
  nchnls nc
  set0dbfs dbfs
  return ()

setSR n       = tellOrc (printf "sr = %i\n" n) >> return n
setKSmps n    = tellOrc (printf "ksmps = %i\n" n) >> return n

-- ---------------------------------
-- ---------------------------------
-- Math ops

instance Math (S n) (ASig (S n)) where
  log2  (S_A a) = asn $ S_A . CVar $ printf "(logbtwo(%s))" (getLbl a)
  sqrt  (S_A a) = asn $ S_A . CVar $ printf "(sqrt(%s))" (getLbl a)
  int   (S_A a) = asn $ S_A . CVar $ printf "(int(%s))" (getLbl a)
  frac  (S_A a) = asn $ S_A . CVar $ printf "(frac(%s))" (getLbl a)
  floor (S_A a) = asn $ S_A . CVar $ printf "(floor(%s))" (getLbl a)

instance Math (S n) (KSig (S n)) where
  log2  (S_K a) = asn $ S_K . CVar $ printf "(logbtwo(%s))" (getLbl a)
  sqrt  (S_K a) = asn $ S_K . CVar $ printf "(sqrt(%s))" (getLbl a)
  int   (S_K a) = asn $ S_K . CVar $ printf "(int(%s))" (getLbl a)
  frac  (S_K a) = asn $ S_K . CVar $ printf "(frac(%s))" (getLbl a)
  floor (S_K a) = asn $ S_K . CVar $ printf "(floor(%s))" (getLbl a)

instance Math (S n) (INum (S n)) where
  log2  (S_I a) = asn $ S_I . CVar $ printf "(logbtwo(%s))" (getLbl a)
  sqrt  (S_I a) = asn $ S_I . CVar $ printf "(sqrt(%s))" (getLbl a)
  int   (S_I a) = asn $ S_I . CVar $ printf "(int(%s))" (getLbl a)
  frac  (S_I a) = asn $ S_I . CVar $ printf "(frac(%s))" (getLbl a)
  floor (S_I a) = asn $ S_I . CVar $ printf "(floor(%s))" (getLbl a)

-- ---------------------------------
-- ---------------------------------
-- phasor
instance Phasor (S n) (KSig (S n)) (KSig (S n)) where
  phasor = mkOp1 "phasor"

instance (Varable a) => Phasor (S n) (ASig (S n)) a where
  phasor = mkOp1 "phasor"

-- oscillators

-- | Supports table-lookup oscillators
instance (Varable a, Varable b, PVar out) => Oscil (S n) out a b where
  oscil   = mkOp3 "oscil3"
  oscil'  = mkOp4 "oscil3"

-- ---------------------------------
-- ---------------------------------
-- delays
instance Delay (S n) where
  delaySamp = mkOp1 "delay1"
  vdelay3   = mkOp3 "vdelay3"

-- delay networks
instance DelayNet (S n) where
  type DelayN (S n) = SDelay n
  runDelay  = runDelay'
  tapA      = tap'
  tapK      = tap'
  tapI      = tap'

newtype SDelay n a = SDelay { unDelay :: S n a }
  deriving (Functor)

instance Applicative (SDelay n) where
  pure = SDelay . pure
  (SDelay a) <*> (SDelay b) = SDelay (a <*> b)

runDelay' :: INum (S n) -> ASig (S n) -> SDelay n a -> S n a
runDelay' maxdel insig dl = do
  tellOrc $ printf "aNull delayr %s\n" (getVarLbl maxdel)
  v <- unDelay dl
  tellOrc $ printf "    delayw %s\n" (getVarLbl insig)
  return v

tap' :: Varable b => b -> SDelay n (ASig (S n))
tap' dtime = SDelay $ mkOp1 "deltap3" dtime


-- ---------------------------------
-- ---------------------------------
-- test instruments

-- | very basic block
t1 = do
  v <- csig 1000
  outs v v

-- | allocate a "variable buffer" (i.e. host-updated buffer)
t2 = do
  buf <- vbuf "a buffer" 8192
  so <- oscil 1000 440 buf
  outs so so

-- | delay networks

-- | simple delay with constant signal
t3 = do
  so <- runDelay 1 1000 (tapK 1)
  outs so so

t4 = do
  buf <- vbuf "a buffer" 8192
  so <- oscil 1000 440 buf
  let d = (\d1 d2 -> 0.5*d1+0.25*d2) <$> tapI 1 <*> tapI 2
  dl <- runDelay 2 so d
  sig <- asn $ so + dl
  outs sig sig

t5 = do
  buf <- vbuf "a buffer" 8192
  so  <- oscil 1000 440 buf
  let d = (\d1 d2 -> 0.5*d1+0.25*d2) <$> tapI 1 <*> tapI 2
  rec dl <- runDelay 2 (so+dl) d
  sig <- asn $ so + dl
  outs sig sig

t5' = do
  buf <- vbuf "a buffer" 8192
  so  <- oscil 1000 440 buf
  let d = (\d1 d2 -> 0.5*d1+0.25*d2) <$> tapI 1 <*> tapI 2
  rec dl <- runDelay 2 (so + 0.1*dl) d
  sig <- asn $ so + dl
  outs sig sig

-- | additive synthesis.  Shared buffer, uses the Num instance for signals.
t6 = do
  so  <- zipWithM (\fq buf -> oscil 1000 (fq*110) buf) [4..] (replicate 20 1)
  so' <- asn $ sum so
  outs so' so'

-- | using fold to make an oscil stack.  Note that emptyBuffer is *not*
-- memoized.
t8 = do
  buf <- emptyBuffer 8192
  stack <- foldM (\a f -> f a) (40)
                       (replicate 4 (\fq -> oscil 1000 fq buf))
  outs stack stack

-- | It's necessary to use monadic sequencing (here implicit in makeInstruments)
-- to chain instruments together
all1 = mapM makeInstrument [t1,t2, t3, t4, t5', t6, t8]