packages feed

vivid (empty) → 0.1.0.0

raw patch · 12 files changed

+2007/−0 lines, 12 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, containers, deepseq, hashable, mtl, network, split, stm

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Vivid.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_HADDOCK show-extensions #-}++-- | For an intro to all this, check out <http://amindfv.com/vivid> or the "Vivid.SynthDef" module++module Vivid (+     sleep+   , module Vivid.SynthDef+   , module Vivid.UGens+   , module Vivid.SCServer+   ) where++import Vivid.SCServer+import Vivid.SynthDef+import Vivid.UGens++import Control.Concurrent (threadDelay)++sleep :: Float -> IO ()+sleep t = threadDelay . fromEnum $ t * 1e6
+ Vivid/OSC.hs view
@@ -0,0 +1,145 @@+-- | __You probably don't need to use this directly__+-- +--   Representation of Open Sound Control data++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoRebindableSyntax #-}++module Vivid.OSC (+     OSC(..)+   , OSCDatum(..)++   , encodeOSC+   , decodeOSC+   ) where++import Vivid.OSC.Util++import Control.DeepSeq+import Data.Binary (encode, decode)+import qualified Data.ByteString as BS+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BSL+import Data.Int (Int32) -- , Int16, Int8)+import Data.Monoid++-- | An OSC message, e.g.+-- +--   > OSC "/n_free" [OSC_I 42]+data OSC+   = OSC ByteString [OSCDatum]+ deriving (Show, Read, Eq)++data OSCDatum+   = OSC_I Int32+   | OSC_S ByteString+   | OSC_F Float+{-+   | OSC_I8 Int8+   | OSC_I16 Int16+-}+   | OSC_B ByteString+ deriving (Show, Read, Eq)++-- formerly known as 'someShit':+encodeOSC :: OSC -> ByteString+encodeOSC (OSC url args) = BSL.toStrict $ BSL.concat $ [+    encodeDatum (OSC_S url)+   ,encodeDatum (OSC_S ("," <> BS.concat (map toTypeChar args)))+   ] <> map encodeDatum args+  where+    toTypeChar (OSC_I _) = "i"+    toTypeChar (OSC_S _) = "s"+    toTypeChar (OSC_F _) = "f"+    toTypeChar (OSC_B _) = "b"++encodeDatum :: OSCDatum -> BSL.ByteString+encodeDatum (OSC_I i) = encode i+encodeDatum (OSC_S s) = BSL.fromStrict $+   s <> BS.replicate (align (BS.length s + 1) + 1) 0+encodeDatum (OSC_F f) = (encode . floatToWord) f+encodeDatum (OSC_B b) = mconcat [+    -- 4 bytes which describe the size of the blob:+     encode (fromIntegral (BS.length b) :: Int32)+    -- the blob itself:+   , BSL.fromStrict b+    -- padding:+   , BSL.fromStrict (BS8.pack (replicate  (align (BS.length b)) '\NUL'))+   ]++decodeDatumWithPadding :: Char -> ByteString -> OSCDatum+decodeDatumWithPadding 'i' b =+   OSC_I (decode $ BSL.fromStrict b)+decodeDatumWithPadding 'f' b =+   OSC_F (wordToFloat . decode $ BSL.fromStrict b)+decodeDatumWithPadding 's' b =+   OSC_S  $ BS.take (numBytesWithoutPadding 's' b)  b+decodeDatumWithPadding 'b' b =+   OSC_B $ BS.take (numBytesWithoutPadding 'b' b) $ BS.drop 4 b+decodeDatumWithPadding c b =+   error $ "unknown character " <> show c <> ": " <> show b++numBytesWithoutPadding :: Char -> ByteString -> Int+numBytesWithoutPadding 'i' _ = 4+numBytesWithoutPadding 'f' _ = 4+numBytesWithoutPadding 's' b = case BS.elemIndex 0 $ b of+   Just x -> fromIntegral x+   Nothing -> error $ "weirdness on " <> show b+numBytesWithoutPadding 'b' b = fromIntegral $+   (decode $ BSL.fromStrict $ BS.take 4 b :: Int32)+numBytesWithoutPadding c b =+   error $ "unknown character " <> show c <> ": " <> show b++numBytesWithPadding :: Char -> ByteString -> Int+numBytesWithPadding 'i' _ = 4+numBytesWithPadding 'f' _ = 4+numBytesWithPadding 's' b =+   let n = (numBytesWithoutPadding 's' b) + 1+   in n + (align n)+numBytesWithPadding 'b' b =+   let n = numBytesWithoutPadding 'b' b+   in n + align n + 4+numBytesWithPadding c b =+   error $ "unknown character " <> show c <> ": " <> show b++decodeOSCData :: [Char] -> ByteString -> [OSCDatum]+decodeOSCData [] "" = []+decodeOSCData [] leftover = error $ "leftover bytes: " <> show leftover+decodeOSCData (t:ypes) blob =+   (:) datum+       (decodeOSCData ypes (BS.drop (numBytesWithPadding t blob) blob))+ where+   datum = decodeDatumWithPadding t thisBlob+   thisBlob = BS.take (numBytesWithPadding t blob) blob++decodeOSC :: ByteString -> OSC+decodeOSC b =+   let sizeOfURL = numBytesWithoutPadding 's' b+       storageOfURL = numBytesWithPadding 's' b++       url = BS.take sizeOfURL b++       -- typeDesc is like ",issif"+       sizeOfTypeDesc = numBytesWithoutPadding 's' $ BS.drop storageOfURL b+       storageOfTypeDesc = numBytesWithPadding 's' $ BS.drop storageOfURL b+       (',':typeDesc) = BS8.unpack $ BS.take sizeOfTypeDesc $+          BS.drop storageOfURL b++       rest = BS.drop (storageOfURL + storageOfTypeDesc) $ b++   in OSC url $ decodeOSCData typeDesc rest++instance NFData OSCDatum where+   rnf (OSC_I x) = rnf x+   rnf (OSC_F x) = rnf x+   rnf (OSC_S x) = rnf x+{-+   rnf (OSC_I8 x) = rnf x+   rnf (OSC_I16 x) = rnf x+-}+   rnf (OSC_B x) = rnf x
+ Vivid/OSC/Util.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE NoRebindableSyntax #-}++module Vivid.OSC.Util (+     align+   , floatToWord+   , wordToFloat+   ) where++import Data.Bits ((.&.), complement, Bits)+import qualified Foreign as F+import System.IO.Unsafe (unsafePerformIO)++-- from hosc:+align :: (Num i,Bits i) => i -> i+{-# INLINE align #-}+align n = ((n + 3) .&. complement 3) - n+++-- from data-binary-ieee754:+floatToWord :: Float -> F.Word32+floatToWord = coercionThing++wordToFloat :: F.Word32 -> Float+wordToFloat = coercionThing++coercionThing :: (F.Storable a, F.Storable b) => a -> b+coercionThing x = unsafePerformIO $ F.alloca $ \buf -> do+   F.poke (F.castPtr buf) x+   F.peek buf
+ Vivid/SCServer.hs view
@@ -0,0 +1,284 @@+{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE NoRebindableSyntax #-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Library for interacting with the SuperCollider server.+-- +--   You don't need to use much of this day-to-day+-- +--   There's a toplevel 'scServerState' that stores the current state of the SC server+module Vivid.SCServer (+     call+   , callBS+   , quit+   , cmdPeriod++   , NodeId(..)+   , newNodeId++   , BufferId(..)+   , newBufferId+   , setMaxBufferIds+   , makeBuffer+   , makeBufferFromFile+   , saveBuffer++   , createSCServerConnection+   , callAndWaitForDone++   , SCServerState(..)+   , scServerState+   ) where++import Vivid.OSC+import Vivid.SynthDef.Types++import Network.Socket (SocketType(Datagram), defaultProtocol, socket, AddrInfo(..), getAddrInfo, Socket, HostName, ServiceName, connect)+import Network.Socket.ByteString++import Control.Concurrent (threadDelay)+--import qualified Data.ByteString as B hiding (find, elem)+import Data.ByteString (ByteString)+import Data.Int (Int32)+import Control.Concurrent.STM as STM++{-+import qualified Data.Map as Map+import Data.Map (Map)+-}+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.ByteString.Char8 as BS8++-- We use this only for "the unsafePerformIO hack"+-- (https://wiki.haskell.org/Top_level_mutable_state) so that functions can+-- refer to the state without being passed the state explicitly. This should+-- still be safe:+import System.IO.Unsafe (unsafePerformIO)++-- SETTINGS:+defaultSCServerPort :: String+defaultSCServerPort = "57110"+-- defaultSCLangPort   = "57120"+++{-# NOINLINE scServerState #-}+scServerState :: SCServerState+-- see the above note about this use of unsafePerformIO:+scServerState = unsafePerformIO makeEmptySCServerState++newtype NodeId+      = NodeId { unNodeId :: Int32 }+   deriving (Show, Eq)++newtype BufferId+      = BufferId { unBufferId :: Int32 }+   deriving (Show, Eq)++data SCServerState+   = SCServerState+     { scServer_socket :: !(TVar (Maybe Socket))+     , scServer_availableBufferIds :: !(TVar [BufferId])+     , scServer_maxBufIds :: !(TVar Int32)+     , scServer_availableNodeIds :: !(TVar [NodeId])+     , scServer_availableSyncIds :: !(TVar [SyncId])+     , scServer_definedSDs :: !(TVar (Set (SDName, Int))) -- Int is the hash+     }++-- | Stop the SuperCollider server+quit :: IO ()+quit = call $ OSC "/quit" []++-- | __You usually don't need to call this function__+-- +--   Use this if to connect on a non-default port or to a server not at localhost+-- +--   Otherwise the connection is created when it's needed.+--   You can also use this to explicitly create the connection, so the+--   computation is done upfront+-- +--   The 'HostName' is the ip address or "localhost". The 'ServiceName' is the port+createSCServerConnection :: HostName -> ServiceName -> IO Socket+createSCServerConnection hostName port = do+   let !_ = scServerState+   readTVarIO (scServer_socket scServerState) >>= \case+      Nothing -> do+         s <- connectToSCServer hostName port+         (atomically . (writeTVar $ scServer_socket scServerState) . Just) s+         return s+      Just _ -> error "Too late -- connection already established. Disconnect first."++connectToSCServer :: HostName -> ServiceName -> IO Socket+connectToSCServer hostName port = do+   (serverAddr:_) <- getAddrInfo Nothing (Just hostName) (Just port)+   s <- socket (addrFamily serverAddr) Datagram defaultProtocol+   connect s (addrAddress serverAddr)+   _ <- send s $ encodeOSC $ OSC "/dumpOSC" [OSC_I 1]+   _ <- send s $ encodeOSC $ OSC "/g_new" [OSC_I 1, OSC_I 0, OSC_I 0]+   threadDelay $ fromEnum 1e3+   return s++getSCServerSocket :: IO Socket+getSCServerSocket = getSCServerSocket' scServerState++getSCServerSocket' :: SCServerState -> IO Socket+getSCServerSocket' scServerState' = do+   let !_ = scServerState'+   readTVarIO (scServer_socket scServerState') >>= \case+      Nothing -> do+         s <- connectToSCServer "localhost" defaultSCServerPort+         (atomically . (writeTVar $ scServer_socket scServerState') . Just) s+         return s+      Just s -> return s++makeEmptySCServerState :: IO SCServerState+makeEmptySCServerState = do+   sockTVar <- newTVarIO Nothing+   availBufIds <- newTVarIO $ drop 512 $ map BufferId $ cycle [0..]+   availNodeIds <- newTVarIO $ map NodeId [10000..] -- sclang starts at 2000+   maxBufIds <- newTVarIO 1024+   syncIds <- newTVarIO $ drop 10000 $ map SyncId $ cycle [0..]+   definedSDs <- newTVarIO $ Set.empty++   return $ SCServerState+          { scServer_socket = sockTVar+          , scServer_availableBufferIds = availBufIds+          , scServer_maxBufIds = maxBufIds+          , scServer_availableNodeIds = availNodeIds+          , scServer_availableSyncIds = syncIds+          , scServer_definedSDs = definedSDs+          }++-- | Send an 'OSC' message to the SuperCollider server+call :: OSC -> IO ()+call message = do+   let !_ = scServerState+   callBS (encodeOSC message)++-- | Async messages to the sc server get responded to with \"\/done\" -- so this calls those functions and waits for the \"\/done\" before continuing+callAndWaitForDone :: OSC -> IO ()+callAndWaitForDone message@(OSC _cmd _) = do+   s <- getSCServerSocket+   call message+   threadDelay $ fromEnum 1e4+   sid@(SyncId syncId) <- newSyncId+   call $ OSC "/sync" [OSC_I syncId]+   getDoneMessage s sid+ where+   getDoneMessage :: Socket -> SyncId -> IO ()+   getDoneMessage s sid@(SyncId syncId) = recvFrom s 1024 >>= \(msg, _) ->+      case decodeOSC msg of+         -- OSC "/done" [OSC_S cmdFinished] | cmd == cmdFinished -> return ()+         OSC "/synced" [OSC_I syncFinished] | syncFinished == syncId -> return ()+         _ -> getDoneMessage s sid++newtype SyncId+      = SyncId Int32+   deriving (Show, Read, Eq, Ord)++-- | Send a ByteString to the SuperCollider server.+--   You usually want to use 'call' instead. May be removed in future versions.+callBS :: ByteString -> IO ()+callBS message = do+   let !_ = scServerState++   sock <- getSCServerSocket++   _ <- send sock message+   return ()++{-+call' :: SCServerState -> OSC -> IO ()+call' scServerState' message = do+   let !_ = scServerState'++   sock <- getSCServerSocket' scServerState'++   _ <- send sock (encodeOSC message)+   return ()+-}++-- | Your \"emergency\" button. Run this and everything playing on the SC server+--   will be freed -- silence!+-- +--   Corresponds to the cmd-. \/ ctrl-.  key command in the SuperCollider IDE+cmdPeriod :: IO ()+cmdPeriod = do+   call $ OSC "/g_freeAll" [OSC_I 0]+   call $ OSC "/clearSched" []+   call $ OSC "/g_new" [OSC_I 1, OSC_I 0, OSC_I 0]++newBufferId :: IO BufferId+newBufferId = do+   maxBufIds <- readTVarIO (scServer_maxBufIds scServerState)+   BufferId nn <- getNextAvailable scServer_availableBufferIds+   return . BufferId $ nn `mod` maxBufIds++getNextAvailable :: (SCServerState -> TVar [a]) -> IO a+getNextAvailable getter = do+   let !_ = scServerState+   atomically $ do+      let avail = getter scServerState+      (n:rest) <- readTVar avail+      writeTVar avail rest+      return n++newNodeId :: IO NodeId+newNodeId =+   getNextAvailable scServer_availableNodeIds++newSyncId :: IO SyncId+newSyncId =+   getNextAvailable scServer_availableSyncIds++-- | If you've started the SC server with a non-default number of buffer ids,+--   (e.g. with the \"-b\" argument), you can reflect that here+-- +--   Note that the buffer ids start at 512, to not clash with any that+--   sclang has allocated+setMaxBufferIds :: Int32 -> IO ()+setMaxBufferIds newMax = atomically $+   writeTVar (scServer_maxBufIds scServerState) newMax++-- | Make an empty buffer+-- +--   The Int32 is the buffer length /in samples/. Multiply seconds by+--   the default sample rate of the server (usually 48000) to get the number+--   of samples+makeBuffer :: Int32 -> IO BufferId+makeBuffer bufferLength = do+   bufId@(BufferId bufIdInt) <- newBufferId+   call $ OSC "/b_alloc" [+       OSC_I bufIdInt+      ,OSC_I bufferLength+      ,OSC_I 1+      ,OSC_I 0+      ]+   return bufId++-- | Make a buffer and fill it with sound data from a file+makeBufferFromFile :: FilePath -> IO BufferId+makeBufferFromFile fPath = do+   bufId@(BufferId bufIdInt) <- newBufferId+   call $ OSC  "/b_allocRead" [+        OSC_I bufIdInt+      , OSC_S (BS8.pack fPath)+      , OSC_I 0+      , OSC_I (-1)+      ]+   return bufId++-- | Write a buffer to a file+saveBuffer :: BufferId -> FilePath -> IO ()+saveBuffer (BufferId theBufId) fPath =+      call $ OSC "/b_write" [+         OSC_I theBufId+        ,OSC_S (BS8.pack fPath)+        ,OSC_S "wav"+        ,OSC_S "float"+        ]
+ Vivid/SynthDef.hs view
@@ -0,0 +1,491 @@+-- | 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+--   'SDState' which lets you construct synthdefs like so:+-- +--   @+--   test :: SynthDef+--   test = 'sdNamed' \"testSynthDef\" [(\"note\", 0)] $ do+--      s <- 0.1 'Vivid.UGens.~*' 'Vivid.UGens.sinOsc' (Freq $ 'Vivid.UGens.midiCPS' \"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 "testSynthDef" [("note", 45)]+-- +--   Or, alternately:+-- +--   >>> s <- synth test [("note", 45)]+-- +--   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 [("note", 38)]+-- +--   Then you can free it (stop its playing) with+-- +--   >>> free s++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE NoRebindableSyntax #-}++-- {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Vivid.SynthDef (+  -- * Synth actions++    synth+  , set+  , free++  -- * Synth Definition Construction++  , SynthDef(..)+  , UGen(..)+  , addUGen+  , addMonoUGen+  , addPolyUGen+  , ToSig(..)+  , ToSigM(..)+  , Signal(..)+--  , SDState+  , encodeSD+  , defineSD+  , sd+  , sdNamed+  , sdPretty+  , (?)+  , play+  , cmdPeriod+  , DoneAction(..)+  , doneActionNum+  , sdLitPretty+  , HasSynthRef+  , sdToLiteral+  -- literalToSD++  , execState++  , getCalcRate++{-+  -- * Type-defaulting stuff+  , fromInteger+  , fromString+  , fromRational+  , int+  , integer+  , i8+  , i16+  , i32+  , string+-}++  -- * Built-in Unit Generator Operations++  , 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) -- , sortBy)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import qualified Data.Set as Set++-- once upon a time, we used -XRebindableSyntax to do Float defaulting instead of -XIncoherentInstances -- this is the machinery for that to work:+{-+import Prelude hiding (Num(..), fromRational) -- so i can do Float defaulting+import qualified Prelude as N+import qualified Data.String (fromString)++fromInteger :: Integer -> Float+fromInteger = realToFrac++fromRational :: Rational -> Float+fromRational = N.fromRational++int :: Float -> Int+int = fromEnum++integer :: Float -> Integer+integer = toInteger . fromEnum++i8 :: Float -> Int8+i8 = fromIntegral . int++i16 :: Float -> Int16+i16 = fromIntegral . int++i32 :: Float -> Int32+i32 = fromIntegral . int++fromString :: String -> ByteString+fromString = Data.String.fromString++string :: ByteString -> String+string = BS8.unpack+-}++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++--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 -> 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++{-+-- Write it if you wanna:+literalToSD :: Literal.SynthDef -> SD+literalToSD = undefined+-}++encodeSD :: SynthDef -> ByteString+encodeSD = encodeSynthDefFile . SynthDefFile . (:[]) . 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 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 -- if there are any params, there's a "Control" in+                                 -- the 0th position+                   in InputSpec_UGen inputPosition outputNum+                Param s -> InputSpec_UGen 0 (indexOfName params s)+                )+            (replicate numOuts (OutputSpec calcRate))+            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 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++-- | Send a synth definition to be loaded on the SC server+-- +--   Note that this is sort of optional -- if you don't call it, it'll be called the first time+--   you call 'synth' with the SynthDef+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++-- | Alias for 'addMonoUGen'+addUGen :: UGen -> SDState Signal+addUGen = addMonoUGen++-- | Add a unit generator with one output+addMonoUGen :: UGen -> SDState Signal+addMonoUGen ugen = addPolyUGen ugen >>= \case+   [x] -> return x+   foo -> error $ "that ugen's not mono!: " <> show ugen <> show foo++-- | Polyphonic -- returns a list of 'Signal's.+--   In the future this might be a tuple instead of a list+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)]++-- | Define a Synth Definition+sd :: [(String, Float)] -> SDState x -> SynthDef+sd params theState =+   makeSynthDef SDName_Hash params theState++-- | Define a Synth Definition and give it a name you can refer to from e.g. sclang+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 ({- id supply: -} [0 :: Int ..], theSD)+++-- | 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 definitely may change+(?) :: 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+   -- 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!):+   (_, ugenGraph) <- get+   case Map.lookup theUG (_sdUGens ugenGraph) of+      Just ug -> return $ _ugenCalculationRate ug+      Nothing -> error "that output isn't in the graph!"++-- | Given a UGen graph, just start playing it right away.+-- +--   e.g.+-- +--   > play $ do+--   >    s <- 0.2 ~* lpf (In whiteNoise) (Freq 440)+--   >    out 0 [s, s]+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"++                   _ -> ""+               ]+  ]++-- | Immediately stop a synth playing+-- +--   This can create a \"clipping\" artifact if the sound goes from a high+--   amplitude to 0 in an instant -- you can avoid that with e.g.+--   'Vivid.UGens.lag'+free :: NodeId -> IO ()+free (NodeId nodeId) =+   call $ OSC (BS8.pack "/n_free") [ OSC_I nodeId ]++-- | Set the given parameters of a running synth+-- +--   e.g.+-- +--   >>> let setTest = sd [("pan", 0.5)] $ out 0 =<< pan2 (In $ 0.1 ~* whiteNoise) (Pos "pan")+--   >>> s <- synth setTest []+--   >>> set s [("pan", -0.5)]+-- +--   Any parameters not referred to will be unaffected, and any you specify that don't exist+--   will be (silently) ignored+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++-- | Create a real live music-playing synth from a boring, dead SynthDef.+-- +--   If you haven't defined the SynthDef on the server, this will do it automatically+--   (Note that this may cause jitters in musical timing)+-- +--   Uses 'HasSynthRef' so that given...+-- +--   >>> let foo = sdNamed "foo" [] $ out 0 [0.1 ~* whiteNoise]+-- +--   ...you can create a synth either with...+-- +--   >>> synth "foo" []+-- +--   ...or...+-- +--   >>> synth foo []+-- +--   Careful!: The SC server doesn't keep track of your nodes for you,+--   so if you do something like...+-- +--   >>> s <- synth "someSynth" []+--   >>> s <- synth "oops" []           -- 's' is overwritten+-- +--   ...you've got no way to refer to the first synth you've created, and if you+--   want to stop it you have to 'cmdPeriod'+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
+ Vivid/SynthDef/CrazyTypes.hs view
@@ -0,0 +1,66 @@+-- | Our IncoherentInstances + UndecidableInstances sin bin, for everything that needs+--   crazy type hacks+-- +--   Most of this is just to get numbers defaulting to Floats in a useful way in+--   SynthDefs+-- +--   We keep these separated so everything that doesn't need IncoherentInstances+--   can live in Sanity Land++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE IncoherentInstances #-}++module Vivid.SynthDef.CrazyTypes where++-- import Vivid.SynthDef ()+import Vivid.SynthDef.Types++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8++++class ToSig s where+  toSig :: s -> Signal++instance ToSig Signal where+   toSig = id++-- | For 'Constant' (Float) values+instance (Num a, Real a) => ToSig a where+   toSig = Constant . fromRational . toRational++instance ToSig String where+   toSig = Param . BS8.pack++---++class ToSigM s where+   toSigM :: s -> SDState Signal++instance (ToSig i) => ToSigM i where+   toSigM = return . toSig++instance ToSigM (SDState Signal) where+   toSigM = id++---++class HasSynthRef a where+   getSynthRef :: a -> Either ByteString SynthDef++-- for some reason this needs -XFlexibleInstances:+instance HasSynthRef String where+   getSynthRef = Left . BS8.pack++instance HasSynthRef SynthDef where+   getSynthRef = Right++-- can also do:+{-+instance HasSynthRef (SDState Input) where+   getSynthRef = Right . sd []+-}
+ Vivid/SynthDef/Literally.hs view
@@ -0,0 +1,317 @@+-- |  __You probably don't need to use this directly__ -- use "Vivid.SynthDef" instead+-- +--   This is a representation of how SynthDefs are sent over the wire, as described in the+--   < http://doc.sccode.org/Reference/Synth-Definition-File-Format.html Synth Definition File Format >+--   helpfile.+-- ++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE NoRebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}++module Vivid.SynthDef.Literally (+     LiteralSynthDef(..)+   , encodeSynthDefFile+   , decodeSynthDefFile++   , UGenSpec(..)+   , InputSpec(..)+   , ParamName(..)+   , SynthDefFile(..)+   , OutputSpec(..)+   ) where++import Vivid.SynthDef.Types+import Vivid.OSC.Util (floatToWord, wordToFloat)++import Control.Arrow (first)+import Control.Monad (when)+import Data.Binary (decode, encode)+import qualified Data.ByteString as B+import qualified Data.ByteString as BS+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BSL+import Data.Int+import Data.List.Split (chunksOf)+import Data.Monoid++data LiteralSynthDef+   = LiteralSynthDef {+    _synthDefName :: ByteString -- pstring: "a pascal format string: a byte giving the length followed by that many bytes"+   ,_synthDefConstants :: [Float]+   ,_synthDefParameters :: [Float] -- Initial values+   ,_synthDefParamNames :: [ParamName]+   ,_synthDefUGens :: [UGenSpec]+   ,_synthDefVariants :: [VariantSpec]+   }+ deriving (Show)++data SynthDefFile = SynthDefFile [LiteralSynthDef]+ deriving (Show)++decodeSynthDefFile :: ByteString -> IO SynthDefFile+decodeSynthDefFile blob = do+   let (top, rest) = BS.splitAt 4 blob+   let (fileVersion :: Int32, rest2) =+          first (decode . BSL.fromStrict) $ BS.splitAt 4 rest++   when (top /= "SCgf" || fileVersion /= 2) $+      error $ "screwed up synthdef file " <> show top <> show fileVersion++   let (numberOfSynthDefs :: Int16, rest3) =+          first (decode . BSL.fromStrict) $ BS.splitAt 2 rest2++   let (synthDefs, rest4) = getNWith numberOfSynthDefs decodeSynthDef rest3++   if rest4 /= ""+      then error $ "leftover data: " <> show rest4+      else return ()++   return $ SynthDefFile synthDefs++{-+a synth-definition-file is :+int32 - four byte file type id containing the ASCII characters: "SCgf"+int32 - file version, currently 2.+int16 - number of synth definitions in this file (D).+[ synth-definition ] * D+-}++encodeSynthDefFile :: SynthDefFile -> ByteString+encodeSynthDefFile (SynthDefFile synthDefs) = mconcat [+     "SCgf"+   , BSL.toStrict $ encode (2 :: Int32)+   , BSL.toStrict $ encode (toEnum (length synthDefs) :: Int16)+   , mconcat $ map encodeSynthDef synthDefs+   ]++-- Yes, the 'restN's are ugly, yes i could have used a state monad. Don't judge me.+decodeSynthDef :: ByteString -> (LiteralSynthDef, {- rest: -} ByteString)+decodeSynthDef blob =+   let (name :: ByteString, rest) = getPString blob++       (numConstants :: Int32, rest2) = getInt32 rest++       (constants :: [Float], rest3) =+          first (map (wordToFloat . decode . BSL.fromStrict)) $ getN4ByteBlocks numConstants rest2++       (numParams :: Int32, rest4) = getInt32 rest3++       (params :: [Float], rest5) =+          first (map (wordToFloat . decode . BSL.fromStrict)) $ getN4ByteBlocks numParams rest4++       (numParamNames :: Int32, rest6) = getInt32 rest5++       (paramNames :: [ParamName], rest7) = getNWith numParamNames getParamName rest6++       (numUGens :: Int32, rest8) = getInt32 rest7++       (uGens, rest9) = getNWith numUGens getUGenSpec rest8++       (numVariants, rest10) = getInt16 rest9++       (variantSpecs, rest11) = getNWith numVariants (getVariantSpec numParams) rest10++   in (LiteralSynthDef name constants params paramNames uGens variantSpecs, rest11)++{-+a synth-definition is :+pstring - the name of the synth definition+int32 - number of constants (K)+[float32] * K - constant values+int32 - number of parameters (P)+[float32] * P - initial parameter values+int32 - number of parameter names (N)+[ param-name ] * N+int32 - number of unit generators (U)+[ ugen-spec ] * U+int16 - number of variants (V)+[ variant-spec ] * V+-}++encodeSynthDef :: LiteralSynthDef -> ByteString+encodeSynthDef (LiteralSynthDef name constants params paramNames uGenSpecs variants) = mconcat [+     encodePString name+   , BSL.toStrict $ encode (toEnum (length constants) :: Int32)+   , mconcat $ map (BSL.toStrict . encode . floatToWord) constants+   , BSL.toStrict $ encode (toEnum (length params) :: Int32)+   , mconcat $ map (BSL.toStrict . encode . floatToWord) params+   , BSL.toStrict $ encode (toEnum (length paramNames) :: Int32)+   , mconcat $ map encodeParamName paramNames+   , BSL.toStrict $ encode (toEnum (length uGenSpecs) :: Int32)+   , mconcat $ map encodeUGenSpec uGenSpecs+   , BSL.toStrict $ encode (toEnum (length variants) :: Int16)+   , mconcat $ map encodeVariantSpec variants+   ]++data ParamName = ParamName {+    _paramName_name :: ByteString+   ,_paramName_indexInParamArray :: Int32+   }+ deriving (Show)++{-+a param-name is :+pstring - the name of the parameter+int32 - its index in the parameter array+-}++getParamName :: ByteString -> (ParamName, ByteString)+getParamName blob =+   let (name, rest) = getPString blob+       (index, rest2) = getInt32 rest+   in (ParamName name index, rest2)++encodeParamName :: ParamName -> ByteString+encodeParamName (ParamName name index) =+   encodePString name <> BSL.toStrict (encode index)++data UGenSpec = UGenSpec {+    _uGenSpec_name :: ByteString+   ,_uGenSpec_calcRate :: CalculationRate+   ,_uGenSpec_inputs :: [InputSpec]+   ,_uGenSpec_outputs :: [OutputSpec]+   ,_uGenSpec_specialIndex :: Int16+   }+ deriving (Show)++{-+a ugen-spec is :+pstring - the name of the SC unit generator class+int8 - calculation rate+int32 - number of inputs (I)+int32 - number of outputs (O)+int16 - special index+[ input-spec ] * I+[ output-spec ] * O+-}++getUGenSpec :: ByteString -> (UGenSpec, {- rest: -} ByteString)+getUGenSpec blob =+   let (name, rest) = getPString blob+       (calcRate :: CalculationRate, rest2) =+          first ((toEnum) . (fromEnum :: Int8 -> Int) . decode . BSL.fromStrict) $+             B.splitAt 1 rest+       (numInputs :: Int32, rest3) = getInt32 rest2+       (numOutputs :: Int32, rest4) = getInt32 rest3++       (specialIndex, rest5) = getInt16 rest4+       (inputSpecs, rest6) = getNWith numInputs getInputSpec rest5+       (outputSpecs, rest7) = getNWith numOutputs getOutputSpec rest6++   in (UGenSpec name calcRate inputSpecs outputSpecs specialIndex, rest7)++encodeUGenSpec :: UGenSpec -> ByteString+encodeUGenSpec (UGenSpec name calcRate inputSpecs outputSpecs specialIndex) = mconcat [+    encodePString name+   ,BSL.toStrict $ encode $ (toEnum (fromEnum calcRate) :: Int8)+   ,BSL.toStrict $ encode $ (toEnum (length inputSpecs) :: Int32)+   ,BSL.toStrict $ encode $ (toEnum (length outputSpecs) :: Int32)+   ,BSL.toStrict $ encode specialIndex+   ,mconcat $ map encodeInputSpec inputSpecs+   ,mconcat $ map encodeOutputSpec outputSpecs+   ]++data InputSpec+   = InputSpec_UGen {+    _inputSpec_uGen_index :: Int32+   ,_inputSpec_uGen_outputIndex :: Int32+   }+   | InputSpec_Constant {+    _inputSpec_constant_index :: Int32+   }+ deriving (Show, Read, Eq)++{-+an input-spec is :+int32 - index of unit generator or -1 for a constant+if (unit generator index == -1) :+int32 - index of constant+else :+int32 - index of unit generator output+-}++getInputSpec :: ByteString -> (InputSpec, ByteString)+getInputSpec blob =+   let (stuffForThis, rest) = BS.splitAt 8 blob+       (one :: Int32, two :: Int32) = (\(a,b) -> ((decode . BSL.fromStrict) a, (decode . BSL.fromStrict) b)) $ BS.splitAt 4 stuffForThis+       spec = case one of+          -1 -> InputSpec_Constant two+          n | n > -1 -> InputSpec_UGen one two+          _ -> error "bad number"+   in (spec, rest)++encodeInputSpec :: InputSpec -> ByteString+encodeInputSpec inputSpec = mconcat $ map (BSL.toStrict . encode) $ encodeInputSpec' inputSpec+ where+   encodeInputSpec' :: InputSpec -> [Int32]+   encodeInputSpec' (InputSpec_Constant i) = [ (-1), i ]+   encodeInputSpec' (InputSpec_UGen i oI) = [ i, oI ]++data OutputSpec = OutputSpec { _outputSpec_calcRate :: CalculationRate }+ deriving (Show, Read, Eq)++{-+an output-spec is :+int8 - calculation rate+-}++getOutputSpec :: ByteString -> (OutputSpec, ByteString)+getOutputSpec blob =+      first (OutputSpec . toEnum . (fromEnum :: Int8 -> Int) . decode . BSL.fromStrict) $+         BS.splitAt 1 blob++encodeOutputSpec :: OutputSpec -> ByteString+encodeOutputSpec (OutputSpec calcRate) =+   BSL.toStrict $ encode $ (toEnum (fromEnum calcRate) :: Int8)++data VariantSpec+   = VariantSpec {+    _variantSpec_name :: ByteString+   ,_variantSpec_initialParamVals :: [Float] -- float32+   }+ deriving (Show)++{-+a variant-spec is :+pstring - the name of the variant+[float32] * P - variant initial parameter values+-}++getVariantSpec :: Int32 -> ByteString -> (VariantSpec, ByteString)+getVariantSpec numParams blob =+   let (name, rest) = getPString blob+       (initialParamVals :: [Float], rest2) = first (map (decode . BSL.fromStrict)) $ getN4ByteBlocks numParams rest+   in (VariantSpec name initialParamVals, rest2)++encodeVariantSpec :: VariantSpec -> ByteString+encodeVariantSpec (VariantSpec name initialParamVals) =+   encodePString name <> mconcat (map (BSL.toStrict . encode . floatToWord) initialParamVals)++--- helpers:+getPString :: ByteString -> (ByteString, {- rest: -} ByteString)+getPString blob = first (BS.drop 1) $+   BS.splitAt (fromEnum (BS.head blob) + 1) blob++encodePString :: ByteString -> ByteString+encodePString s = toEnum (BS.length s) `BS.cons` s++getNWith :: (Integral i) => i -> (ByteString -> (a, ByteString)) -> ByteString -> ([a], ByteString)+getNWith 0 _ rest = ([], rest)+getNWith n f rest =+   let (head1, rest2) = f rest+       (head2, rest3) = getNWith (n - 1) f rest2+   in (head1 : head2, rest3)+   +getInt32 :: ByteString -> (Int32, ByteString)+getInt32 blob = first (decode . BSL.fromStrict) $ B.splitAt 4 blob++getInt16 :: ByteString -> (Int16, ByteString)+getInt16 blob = first (decode . BSL.fromStrict) $ B.splitAt 2 blob++getN4ByteBlocks :: Int32 -> ByteString -> ([ByteString], ByteString)+getN4ByteBlocks numBlocks blob =+   first (map (BS8.pack) . chunksOf 4 . BS8.unpack) $+             B.splitAt (4 * fromEnum numBlocks) blob
+ Vivid/SynthDef/Types.hs view
@@ -0,0 +1,129 @@+-- | Internal. Just use "Vivid.SynthDef"++{-# OPTIONS_HADDOCK show-extensions #-}++module Vivid.SynthDef.Types (+     Signal(..)+   , CalculationRate(..)+   , SynthDef(..)+   , SDName(..)+   , SDState+   , UGen(..)+   , UGenName(..)+   , UnaryOp(..)+   , BinaryOp(..)+   ) where++import Control.Monad.State+import Data.ByteString (ByteString)+import Data.Int (Int32)+import Data.Map (Map)++data Signal+   = Constant Float -- constant+   | Param ByteString -- parameter+   | UGOut Int Int32 -- the name of the ugen, and its output #+ deriving (Show, Eq)++-- | Internal representation of Synth Definitions. Usually, use 'Vivid.SynthDef.sd' instead of+--   making these by hand.+-- +--   This representation (especially '_sdUGens') might change in the future.+data SynthDef = SynthDef {+    _sdName :: SDName+   ,_sdParams :: [(ByteString, Float)]+   ,_sdUGens :: Map Int UGen+   -- ignoring variants+   }+ deriving (Show)++data SDName+   = SDName_Named ByteString+   | SDName_Hash+ deriving (Show, Eq, Read, Ord)++-- | Representation of Unit Generators. You usually won't be creating these+--   by hand, but instead using things from the library in 'Vivid.UGens'+data UGen = UGen {+    _ugenName :: UGenName+   ,_ugenCalculationRate :: CalculationRate+   ,_ugenIns :: [Signal]+   -- The calculation rates of each of the outputs are always the same as the+   -- ugen's calculation rate, so we don't need to represent them:+   ,_ugenNumOuts :: Int+   }+ deriving (Show, Eq)++data UGenName+   = UGName_S ByteString+   | UGName_U UnaryOp+   | UGName_B BinaryOp+ deriving (Show, Eq)++-- The order of these is important for the enum instance:+-- | The rate that a UGen computes at+data CalculationRate+   = IR -- ^ constant value+   | KR -- ^ control rate+   | AR -- ^ audio rate+   | DR -- ^ demand rate+ deriving (Show, Read, Eq, Enum, Ord)++-- | State monad to construct SynthDefs+-- +--   The SynthDef is an under-construction synth definition+--   The [Int] is the id supply. Its type definitely could change in the future+type SDState = State ([Int], SynthDef)++-- | Binary signal operations. For the simple ones (like 'Add', 'Mul', etc.),+--   there are functions (like 'Vivid.UGens.~+', 'Vivid.UGens.~*', etc.)+--   that wrap them up so you+--   don't have to make a ugen for them yourself.+-- +--   In the future these may not be exported -- we'll just have functions for+--   all of them.+data BinaryOp+   = Add | Sub | Mul +   | IDiv -- ^ Integer division+   | FDiv -- ^ Float division+   | Mod | Eq | Ne | Lt | Gt | Le | Ge+   | Min | Max | BitAnd | BitOr | BitXor | Lcm | Gcd | Round | RoundUp | Trunc+   | Atan2 | Hypot | Hypotx | Pow | ShiftLeft | ShiftRight | UnsignedShift | Fill+   -- comments come from SC source:+   | Ring1 -- ^ a * (b + 1) == a * b + a+   | Ring2 -- ^ a * b + a + b+   | Ring3 -- ^ a * a * b+   | Ring4 -- ^ a * a * b - a * b * b+   | DifSqr -- ^ a * a - b * b+   | SumSqr -- ^ a * a + b * b+   | SqrSum -- ^ (a + b) ^ 2+   | SqrDif -- ^ (a - b) ^ 2+   | AbsDif -- ^ abs(a - b)+   | Thresh | AMClip | ScaleNeg | Clip2 | Excess+   | Fold2 | Wrap2 | FirstArg+   | RandRange | ExpRandRange | NumBinarySelectors+ deriving (Show, Eq, Ord, Enum)++++-- These seem to only be in the SuperCollider source:+--   sc/server/plugins/(Bi|U)naryOpUgens.cpp++-- | Unary signal operations. Many of these have functions so you don't need to+--   use this internal representation (e.g. 'Neg' has 'neg', etc).+-- +--   This type might not be exposed in the future.+data UnaryOp+   = Neg | Not | IsNil | NotNil | BitNot | Abs | AsFloat | AsInt | Ciel | Floor+   | Frac | Sign | Squared | Cubed | Sqrt | Exp | Recip | MIDICPS | CPSMIDI+   | MIDIRatio | RatioMIDI+    -- dbamp and ampdb: converts betw db and "amp" so that e.g. -inf db == 0 amp+    -- dunno how the other scaling works+   | DbAmp | AmpDb+   | OctCPS | CPSOct | Log | Log2 | Log10+   | Sin | Cos | Tan | ArcSin | ArcCos | ArcTan | SinH | CosH | TanH+   | Rand | Rand2 | LinRand | BiLinRand | Sum3Rand+   | Distort | SoftClip | Coin | DigitValue+   | Silence | Thru | RectWindow | HanWindow | WelchWindow | TriWindow | Ramp+   | SCurve | NumUnarySelectors+ deriving (Show, Eq, Ord, Enum)
+ Vivid/UGens.hs view
@@ -0,0 +1,444 @@+-- | Unit Generators, which are the signal-generating/processing components of synths.+-- +--   Most of your time reading documentation will probably be in this module+-- +--   Most of these take named arguments with types like 'In', 'Freq', etc.+--   This just means you construct them with the same data constructor.+--   The data constructor is the same as its type ('In' and 'In', etc.).+--   So e.g. to make a lowpass filter which filters whitenoise at 440hz, you'd write:+-- +--   > lpf (In whiteNoise) (Freq 440)+-- +--   This is far from all the ones in SC, so I've exposed the internals so you can make+--   your own when you want. Some exports may disappear in future versions.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE NoRebindableSyntax #-}++{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}++module Vivid.UGens (++   -- * Generators+   -- | Generate signals, which can then be processed++   -- ** Audio or control rate+   -- | These can be used as direct sound sources or as control parameters++     lfTri+   , lfSaw+   , sinOsc+   , fSinOsc+   , whiteNoise+   , pinkNoise+   , brownNoise+++   -- ** Control rate+   -- | These wouldn't be useful as direct sound sources, but instead as+   --   parameters to other UGens++   , xLine+   , line++   -- * User input+   -- | Generators which get signals from user input++   -- ** Audio rate++   , soundIn0++   -- ** Control rate++   , mouseX+   , mouseY+++   -- * Filters+   -- | Filter signals++   , bpf+   , lpf+   , hpf+   , clip+++   -- * Buffers++   , playBuf1+   , recordBuf1+++   -- * FFT+   -- | Stuff for Fast Fourier Transforms. Very incomplete atm.++   , localBuf+   , fft+   , ifft+   , pv_binScramble+   , pv_randComb+++   -- * Signal math+   -- | Add, multiply, etc.++   -- ** Operators+   -- | Mnemonic: the ~ looks like a sound wave++   , (~*)+   , (~+)+   , (~/)+   , (~-)+   , (~>)++   -- ** Functions++   , midiCPS+   , abs'+   , neg+   , binaryOp+   , biOp+   , unaryOp+   , uOp++   -- * Uncategorized+   -- | Haven't organized yet+   , varSaw+   , syncSaw+   , impulse+   , pan2+   , out+   , lfPar+   , lfCub+   , lfPulse+   , mix+   , freeVerb+   , pitchShift+   , lag++   , module Vivid.UGens.Args+   ) where++import Vivid.SynthDef+import Vivid.UGens.Args++import Control.Applicative+import Data.ByteString (ByteString)+import Data.List.Split (chunksOf)++-- | \"A non-band-limited triangle oscillator. Output ranges from -1 to +1.\"+lfTri :: Freq -> SDState Signal+lfTri (Freq freq) = do+   freq' <- toSigM freq+   addUGen $ UGen (UGName_S "LFTri") AR [freq', Constant 0] 1++-- | \"A non-band-limited sawtooth oscillator. Output ranges from -1 to +1.\"+lfSaw :: Freq -> SDState Signal+lfSaw (Freq freq) = do+   freq' <- toSigM freq+   addUGen $ UGen (UGName_S "LFSaw") AR [freq', Constant 0] 1++-- | \"Generates noise whose spectrum has equal power at all frequencies.\"+whiteNoise :: SDState Signal+whiteNoise = addUGen $ UGen (UGName_S "WhiteNoise") AR [] 1++-- | \"Generates noise whose spectrum falls off in power by 3 dB per octave. This gives equal power over the span of each octave. This version gives 8 octaves of pink noise.\"+pinkNoise :: SDState Signal+pinkNoise = addUGen $ UGen (UGName_S "PinkNoise") AR [] 1++-- | \"Generates noise whose spectrum falls off in power by 6 dB per octave.\"+brownNoise :: SDState Signal+brownNoise = addUGen $ UGen (UGName_S "BrownNoise") AR [] 1++-- | Sine wave+sinOsc :: Freq -> SDState Signal+sinOsc (Freq i) = do+   i' <- toSigM i+   addUGen $ UGen (UGName_S "SinOsc") AR [i'] 1++-- | Band-pass filter+bpf :: In -> Freq -> Rq -> SDState Signal+-- Rq: bandwidth / cutofffreq+bpf (In i) (Freq freq) (Rq rq) = do+   i' <- toSigM i+   freq' <- toSigM freq+   rq' <- toSigM rq+   addUGen $ UGen (UGName_S "BPF") AR [i', freq', rq'] 1++-- also look at RLPF:+-- | Low-pass filter+lpf :: In -> Freq -> SDState Signal+lpf = passFilter "LPF"++-- | High-pass filter+hpf :: In -> Freq -> SDState Signal+hpf = passFilter "HPF"++passFilter :: ByteString -> In -> Freq -> SDState Signal+passFilter filterName (In inP) (Freq freq) = do+   in' <- toSigM inP+   freq' <- toSigM freq+   addUGen $ UGen (UGName_S filterName) AR [in', freq'] 1++-- | Unlike in SuperCollider, you don't specify a \"lo\" parameter -- \"lo\" is always+--   negative \"hi\"+clip :: In -> {- Lo -> -} Hi -> SDState Signal+clip (In i) {- (Lo lo) -} (Hi hi) = do+   i' <- toSigM i+   -- lo' <- toSigM lo+   hi' <- toSigM hi+   lo' <- neg hi'+   addUGen $ UGen (UGName_S "Clip") AR [i', lo', hi'] 1++-- | Bus input (usually mic). \"0\" because it's from the 0th bus+soundIn0 :: SDState Signal -- this can easily be expressed now. oh also -- this is a good case where i might want to specify a ton of outputs+soundIn0 = do+   nob <- addUGen $ UGen (UGName_S "NumOutputBuses") IR [] 1+   addUGen $ UGen (UGName_S "In") AR [nob] 1++(~*) :: (ToSigM sig0, ToSigM sig1) => sig0 -> sig1 -> SDState Signal+(~*) = binaryOp Mul++(~+) :: (ToSigM i0, ToSigM i1) => i0 -> i1 -> SDState Signal+(~+) = binaryOp Add++(~/) :: (ToSigM i0, ToSigM i1) => i0 -> i1 -> SDState Signal+(~/) = binaryOp FDiv++(~>) :: (ToSigM i0, ToSigM i1) => i0 -> i1 -> SDState Signal+(~>) = binaryOp Gt++(~-) :: (ToSigM i0, ToSigM i1) => i0 -> i1 -> SDState Signal+(~-) = binaryOp Sub++-- | Build your own!+binaryOp :: (ToSigM s0, ToSigM s1) => BinaryOp -> s0 -> s1 -> SDState Signal+binaryOp theBiOp s0 s1 = do+   s0' <- toSigM s0+   s1' <- toSigM s1+   let sigs = [s0', s1']+   calcRate <- maximum <$> mapM getCalcRate sigs+   addUGen $ UGen (UGName_B theBiOp) calcRate sigs 1++-- | Alias of 'binaryOp'. Shorter, fer livecodin+biOp :: (ToSigM s0, ToSigM s1) => BinaryOp -> s0 -> s1 -> SDState Signal+biOp = binaryOp++-- | Build your own, from 'UnaryOp's+unaryOp :: (ToSigM sig) => UnaryOp -> sig -> SDState Signal+unaryOp theUOp sig = do+   sig' <- toSigM sig+   calcRate <- getCalcRate sig'+   addUGen $ UGen (UGName_U theUOp) calcRate [sig'] 1++-- | Alias of 'unaryOp'+uOp :: (ToSigM sig) => UnaryOp -> sig -> SDState Signal+uOp = unaryOp++-- | Convert from a midi note number (0-127, each representing a musical half step) to a+--   frequency in hz (cycles per second)+midiCPS :: (ToSigM i) => i -> SDState Signal+midiCPS = unaryOp MIDICPS++-- | Inverse of 'midiCPS'+cpsMIDI :: (ToSigM i) => i -> SDState Signal+cpsMIDI = unaryOp CPSMIDI++-- | The prime is to not conflict with \"abs\" in the prelude. May just use+--   \"uOp Abs\" in the future+abs' :: (ToSigM i) => i -> SDState Signal+abs' = unaryOp Abs++neg :: ToSigM i => i -> SDState Signal+neg = unaryOp Neg++out :: (ToSigM i) => Float -> [i] -> SDState [Signal]+out busNum is = do+   is' <- mapM toSigM is+   addPolyUGen $ UGen (UGName_S "Out") AR (Constant busNum : is') (length is)++lfPar :: Freq -> SDState Signal+lfPar (Freq freq) = do+   freq' <- toSigM freq+   addUGen $ UGen (UGName_S "LFPar") AR [freq', Constant 0] 1++-- | \"Generates an exponential curve from the start value to the end value. Both the start and end values must be non-zero and have the same sign.\"+-- +-- Defaults to KR+xLine :: Start -> End -> Dur -> DoneAction -> SDState Signal+xLine (Start start) (End end) (Dur dur) doneAction = do+   start' <- toSigM start+   end' <- toSigM end+   dur' <- toSigM dur+   addUGen $ UGen (UGName_S "XLine") KR [start', end', dur', Constant $ doneActionNum doneAction] 1++-- | \"Generates a line from the start value to the end value.\"+-- +-- Defaults to KR+line :: Start -> End -> Dur -> DoneAction -> SDState Signal+line (Start start) (End end) (Dur dur) doneAction = do+   start' <- toSigM start+   end' <- toSigM end+   dur' <- toSigM dur+   addUGen $ UGen (UGName_S "Line") KR [start', end', dur', Constant $ doneActionNum doneAction] 1++lfCub :: Freq -> SDState Signal+lfCub (Freq freq) = do+   freq' <- toSigM freq+   addUGen $ UGen (UGName_S "LFCub") AR [freq'] 1++impulse :: Freq -> SDState Signal+impulse (Freq freq) = do+   freq' <- toSigM freq+   addUGen $ UGen (UGName_S "Impulse") AR [freq', Constant 0] 1++lfPulse :: Freq -> Width -> SDState Signal+lfPulse (Freq freq) (Width width) = do+   freq' <- toSigM freq+   width' <- toSigM width+   addUGen $ UGen (UGName_S "LFPulse") AR [freq', Constant 0, width'] 1+++-- other options:+-- warp -- Mapping curve. 0 is linear, 1 is exponential (e. g. for freq or times). Alternatively you can specify: 'linear' or 'exponential'.+-- lag -- Lag factor to dezpipper cursor movement.+mouseY :: MinVal -> MaxVal -> SDState Signal+mouseY = mouseGeneral "MouseY"++mouseX :: MinVal -> MaxVal -> SDState Signal+mouseX = mouseGeneral "MouseX"++mouseGeneral :: ByteString -> (MinVal -> MaxVal -> SDState Signal)+mouseGeneral ugenName (MinVal minVal) (MaxVal maxVal) = do+   minVal' <- toSigM minVal+   maxVal' <- toSigM maxVal+   addUGen $ UGen (UGName_S ugenName) KR [minVal', maxVal', Constant 0, Constant 0.2] 1+++varSaw :: Freq -> Width -> SDState Signal+varSaw (Freq freq) (Width width) = do+   freq' <- toSigM freq+   width' <- toSigM width+   addUGen $ UGen (UGName_S "VarSaw") AR [freq', Constant 0, width'] 1++syncSaw :: SyncFreq -> SawFreq -> SDState Signal+syncSaw (SyncFreq syncFreq) (SawFreq sawFreq) = do+   syncFreq' <- toSigM syncFreq+   sawFreq' <- toSigM sawFreq+   addUGen $ UGen (UGName_S "SyncSaw") AR [syncFreq', sawFreq'] 1++-- | Add a single LocalBuf for FFT+localBuf :: NumFrames -> NumChans -> SDState Signal+localBuf (NumFrames numFrames) (NumChans numChannels) = do+   -- don't know what the "1" is here:+   mlb <- addUGen $ UGen (UGName_S "MaxLocalBufs") IR [Constant 1] 1+   numChannels' <- toSigM numChannels+   numFrames' <- toSigM numFrames+   addUGen $ UGen (UGName_S "LocalBuf") IR [numChannels', numFrames', mlb] 1++fft :: Buf -> In -> SDState Signal+fft (Buf buf) (In inp) = do+   buf' <- toSigM buf+   inp' <- toSigM inp+      -- might want to change some of these args:+   let args = [buf', inp', Constant 0.5, Constant 0, Constant 1, Constant 0]+   addUGen $ UGen (UGName_S "FFT") KR args 1++ifft :: Buf -> SDState Signal+ifft (Buf buf) = do+   buf' <- toSigM buf+   addUGen $ UGen (UGName_S "IFFT") AR [buf', Constant 0, Constant 0] 1+++   -- FFT FUNCTIONS: --++pv_binScramble :: Buf -> Wipe -> Width -> Trigger -> SDState Signal+pv_binScramble (Buf buf) (Wipe wipe) (Width width) (Trigger trigger) = do+   buf' <- toSigM buf+   wipe' <- toSigM wipe+   width' <- toSigM width+   trigger' <- toSigM trigger+   addUGen $ UGen (UGName_S "PV_BinScramble") KR [buf', wipe', width', trigger'] 1++pv_randComb :: Buf -> Wipe -> Trigger -> SDState Signal+pv_randComb (Buf buf) (Wipe wipe) (Trigger trigger) = do+   buf' <- toSigM buf+   wipe' <- toSigM wipe+   trigger' <- toSigM trigger+   addUGen $ UGen (UGName_S "PV_RandComb") KR [buf', wipe', trigger'] 1++++   -- END FFT ---+++-- | Mixes down a list of audio rate inputs to one. +--   The list can't be empty.+-- +--   This is more efficient than e.g. @foldl1 (~*)@+mix :: (ToSigM s) => [s] -> SDState Signal+mix [] = error "empty mix"+mix [x] = toSigM x+mix xs = mix =<< (mapM mix' . chunksOf 4) =<< mapM toSigM xs+ where+   mix' :: [Signal] -> SDState Signal+   mix' [] = error "something's broken"+   mix' [x] = return x+   mix' [a,b] = a ~* b+   mix' ins@[_,_,_]   = addUGen $ UGen (UGName_S "Sum3") AR ins 1+   mix' ins@[_,_,_,_] = addUGen $ UGen (UGName_S "Sum4") AR ins 1+   mix' _ = error "that would be weird"++-- can i compute numchans?+-- also e.g. w reverb you dont want the doneaction to be 2+-- | Play a 1-channel buffer+playBuf1 :: {- NumChans -> -} Buf -> SDState Signal+ -- numchans "must be a fixed integer"+   -- args are in sc order, not osc:+playBuf1 {- (NumChans numChans) -} (Buf buf) = do+   -- numChans' <- toSigM numChans+   buf' <- toSigM buf+   addUGen $ UGen (UGName_S "PlayBuf") AR [buf', {- rate: -} Constant 1, {- trigger -} Constant 1, {- startPos -} Constant 0, {- loop: -} Constant 0, {- doneAction -} Constant 2] 1 -- numChans', ++-- | Record a 1-channel buffer+recordBuf1 :: In -> Buf -> SDState Signal+   -- args are in sc order, not osc:+recordBuf1 (In inp) (Buf buf) = do+   in' <- toSigM inp+   buf' <- toSigM buf+   addUGen $ UGen (UGName_S "RecordBuf") AR [buf', {- offset -} Constant 0, {- recLevel -} Constant 1, {- prelevel-} Constant 0, {- run -} Constant 1, {- loop -} Constant 0, {- trigger -} Constant 1, {- doneAction -} Constant 2, in'] 1++freeVerb :: In -> Mix -> Room -> Damp -> SDState Signal+freeVerb (In inp) (Mix mixS) (Room room) (Damp damp) = do+   in' <- toSigM inp+   mix' <- toSigM mixS+   room' <- toSigM room+   damp' <- toSigM damp+   addUGen $ UGen (UGName_S "FreeVerb") AR [in', mix', room', damp'] 1++pitchShift :: In -> Ratio -> SDState Signal+pitchShift (In inp) (Ratio ratio) = do+   in' <- toSigM inp+   ratio' <- toSigM ratio+   addUGen $ UGen (UGName_S "PitchShift") AR [in', {- windowSize: -} Constant 0.2, ratio', {-pitchDispersion -} Constant 0, {- timeDispersion -} Constant 0] 1++fSinOsc :: Freq -> SDState Signal+fSinOsc (Freq freq) = do+   freq' <- toSigM freq+   addUGen $ UGen (UGName_S "FSinOsc") AR [freq'] 1++-- | 'pos' is -1 to 1+pan2 :: In -> Pos -> SDState [Signal]+pan2 (In inp) (Pos pos) = do+   in' <- toSigM inp+   pos' <- toSigM pos+   addPolyUGen $ UGen (UGName_S "Pan2") AR [in', pos'] 2++-- | The \"Secs\" arg is the same as the \"lagTime\" arg in SC+lag :: In -> Secs -> SDState Signal+lag (In inp) (Secs secs) = do+   in' <- toSigM inp+   secs' <- toSigM secs+   addUGen $ UGen (UGName_S "Lag") AR [in', secs'] 1
+ Vivid/UGens/Args.hs view
@@ -0,0 +1,40 @@+-- | These are named the same as their SC counterparts, usually.+--   Sometimes not, if the names are long or if the names would clash w/ common+--   other names.++{-# OPTIONS_HADDOCK show-extensions #-}++{-# LANGUAGE NoRebindableSyntax #-}++{-# LANGUAGE ExistentialQuantification #-}++module Vivid.UGens.Args where++import Vivid.SynthDef (ToSigM)++data Buf = forall i. ToSigM i => Buf i+data Bus = forall i. ToSigM i => Bus i+data Damp = forall i. ToSigM i => Damp i+data Dur = forall i. ToSigM i => Dur i+data End = forall i. ToSigM i => End i+data Freq = forall i. ToSigM i => Freq i+data Hi = forall i. ToSigM i => Hi i+data In = forall i. ToSigM i => In i+data Lo = forall i. ToSigM i => Lo i+data MaxVal = forall i. ToSigM i => MaxVal i+data MinVal = forall i. ToSigM i => MinVal i+data Mix = forall i. ToSigM i => Mix i+data NumChans = forall i. ToSigM i => NumChans i+data NumFrames = forall i. ToSigM i => NumFrames i+data Phase = forall i. ToSigM i => Phase i+data Pos = forall i. ToSigM i => Pos i+data Ratio = forall i. ToSigM i => Ratio i+data Room = forall i. ToSigM i => Room i+data Rq = forall i. ToSigM i => Rq i+data SawFreq = forall i. ToSigM i => SawFreq i+data Secs = forall s. ToSigM s => Secs s+data Start = forall i. ToSigM i => Start i+data SyncFreq = forall i. ToSigM i => SyncFreq i+data Trigger = forall i. ToSigM i => Trigger i+data Width = forall i. ToSigM i => Width i+data Wipe = forall i. ToSigM i => Wipe i
+ vivid.cabal view
@@ -0,0 +1,39 @@+-- Initial vivid.cabal generated by cabal init.  For further documentation,+--  see http://haskell.org/cabal/users-guide/++name:                vivid+version:             0.1.0.0+synopsis:            Sound synthesis with SuperCollider+description:         Sound synthesis with SuperCollider. Start with Vivid.SynthDef+author:              Tom Murphy+maintainer:          Tom Murphy+category:            Sound+build-type:          Simple+cabal-version:       >=1.8+stability:           experimental+license:             GPL++library+  exposed-modules:+      Vivid+    , Vivid.OSC+    , Vivid.OSC.Util+    , Vivid.SCServer+    , Vivid.SynthDef+    , Vivid.SynthDef.CrazyTypes+    , Vivid.SynthDef.Literally+    , Vivid.SynthDef.Types+    , Vivid.UGens+    , Vivid.UGens.Args+  -- other-modules:       +  build-depends:+      base > 2 && <= 4+    , binary+    , bytestring+    , containers+    , deepseq+    , hashable == 1.1.*+    , mtl+    , network+    , split+    , stm