module CsoundExpr.Translator.Cs.CsoundFile (
CsoundFile(..),
Flags, Orchestra(..), Scores(..),
Value(..), Rate(..), ArgName(..), Param(..),
Header(..), Instr(..), OpcodeExpr(..), ArgOut, ArgIn(..),
Ftable(..), FtableInits(..), GEN(..), TotalDuration(..), Note(..), NoteInits(..),
defTempo
)
where
import Data.Char
import Data.List
import qualified Data.Map as Map
import Text.PrettyPrint
data CsoundFile = CsoundFile Flags Orchestra Scores
type Flags = String
data Orchestra = Orchestra Header [Instr]
data Scores = Scores [Ftable] Tempo TotalDuration [Note]
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)
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] [ArgIn]
deriving (Eq, Ord)
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
defTempo = Tempo []
nlines n = foldl1 ($$) $ take n $ repeat $ text ""
commentSection s =
(text "; -------------------------------") $$
(text $ "; " ++ s)
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"
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
flagsHeader =
text "<CsoundSynthesizer>" $$
text "<CsOptions>"
orchestraHeader =
text "</CsOptions>" $$
text "<CsInstruments>"
scoresHeader =
text "</CsInstruments>" $$
text "<CsScore>"
finHeader =
text "</CsScore>" $$
text "</CsoundSynthesizer>"
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
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
instance Show Header where
show (Instr0 []) = ""
show (Instr0 opcodes) = show $ empty $$ align lines $$ empty
where lines = map opcodeExprToLine opcodes
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
show (ArgInOpr op xs) = printOperator op xs
printOperator :: [Name] -> [ArgIn] -> String
printOperator op args = show $ hcat $ mergeLists opDoc argsDoc
where argsDoc = map (text . show) args
opDoc = map text op
mergeLists :: [a] -> [a] -> [a]
mergeLists x x' = case (x, x') of
([], _) -> x'
(_ , []) -> x
(a:as, b:bs) -> a : b : mergeLists as bs
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)
instance Show Tempo where
show (Tempo []) = ""
show (Tempo vals) = show $
text "t" <+>
(foldl1 (<+>) $ map double vals)
instance Show TotalDuration where
show (TotalDuration t) = show $ text "f 0" <+> double t
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