{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE NoRebindableSyntax #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies, NoMonoLocalBinds #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoIncoherentInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE NoUndecidableInstances #-}
module Vivid.SynthDef (
SynthDef(..)
, UGen(..)
, addUGen
, addMonoUGen
, addPolyUGen
, ToSig(..)
, Signal(..)
, encodeSD
, sd
, sdNamed
, sdPretty
, (?)
, DoneAction(..)
, doneActionNum
, sdLitPretty
, sdToLiteral
, execState
, getCalcRate
, UnaryOp(..)
, uOpToSpecialI
, specialIToUOp
, BinaryOp(..)
, biOpToSpecialI
, specialIToBiOp
, module Vivid.SynthDef.Types
, getSDHashName
, makeSynthDef
, shrinkSDArgs
, SDBody
) where
import Vivid.SC.SynthDef.Literally as Literal
import Vivid.SC.SynthDef.Types (CalculationRate(..), BinaryOp(..), UnaryOp(..))
import Vivid.SynthDef.ToSig
import Vivid.SynthDef.Types
import Vivid.SynthDef.FromUA (SDBody)
import Control.Arrow (first)
import Control.Monad.State (get, put, modify, execState)
import Data.ByteString (ByteString)
import qualified Data.ByteString.UTF8 as UTF8
import Data.Hashable (Hashable, hashWithSalt, hash)
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 Prelude
sdPretty :: SynthDef a -> String
sdPretty synthDef = unlines $ [
"Name: " <> show (_sdName synthDef)
, "Args: " <> show (_sdParams synthDef)
, "UGens: "
] <> map show (Map.toAscList (_sdUGens synthDef))
data DoneAction
= DoNothing
| FreeEnclosing
| DoneAction_AsNum Int
deriving (Show, Eq)
doneActionNum :: DoneAction -> Float
doneActionNum = \case
DoNothing -> 0
FreeEnclosing -> 2
DoneAction_AsNum n -> toEnum n
sdToLiteral :: SynthDef a -> Literal.LiteralSynthDef
sdToLiteral theSD@(SynthDef name params ugens) = fixAndSimplify $
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)
[]
fixAndSimplify :: Literal.LiteralSynthDef -> Literal.LiteralSynthDef
fixAndSimplify =
replaceBitNot
replaceBitNot :: Literal.LiteralSynthDef -> Literal.LiteralSynthDef
replaceBitNot lsd@(Literal.LiteralSynthDef name oldConsts params paramNames ugens variants) =
case any isBitNot ugens of
False -> lsd
True ->
Literal.LiteralSynthDef name newConsts params paramNames (map replaceIt ugens) variants
where
(newConsts, (toEnum::Int->Int32) -> negOneLoc) =
case elemIndex (-1) oldConsts of
Nothing -> (oldConsts <> [(-1)], (length::[a]->Int) oldConsts)
Just i -> (oldConsts, i)
isBitNot :: UGenSpec -> Bool
isBitNot ug =
(Literal._uGenSpec_name ug == "UnaryOpUGen")
&& (Literal._uGenSpec_specialIndex ug == uOpToSpecialI BitNot)
replaceIt :: UGenSpec -> UGenSpec
replaceIt ugspec = case isBitNot ugspec of
False -> ugspec
True -> UGenSpec
"BinaryOpUGen"
(Literal._uGenSpec_calcRate ugspec)
(Literal._uGenSpec_inputs ugspec <>
[InputSpec_Constant negOneLoc])
(Literal._uGenSpec_outputs ugspec)
(biOpToSpecialI BitXor)
getSDHashName :: SynthDef a -> ByteString
getSDHashName theSD =
"vivid_" <> (UTF8.fromString . show . hash) theSD
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
(UTF8.fromString "Control")
KR
[]
(replicate ((length::[a]->Int) 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 -> (UTF8.fromString "UnaryOpUGen", uOpToSpecialI uop)
UGName_B biop -> (UTF8.fromString "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
getFreshUGenGraphId :: SDBody' args Int
getFreshUGenGraphId = do
(ids, synthDef, argList) <- get
let (i:ds) = case ids of
[] -> error "You got to the end of an infinite list!"
_ -> ids
put (ds, synthDef, argList)
return i
addUGen :: UGen -> SDBody' args Signal
addUGen = addMonoUGen
addMonoUGen :: UGen -> SDBody' args Signal
addMonoUGen ugen = addPolyUGen ugen >>= \case
[x] -> return x
foo -> error $ "that ugen's not mono!: " <> show ugen <> show foo
addPolyUGen :: UGen -> SDBody' args [Signal]
addPolyUGen ugen = addPolyUGen' $ ugen
addPolyUGen' :: UGen -> SDBody' args [Signal]
addPolyUGen' ugen = do
anId <- getFreshUGenGraphId
modify . (\f (a,b,c)->(a,f b,c)) $ \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 :: VarList argList => argList -> SDBody' (InnerVars argList) [Signal] -> SynthDef (InnerVars argList)
sd params theState =
makeSynthDef SDName_Hash params theState
sdNamed :: VarList argList => String -> argList -> SDBody' (InnerVars argList) [Signal] -> SynthDef (InnerVars argList)
sdNamed name params theState =
makeSynthDef (SDName_Named $ UTF8.fromString name) params theState
makeSynthDef :: VarList argList => SDName -> argList -> SDBody' (InnerVars argList) [Signal] -> SynthDef (InnerVars argList)
makeSynthDef name params theState =
let theSD = SynthDef name (map (first UTF8.fromString) paramList) Map.empty
(paramList, argSet) = makeTypedVarList params
in (\(_,b,_)->b) $ execState theState $
( [0 :: Int ..], theSD, argSet)
(?) :: SDBody' args Signal -> CalculationRate -> SDBody' args Signal
(?) i calcRate = do
i' <- i
case i' of
UGOut ugId _o -> modify $ (\f (a,b,c)->(a,f b,c)) $ \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 -> SDBody' args 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!"
shrinkSDArgs :: Subset new old => SynthDef old -> SynthDef new
shrinkSDArgs (SynthDef a b c) = SynthDef a b c
encodeSD :: SynthDef a -> ByteString
encodeSD =
encodeSynthDefFile . SynthDefFile . (:[]) . sdToLiteral
instance Hashable (SynthDef a) where
hashWithSalt salt (SynthDef _name params ugens) =
hashWithSalt salt . encodeSD $
SynthDef (SDName_Named "VIVID FTW") params ugens