diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Vivid.hs b/Vivid.hs new file mode 100644 --- /dev/null +++ b/Vivid.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | For an intro to all this, check out 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 diff --git a/Vivid/OSC.hs b/Vivid/OSC.hs new file mode 100644 --- /dev/null +++ b/Vivid/OSC.hs @@ -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 diff --git a/Vivid/OSC/Util.hs b/Vivid/OSC/Util.hs new file mode 100644 --- /dev/null +++ b/Vivid/OSC/Util.hs @@ -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 diff --git a/Vivid/SCServer.hs b/Vivid/SCServer.hs new file mode 100644 --- /dev/null +++ b/Vivid/SCServer.hs @@ -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" + ] diff --git a/Vivid/SynthDef.hs b/Vivid/SynthDef.hs new file mode 100644 --- /dev/null +++ b/Vivid/SynthDef.hs @@ -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 diff --git a/Vivid/SynthDef/CrazyTypes.hs b/Vivid/SynthDef/CrazyTypes.hs new file mode 100644 --- /dev/null +++ b/Vivid/SynthDef/CrazyTypes.hs @@ -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 [] +-} diff --git a/Vivid/SynthDef/Literally.hs b/Vivid/SynthDef/Literally.hs new file mode 100644 --- /dev/null +++ b/Vivid/SynthDef/Literally.hs @@ -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 diff --git a/Vivid/SynthDef/Types.hs b/Vivid/SynthDef/Types.hs new file mode 100644 --- /dev/null +++ b/Vivid/SynthDef/Types.hs @@ -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) diff --git a/Vivid/UGens.hs b/Vivid/UGens.hs new file mode 100644 --- /dev/null +++ b/Vivid/UGens.hs @@ -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 diff --git a/Vivid/UGens/Args.hs b/Vivid/UGens/Args.hs new file mode 100644 --- /dev/null +++ b/Vivid/UGens/Args.hs @@ -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 diff --git a/vivid.cabal b/vivid.cabal new file mode 100644 --- /dev/null +++ b/vivid.cabal @@ -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