-- | Synth Definitions in SuperCollider are how you define the way synths should sound
--   -- you describe parameters and a graph of sound generators, add them to the server
--   with 'defineSD', and then create instances of the Synth Definition (called "synths"),
--   which each play separately. You can set parameters of the synth at any time while
--   they're playing
-- 
--   Usually, you shouldn't be making 'SynthDef's explicitly -- there's a state monad
--   'SDBody' which lets you construct synthdefs like so:
-- 
--   @
--   test :: SynthDef
--   test = 'sd' (0 ::I \"note\") $ do
--      s <- 0.1 'Vivid.UGens.~*' 'Vivid.UGens.sinOsc' (freq_ $ 'Vivid.UGens.midiCPS' (V::V \"note\"))
--      out 0 [s, s]
--   @
-- 
--   You then optionally explicitly send the synth definition to the SC server with
-- 
--   >>> defineSD test
-- 
--   You then create a synth from the synthdef like:
-- 
--   >>> s <- synth test (45 ::I "note")
-- 
--   This returns a 'NodeId' which is a reference to the synth, which you can
--   use to e.g. change the params of the running synth with e.g.
-- 
--   >>> set s (38 ::I "note")
-- 
--   Then you can free it (stop its playing) with
-- 
--   >>> free s
-- 
--   (If you want interop with SClang, use "sdNamed" and "synthNamed")

{-# OPTIONS_HADDOCK show-extensions #-}

{-# LANGUAGE NoRebindableSyntax #-}

{-# LANGUAGE
     BangPatterns
   , DataKinds
   , LambdaCase
   , OverloadedStrings
   , TypeFamilies, NoMonoLocalBinds
   , ViewPatterns
   #-}

{-# LANGUAGE NoIncoherentInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE NoUndecidableInstances #-}

module Vivid.SynthDef (
  -- * Synth actions

  -- * Synth Definition Construction
    SynthDef(..)
  , UGen(..)
  , addUGen
  , addMonoUGen
  , addPolyUGen
  , addOrIncrementMaxLocalBufs
  , ToSig(..)
  , Signal(..)
  , encodeSD
--  , defineSD
  , sd
  , sdNamed
  , sdPretty
  , (?)
--  , play
--  , cmdPeriod
  , DoneAction(..)
  , doneActionNum
  , sdLitPretty
  , sdToLiteral
  -- literalToSD

  , execState

  , getCalcRate

  -- * Built-in Unit Generator Operations

  , 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.Applicative
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) -- , sortBy)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
-- import qualified Data.Set as Set
import Prelude

sdPretty :: SynthDef a -> String
sdPretty :: forall (a :: [Symbol]). SynthDef a -> String
sdPretty SynthDef a
synthDef = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
     String
"Name: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SDName -> String
forall a. Show a => a -> String
show (SynthDef a -> SDName
forall (args :: [Symbol]). SynthDef args -> SDName
_sdName SynthDef a
synthDef)
   , String
"Args: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(ByteString, Float)] -> String
forall a. Show a => a -> String
show (SynthDef a -> [(ByteString, Float)]
forall (args :: [Symbol]). SynthDef args -> [(ByteString, Float)]
_sdParams SynthDef a
synthDef)
   , String
"UGens: "
   ] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> ((Int, UGen) -> String) -> [(Int, UGen)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, UGen) -> String
forall a. Show a => a -> String
show (Map Int UGen -> [(Int, UGen)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (SynthDef a -> Map Int UGen
forall (args :: [Symbol]). SynthDef args -> Map Int UGen
_sdUGens SynthDef a
synthDef))

-- | Action to take with a UGen when it's finished
-- 
--   This representation will change in the future
data DoneAction
   = DoNothing
   | FreeEnclosing
   | DoneAction_AsNum Int
 deriving (Int -> DoneAction -> String -> String
[DoneAction] -> String -> String
DoneAction -> String
(Int -> DoneAction -> String -> String)
-> (DoneAction -> String)
-> ([DoneAction] -> String -> String)
-> Show DoneAction
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DoneAction -> String -> String
showsPrec :: Int -> DoneAction -> String -> String
$cshow :: DoneAction -> String
show :: DoneAction -> String
$cshowList :: [DoneAction] -> String -> String
showList :: [DoneAction] -> String -> String
Show, DoneAction -> DoneAction -> Bool
(DoneAction -> DoneAction -> Bool)
-> (DoneAction -> DoneAction -> Bool) -> Eq DoneAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DoneAction -> DoneAction -> Bool
== :: DoneAction -> DoneAction -> Bool
$c/= :: DoneAction -> DoneAction -> Bool
/= :: DoneAction -> DoneAction -> Bool
Eq)

doneActionNum :: DoneAction -> Float
doneActionNum :: DoneAction -> Float
doneActionNum = \case
   DoneAction
DoNothing -> Float
0
   DoneAction
FreeEnclosing -> Float
2
   DoneAction_AsNum Int
n -> Int -> Float
forall a. Enum a => Int -> a
toEnum Int
n

--invariants (to check):
-- param names don't clash
-- graph is real and acyclic
-- no "dangling" pieces -- sign that something's wrong
-- params are all used, and the ones that're used in the graph all exist


sdToLiteral :: SynthDef a -> Literal.LiteralSynthDef
sdToLiteral :: forall (a :: [Symbol]). SynthDef a -> LiteralSynthDef
sdToLiteral theSD :: SynthDef a
theSD@(SynthDef SDName
name [(ByteString, Float)]
params Map Int UGen
ugens) = LiteralSynthDef -> LiteralSynthDef
fixAndSimplify (LiteralSynthDef -> LiteralSynthDef)
-> LiteralSynthDef -> LiteralSynthDef
forall a b. (a -> b) -> a -> b
$
   ByteString
-> [Float]
-> [Float]
-> [ParamName]
-> [UGenSpec]
-> [VariantSpec]
-> LiteralSynthDef
LiteralSynthDef
      (case SDName
name of
         SDName_Named ByteString
s -> ByteString
s
         SDName
SDName_Hash -> SynthDef a -> ByteString
forall (a :: [Symbol]). SynthDef a -> ByteString
getSDHashName SynthDef a
theSD
         )
      ([(Int, UGen)] -> [Float]
gatherConstants ([(Int, UGen)] -> [Float]) -> [(Int, UGen)] -> [Float]
forall a b. (a -> b) -> a -> b
$ Map Int UGen -> [(Int, UGen)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Int UGen
ugens )
      (((ByteString, Float) -> Float) -> [(ByteString, Float)] -> [Float]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Float) -> Float
forall a b. (a, b) -> b
snd [(ByteString, Float)]
params)
      ((ByteString -> Int32 -> ParamName)
-> [ByteString] -> [Int32] -> [ParamName]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ByteString
s Int32
i -> ByteString -> Int32 -> ParamName
ParamName ByteString
s Int32
i) (((ByteString, Float) -> ByteString)
-> [(ByteString, Float)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Float) -> ByteString
forall a b. (a, b) -> a
fst [(ByteString, Float)]
params) [Int32
0..])
      ([(ByteString, Float)] -> [(Int, UGen)] -> [UGenSpec]
makeUGenSpecs [(ByteString, Float)]
params ([(Int, UGen)] -> [UGenSpec]) -> [(Int, UGen)] -> [UGenSpec]
forall a b. (a -> b) -> a -> b
$ Map Int UGen -> [(Int, UGen)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Int UGen
ugens)
      []

fixAndSimplify :: Literal.LiteralSynthDef -> Literal.LiteralSynthDef
fixAndSimplify :: LiteralSynthDef -> LiteralSynthDef
fixAndSimplify =
   LiteralSynthDef -> LiteralSynthDef
replaceBitNot


-- Can unit test this by making a complex SD graph that uses
-- multiple "bitNot"s and checking that it's exactly equal to if
-- we'd used '& . bitXor 0xFFFFFF'

-- silent:
-- play $ (0.1 ~* sinOsc (freq_ 440)) >>= \x -> uOp BitNot x >>= \y -> biOp BitAnd y x >>= \z -> out 0 [z,z]

-- | Fix for github.com/supercollider/supercollider/issues/1749
replaceBitNot :: Literal.LiteralSynthDef -> Literal.LiteralSynthDef
replaceBitNot :: LiteralSynthDef -> LiteralSynthDef
replaceBitNot lsd :: LiteralSynthDef
lsd@(Literal.LiteralSynthDef ByteString
name [Float]
oldConsts [Float]
params [ParamName]
paramNames [UGenSpec]
ugens [VariantSpec]
variants) =
   case (UGenSpec -> Bool) -> [UGenSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any UGenSpec -> Bool
isBitNot [UGenSpec]
ugens of
      Bool
False -> LiteralSynthDef
lsd
      Bool
True ->
         ByteString
-> [Float]
-> [Float]
-> [ParamName]
-> [UGenSpec]
-> [VariantSpec]
-> LiteralSynthDef
Literal.LiteralSynthDef ByteString
name [Float]
newConsts [Float]
params [ParamName]
paramNames ((UGenSpec -> UGenSpec) -> [UGenSpec] -> [UGenSpec]
forall a b. (a -> b) -> [a] -> [b]
map UGenSpec -> UGenSpec
replaceIt [UGenSpec]
ugens) [VariantSpec]
variants
 where
   -- newConsts :: [Float];  newOneLoc :: Int32
   ([Float]
newConsts, (Int -> Int32
forall a. Enum a => Int -> a
toEnum::Int->Int32) -> Int32
negOneLoc) =
      case Float -> [Float] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (-Float
1) [Float]
oldConsts of
         Maybe Int
Nothing -> ([Float]
oldConsts [Float] -> [Float] -> [Float]
forall a. Semigroup a => a -> a -> a
<> [(-Float
1)], ([a] -> Int
forall {a}. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length::[a]->Int) [Float]
oldConsts)
         Just Int
i -> ([Float]
oldConsts, Int
i)
   isBitNot :: UGenSpec -> Bool
   isBitNot :: UGenSpec -> Bool
isBitNot UGenSpec
ug =
         (UGenSpec -> ByteString
Literal._uGenSpec_name UGenSpec
ug ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"UnaryOpUGen")
      Bool -> Bool -> Bool
&& (UGenSpec -> Int16
Literal._uGenSpec_specialIndex UGenSpec
ug Int16 -> Int16 -> Bool
forall a. Eq a => a -> a -> Bool
== UnaryOp -> Int16
uOpToSpecialI UnaryOp
BitNot)
   replaceIt :: UGenSpec -> UGenSpec
   replaceIt :: UGenSpec -> UGenSpec
replaceIt UGenSpec
ugspec = case UGenSpec -> Bool
isBitNot UGenSpec
ugspec of
      Bool
False -> UGenSpec
ugspec
      Bool
True -> ByteString
-> CalculationRate
-> [InputSpec]
-> [OutputSpec]
-> Int16
-> UGenSpec
UGenSpec
         ByteString
"BinaryOpUGen"
         (UGenSpec -> CalculationRate
Literal._uGenSpec_calcRate UGenSpec
ugspec)
         (UGenSpec -> [InputSpec]
Literal._uGenSpec_inputs UGenSpec
ugspec [InputSpec] -> [InputSpec] -> [InputSpec]
forall a. Semigroup a => a -> a -> a
<>
            [Int32 -> InputSpec
InputSpec_Constant Int32
negOneLoc])
         (UGenSpec -> [OutputSpec]
Literal._uGenSpec_outputs UGenSpec
ugspec)
         (BinaryOp -> Int16
biOpToSpecialI BinaryOp
BitXor)

getSDHashName :: SynthDef a -> ByteString
getSDHashName :: forall (a :: [Symbol]). SynthDef a -> ByteString
getSDHashName SynthDef a
theSD =
   ByteString
"vivid_" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (String -> ByteString
UTF8.fromString (String -> ByteString)
-> (SynthDef a -> String) -> SynthDef a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (SynthDef a -> Int) -> SynthDef a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynthDef a -> Int
forall a. Hashable a => a -> Int
hash) SynthDef a
theSD

{-
-- Anyone, write it for me if you wanna!:
literalToSD :: Literal.SynthDef -> SD
literalToSD =
-}

gatherConstants :: [(Int, UGen)] -> [Float]
gatherConstants :: [(Int, UGen)] -> [Float]
gatherConstants [(Int, UGen)]
ugens =
   [Float] -> [Float]
forall a. Eq a => [a] -> [a]
nub [ Float
x | Constant Float
x <- ((Int, UGen) -> [Signal]) -> [(Int, UGen)] -> [Signal]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (UGen -> [Signal]
_ugenIns (UGen -> [Signal])
-> ((Int, UGen) -> UGen) -> (Int, UGen) -> [Signal]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, UGen) -> UGen
forall a b. (a, b) -> b
snd) [(Int, UGen)]
ugens]

makeUGenSpecs :: [(ByteString, Float)] -> [(Int, UGen)] -> [Literal.UGenSpec]
makeUGenSpecs :: [(ByteString, Float)] -> [(Int, UGen)] -> [UGenSpec]
makeUGenSpecs [(ByteString, Float)]
params [(Int, UGen)]
ugens = case [(ByteString, Float)]
params of
   [] -> [UGenSpec]
rest
   [(ByteString, Float)]
_ -> UGenSpec
control UGenSpec -> [UGenSpec] -> [UGenSpec]
forall a. a -> [a] -> [a]
: [UGenSpec]
rest
 where
   control :: UGenSpec
control = ByteString
-> CalculationRate
-> [InputSpec]
-> [OutputSpec]
-> Int16
-> UGenSpec
UGenSpec
      (String -> ByteString
UTF8.fromString String
"Control")
      CalculationRate
KR
      []
      (Int -> OutputSpec -> [OutputSpec]
forall a. Int -> a -> [a]
replicate (([a] -> Int
forall {a}. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length::[a]->Int) [(ByteString, Float)]
params) (CalculationRate -> OutputSpec
OutputSpec CalculationRate
KR))
      Int16
0

   rest :: [UGenSpec]
rest = ((Int, UGen) -> UGenSpec) -> [(Int, UGen)] -> [UGenSpec]
forall a b. (a -> b) -> [a] -> [b]
map (Int, UGen) -> UGenSpec
makeSpec [(Int, UGen)]
ugens

   makeSpec :: (Int, UGen) -> UGenSpec
   makeSpec :: (Int, UGen) -> UGenSpec
makeSpec (Int
_, UGen UGenName
name CalculationRate
calcRate [Signal]
ins Int
numOuts) =
      let (ByteString
theName, Int16
specialIndex) = case UGenName
name of
             UGName_S ByteString
s -> (ByteString
s, Int16
0)
             UGName_U UnaryOp
uop -> (String -> ByteString
UTF8.fromString String
"UnaryOpUGen", UnaryOp -> Int16
uOpToSpecialI UnaryOp
uop)
             UGName_B BinaryOp
biop -> (String -> ByteString
UTF8.fromString String
"BinaryOpUGen", BinaryOp -> Int16
biOpToSpecialI BinaryOp
biop)
      in ByteString
-> CalculationRate
-> [InputSpec]
-> [OutputSpec]
-> Int16
-> UGenSpec
UGenSpec
            ByteString
theName
            CalculationRate
calcRate
            ((((Signal -> InputSpec) -> [Signal] -> [InputSpec])
-> [Signal] -> (Signal -> InputSpec) -> [InputSpec]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Signal -> InputSpec) -> [Signal] -> [InputSpec]
forall a b. (a -> b) -> [a] -> [b]
map) [Signal]
ins ((Signal -> InputSpec) -> [InputSpec])
-> (Signal -> InputSpec) -> [InputSpec]
forall a b. (a -> b) -> a -> b
$ \case
                Constant Float
x -> Int32 -> InputSpec
InputSpec_Constant (Int32 -> InputSpec) -> Int32 -> InputSpec
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$
                   Float -> [Float] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Float
x ([Float] -> Maybe Int) -> [Float] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [(Int, UGen)] -> [Float]
gatherConstants [(Int, UGen)]
ugens
                UGOut Int
ugenId Int32
outputNum ->
                   let inputPosition :: a
inputPosition =
                           -- If there are any params, there's a "Control" in
                           -- the 0th position:
                          Int -> a
forall a. Enum a => Int -> a
toEnum Int
ugenId a -> a -> a
forall a. Num a => a -> a -> a
+ case [(ByteString, Float)]
params of { [] -> a
0 ; [(ByteString, Float)]
_ -> a
1 }
                   in Int32 -> Int32 -> InputSpec
InputSpec_UGen Int32
forall {a}. (Num a, Enum a) => a
inputPosition Int32
outputNum
                Param ByteString
s -> Int32 -> Int32 -> InputSpec
InputSpec_UGen Int32
0 ([(ByteString, Float)] -> ByteString -> Int32
forall a. Eq a => [(ByteString, a)] -> ByteString -> Int32
indexOfName [(ByteString, Float)]
params ByteString
s)
                )
            (Int -> OutputSpec -> [OutputSpec]
forall a. Int -> a -> [a]
replicate Int
numOuts (CalculationRate -> OutputSpec
OutputSpec CalculationRate
calcRate))
            Int16
specialIndex

 -- invariant: strings are unique:
indexOfName :: (Eq a) => [(ByteString, a)] -> ByteString -> Int32
-- In the future: add levens(t|h)ein distance "did you mean?:"
indexOfName :: forall a. Eq a => [(ByteString, a)] -> ByteString -> Int32
indexOfName [(ByteString, a)]
haystack ByteString
key =
   let foo :: (ByteString, a)
foo = case ((ByteString, a) -> Bool)
-> [(ByteString, a)] -> Maybe (ByteString, a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==ByteString
key) (ByteString -> Bool)
-> ((ByteString, a) -> ByteString) -> (ByteString, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, a) -> ByteString
forall a b. (a, b) -> a
fst) [(ByteString, a)]
haystack of
         Maybe (ByteString, a)
Nothing -> String -> (ByteString, a)
forall a. HasCallStack => String -> a
error (String -> (ByteString, a)) -> String -> (ByteString, a)
forall a b. (a -> b) -> a -> b
$ String
"missing param: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
key
         Just (ByteString, a)
x -> (ByteString, a)
x
   in Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ (((ByteString, a) -> [(ByteString, a)] -> Maybe Int)
-> [(ByteString, a)] -> (ByteString, a) -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ByteString, a) -> [(ByteString, a)] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex) [(ByteString, a)]
haystack ((ByteString, a) -> Maybe Int) -> (ByteString, a) -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (ByteString, a)
foo

getFreshUGenGraphId :: SDBody' args Int
getFreshUGenGraphId :: forall (args :: [Symbol]). SDBody' args Int
getFreshUGenGraphId = do
   ([Int]
ids, SynthDef args
synthDef, VarSet args
argList) <- StateT
  ([Int], SynthDef args, VarSet args)
  Identity
  ([Int], SynthDef args, VarSet args)
forall s (m :: * -> *). MonadState s m => m s
get
   let (Int
i:[Int]
ds) = case [Int]
ids of
          [] -> String -> [Int]
forall a. HasCallStack => String -> a
error String
"You got to the end of an infinite list!"
          [Int]
_ -> [Int]
ids
   ([Int], SynthDef args, VarSet args)
-> StateT ([Int], SynthDef args, VarSet args) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([Int]
ds, SynthDef args
synthDef, VarSet args
argList)
   Int -> SDBody' args Int
forall a.
a -> StateT ([Int], SynthDef args, VarSet args) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i

-- | Alias for 'addMonoUGen'
addUGen :: UGen -> SDBody' args Signal
addUGen :: forall (args :: [Symbol]). UGen -> SDBody' args Signal
addUGen = UGen -> SDBody' args Signal
forall (args :: [Symbol]). UGen -> SDBody' args Signal
addMonoUGen

-- | Add a unit generator with one output
addMonoUGen :: UGen -> SDBody' args Signal
addMonoUGen :: forall (args :: [Symbol]). UGen -> SDBody' args Signal
addMonoUGen UGen
ugen = UGen -> SDBody' args [Signal]
forall (args :: [Symbol]). UGen -> SDBody' args [Signal]
addPolyUGen UGen
ugen SDBody' args [Signal]
-> ([Signal]
    -> StateT ([Int], SynthDef args, VarSet args) Identity Signal)
-> StateT ([Int], SynthDef args, VarSet args) Identity Signal
forall a b.
StateT ([Int], SynthDef args, VarSet args) Identity a
-> (a -> StateT ([Int], SynthDef args, VarSet args) Identity b)
-> StateT ([Int], SynthDef args, VarSet args) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
   [Signal
x] -> Signal
-> StateT ([Int], SynthDef args, VarSet args) Identity Signal
forall a.
a -> StateT ([Int], SynthDef args, VarSet args) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Signal
x
   [Signal]
foo -> String
-> StateT ([Int], SynthDef args, VarSet args) Identity Signal
forall a. HasCallStack => String -> a
error (String
 -> StateT ([Int], SynthDef args, VarSet args) Identity Signal)
-> String
-> StateT ([Int], SynthDef args, VarSet args) Identity Signal
forall a b. (a -> b) -> a -> b
$ String
"that ugen's not mono!: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>   UGen -> String
forall a. Show a => a -> String
show UGen
ugen String -> String -> String
forall a. Semigroup a => a -> a -> a
<>  [Signal] -> String
forall a. Show a => a -> String
show [Signal]
foo

-- | Polyphonic -- returns a list of 'Signal's.
--   In the future this might be a tuple instead of a list
addPolyUGen :: UGen -> SDBody' args [Signal]
addPolyUGen :: forall (args :: [Symbol]). UGen -> SDBody' args [Signal]
addPolyUGen UGen
ugen = UGen -> SDBody' args [Signal]
forall (args :: [Symbol]). UGen -> SDBody' args [Signal]
addPolyUGen' (UGen -> SDBody' args [Signal]) -> UGen -> SDBody' args [Signal]
forall a b. (a -> b) -> a -> b
$ UGen
ugen

addPolyUGen' :: UGen -> SDBody' args [Signal]
addPolyUGen' :: forall (args :: [Symbol]). UGen -> SDBody' args [Signal]
addPolyUGen' UGen
ugen = do
   Int
anId <- SDBody' args Int
forall (args :: [Symbol]). SDBody' args Int
getFreshUGenGraphId
   (([Int], SynthDef args, VarSet args)
 -> ([Int], SynthDef args, VarSet args))
-> StateT ([Int], SynthDef args, VarSet args) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((([Int], SynthDef args, VarSet args)
  -> ([Int], SynthDef args, VarSet args))
 -> StateT ([Int], SynthDef args, VarSet args) Identity ())
-> ((SynthDef args -> SynthDef args)
    -> ([Int], SynthDef args, VarSet args)
    -> ([Int], SynthDef args, VarSet args))
-> (SynthDef args -> SynthDef args)
-> StateT ([Int], SynthDef args, VarSet args) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\SynthDef args -> SynthDef args
f ([Int]
a,SynthDef args
b,VarSet args
c)->([Int]
a,SynthDef args -> SynthDef args
f SynthDef args
b,VarSet args
c)) ((SynthDef args -> SynthDef args)
 -> StateT ([Int], SynthDef args, VarSet args) Identity ())
-> (SynthDef args -> SynthDef args)
-> StateT ([Int], SynthDef args, VarSet args) Identity ()
forall a b. (a -> b) -> a -> b
$ \SynthDef args
synthDef -> SynthDef args
synthDef { _sdUGens =
      Map.unionWith (\UGen
_ -> String -> UGen -> UGen
forall a. HasCallStack => String -> a
error String
"dammit keying broken") (_sdUGens synthDef) $
         Map.singleton anId ugen
      }
   [Signal] -> SDBody' args [Signal]
forall a.
a -> StateT ([Int], SynthDef args, VarSet args) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Signal] -> SDBody' args [Signal])
-> [Signal] -> SDBody' args [Signal]
forall a b. (a -> b) -> a -> b
$ (Int32 -> Signal) -> [Int32] -> [Signal]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int32 -> Signal
UGOut Int
anId) [Int32
0.. Int -> Int32
forall a. Enum a => Int -> a
toEnum (UGen -> Int
_ugenNumOuts UGen
ugen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]

-- In all (as of this writing) other cases, UGens are 'write only': you can
--   just add them, not edit or remove them. However! SC has a special case
--   where if you create a LocalBuf, you need to have previously a
--   'MaxLocalBufs' which says how many LocalBufs there are in the whole graph.
--   So for that, we update our 'MaxLocalBufs'
addOrIncrementMaxLocalBufs :: SDBody' args Signal
addOrIncrementMaxLocalBufs :: forall (args :: [Symbol]). SDBody' args Signal
addOrIncrementMaxLocalBufs = do
   ([Int]
ids, SynthDef args
synthDef, VarSet args
argList) <- StateT
  ([Int], SynthDef args, VarSet args)
  Identity
  ([Int], SynthDef args, VarSet args)
forall s (m :: * -> *). MonadState s m => m s
get
   case Map Int UGen -> [(Int, UGen)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Int UGen -> [(Int, UGen)]) -> Map Int UGen -> [(Int, UGen)]
forall a b. (a -> b) -> a -> b
$ (UGen -> Bool) -> Map Int UGen -> Map Int UGen
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter UGen -> Bool
isMLB (Map Int UGen -> Map Int UGen) -> Map Int UGen -> Map Int UGen
forall a b. (a -> b) -> a -> b
$ SynthDef args -> Map Int UGen
forall (args :: [Symbol]). SynthDef args -> Map Int UGen
_sdUGens SynthDef args
synthDef of
      [] -> UGen -> SDBody' args Signal
forall (args :: [Symbol]). UGen -> SDBody' args Signal
addMonoUGen (UGen -> SDBody' args Signal) -> UGen -> SDBody' args Signal
forall a b. (a -> b) -> a -> b
$ UGenName -> CalculationRate -> [Signal] -> Int -> UGen
UGen (ByteString -> UGenName
UGName_S ByteString
"MaxLocalBufs") CalculationRate
IR [Float -> Signal
Constant Float
1] Int
1
      [(Int
ugIndex,     UGen (UGName_S ByteString
"MaxLocalBufs") CalculationRate
IR [Constant Float
numPreviously]      Int
1)] -> do
         let newUG :: UGen
newUG = UGenName -> CalculationRate -> [Signal] -> Int -> UGen
UGen (ByteString -> UGenName
UGName_S ByteString
"MaxLocalBufs") CalculationRate
IR [Float -> Signal
Constant (Float
numPreviously Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
1)] Int
1
             newSD :: SynthDef args
newSD = SynthDef args
synthDef { _sdUGens = Map.insert ugIndex newUG $ _sdUGens synthDef }
         ([Int], SynthDef args, VarSet args)
-> StateT ([Int], SynthDef args, VarSet args) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (([Int], SynthDef args, VarSet args)
 -> StateT ([Int], SynthDef args, VarSet args) Identity ())
-> ([Int], SynthDef args, VarSet args)
-> StateT ([Int], SynthDef args, VarSet args) Identity ()
forall a b. (a -> b) -> a -> b
$ ([Int]
ids, SynthDef args
forall {args :: [Symbol]}. SynthDef args
newSD, VarSet args
argList)
         Signal -> SDBody' args Signal
forall a.
a -> StateT ([Int], SynthDef args, VarSet args) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Signal -> SDBody' args Signal) -> Signal -> SDBody' args Signal
forall a b. (a -> b) -> a -> b
$ Int -> Int32 -> Signal
UGOut Int
ugIndex Int32
0
      [(Int, UGen)
e] -> String -> SDBody' args Signal
forall a. HasCallStack => String -> a
error (String -> SDBody' args Signal) -> String -> SDBody' args Signal
forall a b. (a -> b) -> a -> b
$ String
"Incorrectly constructed MLB?: "String -> String -> String
forall a. [a] -> [a] -> [a]
++(Int, UGen) -> String
forall a. Show a => a -> String
show (Int, UGen)
e
      [(Int, UGen)]
es -> String -> SDBody' args Signal
forall a. HasCallStack => String -> a
error (String -> SDBody' args Signal) -> String -> SDBody' args Signal
forall a b. (a -> b) -> a -> b
$ String
"Multiple MLB?: "String -> String -> String
forall a. [a] -> [a] -> [a]
++[(Int, UGen)] -> String
forall a. Show a => a -> String
show [(Int, UGen)]
es
 where
   isMLB :: UGen -> Bool
isMLB = \case
      UGen (UGName_S ByteString
"MaxLocalBufs") CalculationRate
_ [Signal]
_ Int
_ -> Bool
True
      UGen
_ -> Bool
False

-- | Define a Synth Definition
sd :: VarList argList => argList -> SDBody' (InnerVars argList) [Signal] -> SynthDef (InnerVars argList)
sd :: forall argList.
VarList argList =>
argList
-> SDBody' (InnerVars argList) [Signal]
-> SynthDef (InnerVars argList)
sd argList
params SDBody' (InnerVars argList) [Signal]
theState =
   SDName
-> argList
-> SDBody' (InnerVars argList) [Signal]
-> SynthDef (InnerVars argList)
forall argList.
VarList argList =>
SDName
-> argList
-> SDBody' (InnerVars argList) [Signal]
-> SynthDef (InnerVars argList)
makeSynthDef SDName
SDName_Hash argList
params SDBody' (InnerVars argList) [Signal]
theState

-- | Define a Synth Definition and give it a name you can refer to from e.g. sclang
sdNamed :: VarList argList => String -> argList -> SDBody' (InnerVars argList) [Signal] -> SynthDef (InnerVars argList)
sdNamed :: forall argList.
VarList argList =>
String
-> argList
-> SDBody' (InnerVars argList) [Signal]
-> SynthDef (InnerVars argList)
sdNamed String
name argList
params SDBody' (InnerVars argList) [Signal]
theState =
   SDName
-> argList
-> SDBody' (InnerVars argList) [Signal]
-> SynthDef (InnerVars argList)
forall argList.
VarList argList =>
SDName
-> argList
-> SDBody' (InnerVars argList) [Signal]
-> SynthDef (InnerVars argList)
makeSynthDef (ByteString -> SDName
SDName_Named (ByteString -> SDName) -> ByteString -> SDName
forall a b. (a -> b) -> a -> b
$ String -> ByteString
UTF8.fromString String
name) argList
params SDBody' (InnerVars argList) [Signal]
theState

makeSynthDef :: VarList argList => SDName -> argList -> SDBody' (InnerVars argList) [Signal] -> SynthDef (InnerVars argList)
makeSynthDef :: forall argList.
VarList argList =>
SDName
-> argList
-> SDBody' (InnerVars argList) [Signal]
-> SynthDef (InnerVars argList)
makeSynthDef SDName
name argList
params SDBody' (InnerVars argList) [Signal]
theState =
   SynthDef (InnerVars argList)
b
 where
   paramList :: [(String, Float)]
   ([(String, Float)]
paramList, VarSet (InnerVars argList)
argSet) = argList -> ([(String, Float)], VarSet (InnerVars argList))
forall from. VarList from => from -> TypedVarList (InnerVars from)
makeTypedVarList argList
params

   sdBeforeBody :: SynthDef args
sdBeforeBody = SDName -> [(ByteString, Float)] -> Map Int UGen -> SynthDef args
forall (args :: [Symbol]).
SDName -> [(ByteString, Float)] -> Map Int UGen -> SynthDef args
SynthDef SDName
name [ (String -> ByteString
UTF8.fromString String
k, Float
v) | (String
k, Float
v) <- [(String, Float)]
paramList ] Map Int UGen
forall k a. Map k a
Map.empty
   ([Int]
_,SynthDef (InnerVars argList)
b,VarSet (InnerVars argList)
_) = SDBody' (InnerVars argList) [Signal]
-> ([Int], SynthDef (InnerVars argList),
    VarSet (InnerVars argList))
-> ([Int], SynthDef (InnerVars argList),
    VarSet (InnerVars argList))
forall s a. State s a -> s -> s
execState SDBody' (InnerVars argList) [Signal]
theState (([Int], SynthDef (InnerVars argList), VarSet (InnerVars argList))
 -> ([Int], SynthDef (InnerVars argList),
     VarSet (InnerVars argList)))
-> ([Int], SynthDef (InnerVars argList),
    VarSet (InnerVars argList))
-> ([Int], SynthDef (InnerVars argList),
    VarSet (InnerVars argList))
forall a b. (a -> b) -> a -> b
$
      ({- id supply: -} [Int
0 :: Int ..], SynthDef (InnerVars argList)
forall {args :: [Symbol]}. SynthDef args
sdBeforeBody, VarSet (InnerVars argList)
argSet)

-- | Set the calculation rate of a UGen
-- 
--   e.g.
-- 
--   @
-- play $ do
--    s0 <- 1 ~+ (lfSaw (freq_ 1) ? KR)
--    s1 <- 0.1 ~* lfSaw (freq_ $ 220 ~* s0)
--    out 0 [s1, s1]
-- @
-- 
--   Mnemonic: \"?\" is like thinking
-- 
--   In the future, the representation of calculation rates may change
(?) :: SDBody' args Signal -> CalculationRate -> SDBody' args Signal
? :: forall (args :: [Symbol]).
SDBody' args Signal -> CalculationRate -> SDBody' args Signal
(?) SDBody' args Signal
i CalculationRate
calcRate = do
   Signal
i' <- SDBody' args Signal
i
   case Signal
i' of
      UGOut Int
ugId Int32
_o -> (([Int], SynthDef args, VarSet args)
 -> ([Int], SynthDef args, VarSet args))
-> StateT ([Int], SynthDef args, VarSet args) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((([Int], SynthDef args, VarSet args)
  -> ([Int], SynthDef args, VarSet args))
 -> StateT ([Int], SynthDef args, VarSet args) Identity ())
-> (([Int], SynthDef args, VarSet args)
    -> ([Int], SynthDef args, VarSet args))
-> StateT ([Int], SynthDef args, VarSet args) Identity ()
forall a b. (a -> b) -> a -> b
$ (\SynthDef args -> SynthDef args
f ([Int]
a,SynthDef args
b,VarSet args
c)->([Int]
a,SynthDef args -> SynthDef args
f SynthDef args
b,VarSet args
c)) ((SynthDef args -> SynthDef args)
 -> ([Int], SynthDef args, VarSet args)
 -> ([Int], SynthDef args, VarSet args))
-> (SynthDef args -> SynthDef args)
-> ([Int], SynthDef args, VarSet args)
-> ([Int], SynthDef args, VarSet args)
forall a b. (a -> b) -> a -> b
$ \SynthDef args
synthDef ->
         let ugs :: Map Int UGen
ugs = SynthDef args -> Map Int UGen
forall (args :: [Symbol]). SynthDef args -> Map Int UGen
_sdUGens SynthDef args
synthDef
             updatedUGens :: Map Int UGen
             updatedUGens :: Map Int UGen
updatedUGens = case Int -> Map Int UGen -> Maybe UGen
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
ugId Map Int UGen
ugs of
                Maybe UGen
Nothing -> String -> Map Int UGen
forall a. HasCallStack => String -> a
error String
"ugen id not found"
                Just UGen{} ->
                   (UGen -> UGen) -> Int -> Map Int UGen -> Map Int UGen
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\UGen
ug -> UGen
ug { _ugenCalculationRate = calcRate }) Int
ugId Map Int UGen
ugs
         in SynthDef args
synthDef { _sdUGens = updatedUGens }
      Signal
_ -> () -> StateT ([Int], SynthDef args, VarSet args) Identity ()
forall a.
a -> StateT ([Int], SynthDef args, VarSet args) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   Signal -> SDBody' args Signal
forall a.
a -> StateT ([Int], SynthDef args, VarSet args) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Signal
i'

getCalcRate :: Signal -> SDBody' args CalculationRate
getCalcRate :: forall (args :: [Symbol]). Signal -> SDBody' args CalculationRate
getCalcRate = \case
   Constant Float
_ -> CalculationRate -> SDBody' args CalculationRate
forall a.
a -> StateT ([Int], SynthDef args, VarSet args) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CalculationRate
IR
   Param ByteString
_ -> CalculationRate -> SDBody' args CalculationRate
forall a.
a -> StateT ([Int], SynthDef args, VarSet args) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CalculationRate
KR
   UGOut Int
theUG Int32
_ -> do
      -- Note: this assumes updates to the ugen graph are only appends
      -- (so don't break that invariant if you build your own graph by hand!):
      ([Int]
_, SynthDef args
ugenGraph, VarSet args
_) <- StateT
  ([Int], SynthDef args, VarSet args)
  Identity
  ([Int], SynthDef args, VarSet args)
forall s (m :: * -> *). MonadState s m => m s
get
      case Int -> Map Int UGen -> Maybe UGen
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
theUG (SynthDef args -> Map Int UGen
forall (args :: [Symbol]). SynthDef args -> Map Int UGen
_sdUGens SynthDef args
ugenGraph) of
         Just UGen
ug -> CalculationRate -> SDBody' args CalculationRate
forall a.
a -> StateT ([Int], SynthDef args, VarSet args) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (CalculationRate -> SDBody' args CalculationRate)
-> CalculationRate -> SDBody' args CalculationRate
forall a b. (a -> b) -> a -> b
$ UGen -> CalculationRate
_ugenCalculationRate UGen
ug
         Maybe UGen
Nothing -> String -> SDBody' args CalculationRate
forall a. HasCallStack => String -> a
error String
"that output isn't in the graph!"


-- | Like 'Vivid.SCServer.shrinkSynthArgs' but for 'SynthDef's
shrinkSDArgs :: Subset new old => SynthDef old -> SynthDef new
shrinkSDArgs :: forall (new :: [Symbol]) (old :: [Symbol]).
Subset new old =>
SynthDef old -> SynthDef new
shrinkSDArgs (SynthDef SDName
a [(ByteString, Float)]
b Map Int UGen
c) = SDName -> [(ByteString, Float)] -> Map Int UGen -> SynthDef new
forall (args :: [Symbol]).
SDName -> [(ByteString, Float)] -> Map Int UGen -> SynthDef args
SynthDef SDName
a [(ByteString, Float)]
b Map Int UGen
c



encodeSD :: SynthDef a -> ByteString
encodeSD :: forall (a :: [Symbol]). SynthDef a -> ByteString
encodeSD =
   SynthDefFile -> ByteString
encodeSynthDefFile (SynthDefFile -> ByteString)
-> (SynthDef a -> SynthDefFile) -> SynthDef a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LiteralSynthDef] -> SynthDefFile
SynthDefFile ([LiteralSynthDef] -> SynthDefFile)
-> (SynthDef a -> [LiteralSynthDef]) -> SynthDef a -> SynthDefFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LiteralSynthDef -> [LiteralSynthDef] -> [LiteralSynthDef]
forall a. a -> [a] -> [a]
:[]) (LiteralSynthDef -> [LiteralSynthDef])
-> (SynthDef a -> LiteralSynthDef)
-> SynthDef a
-> [LiteralSynthDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynthDef a -> LiteralSynthDef
forall (a :: [Symbol]). SynthDef a -> LiteralSynthDef
sdToLiteral

-- | This is the hash of the UGen graph and params, but not the name!
--   So (re)naming a SynthDef will not change its hash.
instance Hashable (SynthDef a) where
   hashWithSalt :: Int -> SynthDef a -> Int
hashWithSalt Int
salt (SynthDef SDName
_name [(ByteString, Float)]
params Map Int UGen
ugens) =
      Int -> ByteString -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (ByteString -> Int)
-> (SynthDef Any -> ByteString) -> SynthDef Any -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SynthDef Any -> ByteString
forall (a :: [Symbol]). SynthDef a -> ByteString
encodeSD (SynthDef Any -> Int) -> SynthDef Any -> Int
forall a b. (a -> b) -> a -> b
$
         SDName -> [(ByteString, Float)] -> Map Int UGen -> SynthDef Any
forall (args :: [Symbol]).
SDName -> [(ByteString, Float)] -> Map Int UGen -> SynthDef args
SynthDef (ByteString -> SDName
SDName_Named ByteString
"VIVID FTW") [(ByteString, Float)]
params Map Int UGen
ugens