module CsoundExpr.Translator.Cs.CsoundFile (
    CsoundFile(..),
    Flags, Orchestra(..), Scores(..),
    Value(..), Rate(..), ArgName(..), Param(..),
    Header(..), Instr(..), OpcodeExpr(..), ArgOut, ArgIn(..), OprType(..),
    Ftable(..), FtableInits(..), GEN(..), TotalDuration(..), Note(..), NoteInits(..),
    defTempo
)
where

import Data.Char
import Data.List
import qualified Data.Map as Map
import Text.PrettyPrint

-----------------------------------------------------------
-----------------------------------------------------------
-- types

-- | csound code
data CsoundFile = CsoundFile Flags Orchestra Scores

-- | csound flags
type Flags = String
data Orchestra = Orchestra Header [Instr]
data Scores = Scores [Ftable] Tempo TotalDuration [Note]

-- basic types
type Id = Int

data Value = ValueInt Int
           | ValueDouble Double
           | ValueString String
             deriving (Eq, Ord)

data Rate = SetupRate | A | K | I | S | GA | GK | GI | GS
            deriving (Eq, Ord)

type Name = String
data ArgName = ArgName Rate Name
               deriving (Eq, Ord)
data Param = Param Id
             deriving (Eq, Ord)

-- Orchestra subtypes
newtype Header = Instr0 [OpcodeExpr]

data Instr = Instr Id [OpcodeExpr]

data OpcodeExpr = OpcodeExpr [ArgOut] Name [ArgIn]
                  deriving (Show)
type ArgOut = ArgName
data ArgIn = ArgInName ArgName
           | ArgInParam Param
           | ArgInValue Value
           | ArgInOpr Name OprType [ArgIn]
             deriving (Eq, Ord)

data OprType = Infix | Prefix
               deriving (Eq, Ord)

-- Scores subtypes
data Ftable = Ftable Id FtableInits GEN

data FtableInits = FtableInits LoadTime NumOfPoints

type LoadTime = Double
type NumOfPoints = Int

data GEN = GEN Id [Value]

newtype Tempo = Tempo [Double]

newtype TotalDuration = TotalDuration Double

data Note = Note Id NoteInits [Value]

data NoteInits = NoteInits StartTime Duration
type StartTime = Double
type Duration = Double

-----------------------------------------------------------
-----------------------------------------------------------
-- defaults

defTempo = Tempo []

-----------------------------------------------------------
-----------------------------------------------------------
-- pretty printing around


nlines n = foldl1 ($$) $ take n $ repeat $ text ""
commentSection s = 
    (text "; -------------------------------") $$ 
    (text $ "; " ++ s)


-----------------------------------------------------------
-----------------------------------------------------------
-- rates

instance Show Rate where
    show x = case x of
               SetupRate -> ""
               A         -> "a"
               K         -> "k"
               I         -> "i"
               S         -> "S"
               GA        -> "ga"
               GK        -> "gk"
               GI        -> "gi"                   
               GS        -> "gS"

-----------------------------------------------------------
-----------------------------------------------------------
-- .CSD file

instance Show CsoundFile where
    show (CsoundFile flags orc sco) = show $
             flagsHeader $$
             (text flags) $$
             orchestraHeader $$
             (text $ show orc) $$            
             scoresHeader $$
             (text $ show sco) $$           
             finHeader
        where nlineOffset = 2

-----------------------------------------------------------    
-----------------------------------------------------------
-- headers for .CSD file

-- <CsoundSynthesizer>
-- <CsOptions>
flagsHeader = 
    text "<CsoundSynthesizer>" $$ 
    text "<CsOptions>"

-- </CsOptions>
-- <CsInstruments>
orchestraHeader = 
    text "</CsOptions>" $$
    text "<CsInstruments>"

-- </CsInstruments>
-- <CsScore>
scoresHeader = 
    text "</CsInstruments>" $$
    text "<CsScore>"

-- </CsScore>
-- </CsoundSynthesizer>
finHeader = 
    text "</CsScore>" $$
    text "</CsoundSynthesizer>"

-----------------------------------------------------------
-----------------------------------------------------------
-- .ORC file

instance Show Orchestra where 
    show (Orchestra header instrs) = show $
             (commentSection "Header") $$
             (text $ show header) $$ 
             nlines (2*nlineOffset) $$
             (commentSection "Instruments") $$
             (vcat $ 
                   map ((nlines nlineOffset <>) . text . show) instrs) $$
             nlines (2*nlineOffset)
        where nlineOffset = 1


-----------------------------------------------------------
-----------------------------------------------------------
-- .SCO file

instance Show Scores where
    show (Scores ftables tempo totalDuration notes) = show $
              (commentSection "Ftables") $$
              (text $ show totalDuration) $$
              (vcat $ map (text . show) ftables) $$
              (nlines (2*nlineOffset)) $$
              (commentSection "Tempo") $$
              (text $ show tempo) $$
              (nlines (2*nlineOffset)) $$
              (commentSection "Notes") $$
              (vcat $ map (text . show) notes) $$
              (nlines nlineOffset) $$
              (text "e") $$
              (nlines (2*nlineOffset))        
        where nlineOffset = 1
              
                      
----------------------------------------------------
----------------------------------------------------
-- flags section

----------------------------------------------------
----------------------------------------------------
-- orchestra section (header, intruments)

----------------------------------------------------
-- header section

instance Show Header where
    show (Instr0 []) = ""
    show (Instr0 opcodes) = show $ empty $$ align lines $$ empty
        where lines = map opcodeExprToLine opcodes    

----------------------------------------------------
-- instrument section

instance Show Instr where
    show (Instr id opcodes) = show $ space $$ align lines $$ space
        where lines = firstLine ++ body ++ lastLine
              firstLine = [("", "instr", show id)]
              lastLine = [("", "endin", "")]
              body = map opcodeExprToLine opcodes

align :: [(String, String, String)] -> Doc
align lines = foldl1 ($$) $ map (f indent1 indent2) lines
    where offset = 3
          indent1 = offset + maximum [length x | (x, _, _) <- lines]
          indent2 = offset + maximum [length x | (_, x, _) <- lines]
          f n1 n2 (x1, x2, x3) = 
              text x1 $$ 
              nest (n1) (text x2) $$
              nest (n1+n2) (text x3)

opcodeExprToLine :: OpcodeExpr -> (String, String, String)
opcodeExprToLine (OpcodeExpr argsOut opcode argsIn) = 
    (argsToLine argsOut, opcode, argsToLine argsIn)
    where
      argsToLine :: Show a => [a] -> String
      argsToLine = show . hcat . 
                   punctuate (comma <> space) . map (text . show) 

instance Show ArgName where
    show (ArgName rate name) = show rate ++ name

instance Show Param where
    show (Param id) = "p" ++ show id

instance Show Value where
    show (ValueString s) = show s
    show (ValueInt x) = show x
    show (ValueDouble x) = show x


instance Show ArgIn where
    show (ArgInName x) = show x
    show (ArgInParam x) = show x
    show (ArgInValue x) = show x
-- operators
    show (ArgInOpr op opType xs) = printOperator op opType xs
--        if (Map.member op operators)
--        then 
--        else error "no such operator"
           
printOperator :: Name -> OprType -> [ArgIn] -> String
printOperator op desc args = 
    case desc of
      Prefix -> show $ opStr <> (parens $ hcat $ argsStr)              
      Infix  -> show $ parens $ hcat $ punctuate space [arg1Str, opStr, arg2Str]
    where opStr   = text op
          argsStr = punctuate (comma <> space) $ map (text . show) args
          (arg1Str, arg2Str) = 
              if length args == 1
              then (text "", parens $ text $ show $ head args)
              else (text $ show (args !! 0), text $ show (args !! 1))
                                      

----------------------------------------------------
----------------------------------------------------
-- scores section

----------------------------------------------------
-- ftable section

instance Show Ftable where
    show (Ftable id inits gen) = show $
                                 (text "f") <+> 
                                 int id <+>
                                 (text $ show inits) <+>
                                 (text $ show gen)


instance Show FtableInits where
    show (FtableInits loadTime numOfPoints) = show $ 
                (text $ show loadTime) <+>
                (text $ show numOfPoints) 

instance Show GEN where
    show (GEN id vals) = show $ int id <+>
                         (foldl1 (<+>) $ map (text . show) vals)

----------------------------------------------------
-- tempo 

instance Show Tempo where
    show (Tempo []) = ""
    show (Tempo vals) = show $ 
                     text "t" <+> 
                     (foldl1 (<+>) $ map double vals)


----------------------------------------------------
-- total duration

instance Show TotalDuration where
    show (TotalDuration t) = show $ text "f 0" <+> double t

----------------------------------------------------
-- notes

instance Show Note where
    show (Note id noteInits vals) = show $ inits <+> aux
        where
          inits = text "i" <+> int id <+> (text $ show noteInits)
          aux = if (length vals == 0)
                then text "" 
                else foldl1 (<+>) $ map (text . show) vals

instance Show NoteInits where
    show (NoteInits start duration) = show $ 
                                      double start <+> double duration