module Alga.Translation.Cubase (cubaseBackend) where
import Alga.Translation.Base
import Control.Arrow
import Control.Arrow.ArrowTree
import Data.Bool (bool)
import Data.Char (ord)
import Data.Foldable (foldl')
import Data.Map.Lazy (Map)
import Data.Maybe (fromMaybe, listToMaybe)
import Numeric.Natural
import Text.XML.HXT.Core
import qualified Data.Map.Lazy as M
cubaseBackend :: AlgaBackend
cubaseBackend m =
configSysVars [withNoEmptyElemFor nonEmptyElts] >>>
"tracklist" />/ inList "track" ("obj" />/ procTrack m)
procTrack :: ArrowXml a
=> AutoMap
-> a XmlTree XmlTree
procTrack amap = mthis editTrack $< (trackName >>> arr prepBatch)
where editTrack ab = g ab $<< insertGuids &&& synthGuids
g ab is ps = inClass "MAutomationNode" (procAuto ab is ps)
prepBatch x = (`M.union` ritualVolumeEvent) <$> (x `M.lookup` amap)
procAuto :: ArrowXml a
=> AutoBatch
-> [String]
-> [String]
-> a XmlTree XmlTree
procAuto batch is ps = setInt "Expanded" 1 >>> deleteOld += mkTracks
where deleteOld = processChildren (none `when` deletable)
deletable = isList "Tracks" <+> isClass "MAutomationTrack"
mkTracks = M.foldlWithKey' f (mkList "Tracks" "obj" []) batch
f a k t = a ++= g k t
g k =
case k of
Volume -> volumeEvent
Mute -> muteEvent
IGain -> igainEvent
Pan -> panEvent
InsertSlot n s -> mnone' (`iEvent` s) (genInsertDN is n)
SendSlot n s -> sendEvent (genSendDN n) s
SynthParam s -> mnone' (`iEvent` s) (genSynthDN ps)
mnone' = maybe (const none)
volumeEvent :: ArrowXml a => AutoTrack -> a XmlTree XmlTree
volumeEvent = addEvent 1025 4 Nothing . fixRange
muteEvent :: ArrowXml a => AutoTrack -> a XmlTree XmlTree
muteEvent = addEvent 1027 5 Nothing
igainEvent :: ArrowXml a => AutoTrack -> a XmlTree XmlTree
igainEvent = addEvent 4099 4 Nothing . fixRange
panEvent :: ArrowXml a => AutoTrack -> a XmlTree XmlTree
panEvent = addEvent 4201 6 (Just "Panner")
iEvent :: ArrowXml a => String -> Natural -> AutoTrack -> a XmlTree XmlTree
iEvent dn i = addEvent (4201 + i) 4 (Just dn)
sendEvent :: ArrowXml a => String -> Natural -> AutoTrack -> a XmlTree XmlTree
sendEvent dn i = addEvent (4096 + i) 5 (Just dn) . bool id fixRange (i == 1)
addEvent :: ArrowXml a
=> Natural
-> Natural
-> Maybe String
-> AutoTrack
-> a XmlTree XmlTree
addEvent tag flags dn t =
mkObj (Just "MAutomationTrackEvent") Nothing Nothing
[ mkInt "Flags" 32
, mkFloat "Start" 0
, mkFloat "Length" (durFactor * totalDur t)
, mkObj (Just "MAutoListNode") (Just "Node") Nothing
[ mkMember "Domain"
[ mkInt "Type" 0 ]
, mkList "Events" "obj" (genEvents t) ]
, mkAutoTrack dn
, unlessNull (mkInt "Height" 42)
, mkInt "Tag" tag
, unlessNull (mkInt "TrackFlags" flags) ]
where unlessNull a = if nullTrack t then none else a
mkAutoTrack :: ArrowXml a => Maybe String -> a XmlTree XmlTree
mkAutoTrack dn = ifA (deep $ isAT dn) mkLink mkCmpl
where mkCmpl = mkObj (Just "MAutomationTrack") name (Just $ genID dn)
[ mkInt "Connection Type" (maybe 2 (const 7) dn)
, mnone (mkString "Device Name") dn
, mkInt "Read" 1
, mkInt "Write" 0 ]
mkLink = mkObj Nothing name (Just (genID dn)) []
name = Just "Track Device"
genEvents :: ArrowXml a => AutoTrack -> [a XmlTree XmlTree]
genEvents AutoTrack {..} = zipWith f atVal (fixDur atDur)
where f v d = mkObj (Just "MParamEvent") Nothing Nothing
[mkFloat "Start" d, mkFloat "Value" v]
fixRange :: AutoTrack -> AutoTrack
fixRange AutoTrack {..} = AutoTrack ((* 0.78908658027648926) <$> atVal) atDur
fixDur :: [Double] -> [Double]
fixDur = fmap (* durFactor) . reverse . tail . foldl' f []
where f [] a = [a, 0]
f xs@(x:_) a = x + a : xs
genInsertDN
:: [String]
-> Natural
-> Maybe String
genInsertDN is n = wrap <$> is !!! n
where wrap x = concat ["Inserts\\Slot", idx, "\\", x, "-0"]
idx = if n > 0 then " " ++ show (succ n) else ""
genSendDN :: Natural -> String
genSendDN n = "Sends\\Slot" ++ if n > 0 then " " ++ show (succ n) else ""
genSynthDN :: [String] -> Maybe String
genSynthDN ps = wrap <$> ps !!! 0
where wrap x = "Slot\\" ++ x ++ "-0"
genID :: Maybe String -> String
genID = show . (+ 13) . maybe 0 (sum . zipWith (+) [255,510..] . fmap ord)
mkObj :: ArrowXml a
=> Maybe String
-> Maybe String
-> Maybe String
-> [a XmlTree XmlTree]
-> a XmlTree XmlTree
mkObj c n i = mkelem "obj"
[ mnone (sattr "class") c
, mnone (sattr "name") n
, sattr "ID" (fromMaybe "7" i) ]
mkMember :: ArrowXml a
=> String
-> [a XmlTree XmlTree]
-> a XmlTree XmlTree
mkMember name = mkelem "member" [sattr "name" name]
mkList :: ArrowXml a
=> String
-> String
-> [a XmlTree XmlTree]
-> a XmlTree XmlTree
mkList name t = mkelem "list" [sattr "name" name, sattr "type" t]
mkString :: ArrowXml a
=> String
-> String
-> a XmlTree XmlTree
mkString n v = mkNamedVal "string" n v += sattr "wide" "true"
mkInt :: ArrowXml a
=> String
-> Natural
-> a XmlTree XmlTree
mkInt n v = mkNamedVal "int" n (show v)
mkFloat :: ArrowXml a
=> String
-> Double
-> a XmlTree XmlTree
mkFloat n v = mkNamedVal "float" n (show v)
mkNamedVal :: ArrowXml a
=> String
-> String
-> String
-> a XmlTree XmlTree
mkNamedVal t n v = mkelem t [sattr "name" n, sattr "value" v] []
trackName :: ArrowXml a => a XmlTree String
trackName = isAnyClass trackEvents /> isClass "MListNode" /> getStr "Name"
insertGuids :: ArrowXml a => a XmlTree [String]
insertGuids = guidsIn $ isMember "InsertFolder" /> isList "Slot" /> isItem
synthGuids :: ArrowXml a => a XmlTree [String]
synthGuids = guidsIn $ isMember "Synth Slot"
guidsIn :: ArrowXml a
=> a XmlTree XmlTree
-> a XmlTree [String]
guidsIn a =
listA $ getChildren >>>
isAnyClass tracks />
isMember "DeviceAttributes" />
a />
isMember "Plugin" />
isMember "Plugin UID" />
getStr "GUID"
getStr :: ArrowXml a => String -> a XmlTree String
getStr name =
isElem >>> hasName "string" >>> hasAttrValue "name" (== name) >>>
getAttrValue "value"
setInt :: ArrowXml a => String -> Int -> a XmlTree XmlTree
setInt name val = processChildren $ setVal `when` rightInt
where setVal = addAttr "value" (show val)
rightInt = isElem >>> hasName "int" >>> hasAttrValue "name" (== name)
isAT :: ArrowXml a => Maybe String -> a XmlTree XmlTree
isAT i = isClass "MAutomationTrack" >>> hasAttrValue "ID" (== genID i)
inList :: ArrowXml a => String -> a XmlTree XmlTree -> a XmlTree XmlTree
inList name action = processChildren $ action `when` isList name
isList :: ArrowXml a => String -> a XmlTree XmlTree
isList name = isElem >>> hasName "list" >>> hasAttrValue "name" (== name)
isAnyClass :: ArrowXml a
=> [String]
-> a XmlTree XmlTree
isAnyClass cs = catA (isClass <$> cs)
inClass :: ArrowXml a => String -> a XmlTree XmlTree -> a XmlTree XmlTree
inClass cls action = processChildren $ action `when` isClass cls
isClass :: ArrowXml a => String -> a XmlTree XmlTree
isClass cls = isElem >>> hasName "obj" >>> hasAttrValue "class" (== cls)
isMember :: ArrowXml a => String -> a XmlTree XmlTree
isMember name = isElem >>> hasName "member" >>> hasAttrValue "name" (== name)
isItem :: ArrowXml a => a XmlTree XmlTree
isItem = isElem >>> hasName "item"
mthis :: ArrowXml a => (b -> a XmlTree XmlTree) -> Maybe b -> a XmlTree XmlTree
mthis = maybe this
mnone :: ArrowXml a => (b -> a XmlTree XmlTree) -> Maybe b -> a XmlTree XmlTree
mnone = maybe none
infixl 7 ++=
(++=) :: ArrowXml a
=> a XmlTree XmlTree
-> a XmlTree XmlTree
-> a XmlTree XmlTree
a ++= b = a += (a >>> b)
infixr 5 />/
(/>/) :: ArrowXml a
=> String
-> a XmlTree XmlTree
-> a XmlTree XmlTree
name />/ action = processChildren $ action `when` (isElem >>> hasName name)
infixl 9 !!!
(!!!) :: [a] -> Natural -> Maybe a
xs !!! n = listToMaybe $ drop (fromIntegral n) xs
nonEmptyElts :: [String]
nonEmptyElts = ["bin","member","obj","list"]
trackEvents :: [String]
trackEvents = ["MAudioTrackEvent","MInstrumentTrackEvent","MDeviceTrackEvent"]
tracks :: [String]
tracks = ["MAudioTrack","MInstrumentTrack","MTrack"]
ritualVolumeEvent :: Map AutoType AutoTrack
ritualVolumeEvent = M.singleton Volume (AutoTrack [] [])
durFactor :: Double
durFactor = 1920