module Vivid.SynthDef (
synth
, set
, free
, SynthDef(..)
, UGen(..)
, addUGen
, addMonoUGen
, addPolyUGen
, ToSig(..)
, ToSigM(..)
, Signal(..)
, encodeSD
, defineSD
, sd
, sdNamed
, sdPretty
, (?)
, play
, cmdPeriod
, DoneAction(..)
, doneActionNum
, sdLitPretty
, HasSynthRef
, sdToLiteral
, execState
, getCalcRate
, UnaryOp(..)
, uOpToSpecialI
, specialIToUOp
, BinaryOp(..)
, biOpToSpecialI
, specialIToBiOp
, module Vivid.SynthDef.Types
) where
import Vivid.OSC (OSC(..), OSCDatum(..))
import Vivid.SCServer
import Vivid.SynthDef.CrazyTypes
import Vivid.SynthDef.Literally as Literal
import Vivid.SynthDef.Types
import Control.Applicative
import Control.Arrow (first, second)
import Control.Concurrent.STM
import Control.Monad.State
import qualified Data.ByteString.Char8 as BS8
import Data.ByteString (ByteString)
import Data.Hashable
import Data.Int
import Data.List (nub, elemIndex, find)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import qualified Data.Set as Set
sdPretty :: SynthDef -> String
sdPretty synthDef = unlines $ [
"Name: " <> show (_sdName synthDef)
, "Args: " <> show (_sdParams synthDef)
, "UGens: "
] <> map show (Map.toAscList (_sdUGens synthDef))
data DoneAction
= DoNothing
| FreeEnclosing
deriving (Show, Eq)
doneActionNum :: DoneAction -> Float
doneActionNum = \case
DoNothing -> 0
FreeEnclosing -> 2
uOpToSpecialI :: UnaryOp -> Int16
uOpToSpecialI uop = toEnum . fromEnum $ uop
specialIToUOp :: Int16 -> UnaryOp
specialIToUOp specialI = toEnum . fromEnum $ specialI
biOpToSpecialI :: BinaryOp -> Int16
biOpToSpecialI theBiOp = toEnum . fromEnum $ theBiOp
specialIToBiOp :: Int16 -> BinaryOp
specialIToBiOp theBiOp = toEnum . fromEnum $ theBiOp
sdToLiteral :: SynthDef -> Literal.LiteralSynthDef
sdToLiteral theSD@(SynthDef name params ugens) =
LiteralSynthDef
(case name of
SDName_Named s -> s
SDName_Hash -> getSDHashName theSD
)
(gatherConstants $ Map.toAscList ugens)
(map snd params)
(zipWith (\s i -> ParamName s i) (map fst params) [0..])
(makeUGenSpecs params $ Map.toAscList ugens)
[]
getSDHashName :: SynthDef -> ByteString
getSDHashName theSD =
"vivid_" <> (BS8.pack . show . hash) theSD
encodeSD :: SynthDef -> ByteString
encodeSD = encodeSynthDefFile . SynthDefFile . (:[]) . sdToLiteral
instance Hashable SynthDef where
hash (SynthDef _name params ugens) = hash . encodeSD $
SynthDef (SDName_Named "VIVID FTW") params ugens
gatherConstants :: [(Int, UGen)] -> [Float]
gatherConstants ugens =
nub [ x | Constant x <- concatMap (_ugenIns . snd) ugens]
makeUGenSpecs :: [(ByteString, Float)] -> [(Int, UGen)] -> [Literal.UGenSpec]
makeUGenSpecs params ugens = case params of
[] -> rest
_ -> control : rest
where
control = UGenSpec
(BS8.pack "Control")
KR
[]
(replicate (length params) (OutputSpec KR))
0
rest = map makeSpec ugens
makeSpec :: (Int, UGen) -> UGenSpec
makeSpec (_, UGen name calcRate ins numOuts) =
let (theName, specialIndex) = case name of
UGName_S s -> (s, 0)
UGName_U uop -> (BS8.pack "UnaryOpUGen", uOpToSpecialI uop)
UGName_B biop -> (BS8.pack "BinaryOpUGen", biOpToSpecialI biop)
in UGenSpec
theName
calcRate
((flip map) ins $ \case
Constant x -> InputSpec_Constant $ fromIntegral $ fromJust $
elemIndex x $ gatherConstants ugens
UGOut ugenId outputNum ->
let inputPosition = toEnum ugenId + case params of
[] -> 0
_ -> 1
in InputSpec_UGen inputPosition outputNum
Param s -> InputSpec_UGen 0 (indexOfName params s)
)
(replicate numOuts (OutputSpec calcRate))
specialIndex
indexOfName :: (Eq a) => [(ByteString, a)] -> ByteString -> Int32
indexOfName haystack key =
let foo = case find ((==key) . fst) haystack of
Nothing -> error $ "missing param: " <> show key
Just x -> x
in fromIntegral $ fromJust $ (flip elemIndex) haystack $ foo
defineSD :: SynthDef -> IO ()
defineSD synthDef =
defineSDIfNeeded synthDef
defineSDIfNeeded :: SynthDef -> IO ()
defineSDIfNeeded synthDef@(SynthDef name _ _) = do
hasBeenDefined <- (((name, hash synthDef) `Set.member`) <$>) $
readTVarIO (scServer_definedSDs scServerState)
unless hasBeenDefined $ do
callAndWaitForDone $ OSC (BS8.pack "/d_recv") [
OSC_B $ encodeSD synthDef
, OSC_I 0
]
atomically $ modifyTVar (scServer_definedSDs scServerState) $
((name, hash synthDef) `Set.insert`)
getFreshUGenGraphId :: SDState Int
getFreshUGenGraphId = do
(i:ds, synthDef) <- get
put (ds, synthDef)
return i
addUGen :: UGen -> SDState Signal
addUGen = addMonoUGen
addMonoUGen :: UGen -> SDState Signal
addMonoUGen ugen = addPolyUGen ugen >>= \case
[x] -> return x
foo -> error $ "that ugen's not mono!: " <> show ugen <> show foo
addPolyUGen :: UGen -> SDState [Signal]
addPolyUGen ugen = do
anId <- getFreshUGenGraphId
modify . second $ \synthDef -> synthDef { _sdUGens =
Map.unionWith (\_ -> error "dammit keying broken") (_sdUGens synthDef) $
Map.singleton anId ugen
}
return $ map (UGOut anId) [0.. toEnum (_ugenNumOuts ugen 1)]
sd :: [(String, Float)] -> SDState x -> SynthDef
sd params theState =
makeSynthDef SDName_Hash params theState
sdNamed :: String -> [(String, Float)] -> SDState x -> SynthDef
sdNamed name params theState =
makeSynthDef (SDName_Named $ BS8.pack name) params theState
makeSynthDef :: SDName -> [(String, Float)] -> SDState x -> SynthDef
makeSynthDef name params theState =
let theSD = SynthDef name (map (first BS8.pack) params) Map.empty
in snd $ execState theState ( [0 :: Int ..], theSD)
(?) :: SDState Signal -> CalculationRate -> SDState Signal
(?) i calcRate = do
i' <- i
case i' of
UGOut ugId _o -> modify $ second $ \synthDef ->
let ugs = _sdUGens synthDef
updatedUGens :: Map Int UGen
updatedUGens = case Map.lookup ugId ugs of
Nothing -> error "ugen id not found"
Just UGen{} ->
Map.adjust (\ug -> ug { _ugenCalculationRate = calcRate }) ugId ugs
in synthDef { _sdUGens = updatedUGens }
_ -> return ()
return i'
getCalcRate :: Signal -> SDState CalculationRate
getCalcRate (Constant _) = return IR
getCalcRate (Param _) = return KR
getCalcRate (UGOut theUG _) = do
(_, ugenGraph) <- get
case Map.lookup theUG (_sdUGens ugenGraph) of
Just ug -> return $ _ugenCalculationRate ug
Nothing -> error "that output isn't in the graph!"
play :: SDState a -> IO NodeId
play x = do
let graphWithOut = x
let sdWithOut = sd [] graphWithOut
synth sdWithOut []
sdLitPretty :: Literal.LiteralSynthDef -> String
sdLitPretty synthDef = mconcat [
"Constants: ", show $ _synthDefConstants synthDef
, "\n"
, mconcat$
(flip map) (Literal._synthDefUGens synthDef) $ \ug -> mconcat [
show (_uGenSpec_name ug) <> " - " <> show (_uGenSpec_calcRate ug)
,"\n"
,mconcat $ map ((<>"\n") . (" "<>) . show) $ _uGenSpec_inputs ug
,case BS8.unpack (_uGenSpec_name ug) of
"UnaryOpUGen" -> mconcat [ " "
, show ( specialIToUOp (_uGenSpec_specialIndex ug))
, "\n" ]
"BinaryOpUGen" ->
" " <> show (specialIToBiOp (_uGenSpec_specialIndex ug)) <> "\n"
_ -> ""
]
]
free :: NodeId -> IO ()
free (NodeId nodeId) =
call $ OSC (BS8.pack "/n_free") [ OSC_I nodeId ]
set :: NodeId -> [(String, Float)] -> IO ()
set (NodeId nodeId) params =
call $ OSC (BS8.pack "/n_set") $ OSC_I nodeId : paramList
where
paramList :: [OSCDatum]
paramList = concatMap (\(k,v)->[OSC_S k,OSC_F v]) $
map (first BS8.pack) params
synth :: (HasSynthRef a) => a -> [(String, Float)] -> IO NodeId
synth refHolder params = do
case getSynthRef refHolder of
Left _ -> return ()
Right aSD -> defineSDIfNeeded aSD
nodeId@(NodeId nn) <- newNodeId
let synthName = case getSynthRef refHolder of
Left sn -> sn
Right (SynthDef (SDName_Named n) _ _) -> n
Right theSD@(SynthDef SDName_Hash _ _) -> getSDHashName theSD
call $ OSC (BS8.pack "/s_new") $ [
OSC_S $ synthName, OSC_I nn
, OSC_I 0
, OSC_I 1
] <> paramList
return nodeId
where
paramList :: [OSCDatum]
paramList = concatMap (\(k, v) -> [OSC_S k, OSC_F v]) $
map (first BS8.pack) params