module Alga.Translation.Base
( AlgaBackend
, AutoMap
, AutoBatch
, AutoType (..)
, AutoTrack (..)
, nullTrack
, totalDur
, topDefs
, patchAuto )
where
import Alga.Language
import Alga.Representation (autoDel)
import Control.Monad.IO.Class
import Data.Map (Map)
import Data.Maybe (isJust, maybeToList)
import Data.Ratio (numerator, denominator)
import Numeric.Natural
import Path
import Text.Megaparsec
import Text.Megaparsec.String
import Text.XML.HXT.Core
import qualified Data.Map.Lazy as M
import qualified Text.Megaparsec.Lexer as L
type AlgaBackend = AutoMap -> IOSArrow XmlTree XmlTree
type AutoMap = Map String AutoBatch
type AutoBatch = Map AutoType AutoTrack
data AutoType
= Volume
| Mute
| IGain
| Pan
| InsertSlot Natural Natural
| SendSlot Natural Natural
| SynthParam Natural
deriving (Show, Eq, Ord)
data AutoTrack = AutoTrack
{ atVal :: [Double]
, atDur :: [Double]
} deriving (Eq, Show)
nullTrack :: AutoTrack -> Bool
nullTrack AutoTrack {..} = null atVal || null atDur
totalDur :: AutoTrack -> Double
totalDur AutoTrack {..} = sum atDur
topDefs :: HasEnv m => m [String]
topDefs = filter isTopRef <$> getRefs
patchAuto :: (MonadIO m, HasEnv m)
=> Natural
-> Double
-> Path Abs File
-> AlgaBackend
-> m Int
patchAuto s b fpath exec = do
setRandGen s
refs <- getRefs
amap <- M.fromListWith M.union . concat <$>
mapM (fmap maybeToList . toMap b) refs
let file = fromAbsFile fpath
uri = "file://" ++ n (g <$> file)
g x = if x == '\\' then '/' else x
n x = if head x /= '/' then '/' : x else x
head <$> (liftIO . runX $
readDocument [withValidate no] uri >>>
exec amap >>>
writeDocument [withIndent yes] file >>>
errorMsgStderr >>>
getErrStatus)
toMap :: HasEnv m
=> Double
-> String
-> m (Maybe (String, AutoBatch))
toMap b n =
case parseTopRef n of
Nothing -> return Nothing
Just (r, at) -> fmap f <$> evalTrack b n
where f x = (r, M.singleton at x)
evalTrack :: HasEnv m
=> Double
-> String
-> m (Maybe AutoTrack)
evalTrack b valRef = do
let durRef = valRef ++ durSuffix
val <- fmap toFloat <$> evalDef valRef
dur <- fmap toFloat <$> evalDef durRef
return $ if null val || null dur
then Nothing
else Just $ slice b AutoTrack { atVal = val, atDur = dur }
slice
:: Double
-> AutoTrack
-> AutoTrack
slice b AutoTrack {..} =
let n = f 0 0 atDur
f !i _ [] = i
f !i !a (x:xs) = if x + a >= b then succ i else f (succ i) (x + a) xs
in AutoTrack { atVal = take n atVal, atDur = take n atDur }
toFloat :: NRatio -> Double
toFloat x = fromIntegral (numerator x) / fromIntegral (denominator x)
isTopRef :: String -> Bool
isTopRef = isJust . parseMaybe pTopRef'
parseTopRef :: String -> Maybe (String, AutoType)
parseTopRef = parseMaybe pTopRef
pTopRef' :: Parser (String, AutoType)
pTopRef' = pTopRef <* optional (string durSuffix)
pTopRef :: Parser (String, AutoType)
pTopRef = (,) <$> some (satisfy (/= autoDel)) <* char autoDel <*> pSuffix
pSuffix :: Parser AutoType
pSuffix
= try pVolume
<|> try pMute
<|> try pIGain
<|> try pPan
<|> try pInsert
<|> try pSend
<|> pSynth
pVolume :: Parser AutoType
pVolume = Volume <$ string "volume"
pMute :: Parser AutoType
pMute = Mute <$ string "mute"
pIGain :: Parser AutoType
pIGain = IGain <$ string "igain"
pPan :: Parser AutoType
pPan = Pan <$ string "pan"
pInsert :: Parser AutoType
pInsert = string "i" *> (InsertSlot <$> pNum <* string "_" <*> pNum)
pSend :: Parser AutoType
pSend = string "s" *> (SendSlot <$> pNum <* string "_" <*> pNum)
pSynth :: Parser AutoType
pSynth = string "p" *> (SynthParam <$> pNum)
pNum :: Parser Natural
pNum = fromIntegral <$> L.integer
durSuffix :: String
durSuffix = "d"