hsc3-server-0.4.0: examples/sine-grains.hs

import           Control.Concurrent.MVar
import           Control.Monad (void, when)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Sound.SC3.UGen
import           Sound.SC3.Server.Monad
import           Sound.SC3.Server.Monad.Command
-- You need the hsc3-server-internal package in order to use the internal server
--import           Sound.SC3.Server.Monad.Process.Internal (withDefaultInternal)
import           Sound.SC3.Server.Monad.Process (withDefaultSynth)
import           Sound.SC3.Server.Monad.Request
import           Sound.SC3.Server.Notification
import           Sound.OpenSoundControl (immediately)
import qualified Sound.OpenSoundControl as OSC
import           System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))
import           System.Random

sine = out 0 $ pan2 x (sinOsc KR 1 0 * 0.6) 1
    where x = sinOsc AR (control KR "freq" 440) 0
                * control KR "amp" 1
                * envGen KR (control KR "gate" 1) 1 0 1 RemoveSynth (envASR 0.02 1 0.1 EnvLin)

pauseThread :: MonadIO m => Double -> m ()
pauseThread = liftIO . OSC.pauseThread
pauseThreadUntil = liftIO . OSC.pauseThreadUntil

statusLoop = do
    immediately !> status >>= extract >>= liftIO . print
    pauseThread 1
    statusLoop

keepRunning = liftIO . isEmptyMVar

grainLoop quit synthDef delta sustain t = do
    f <- liftIO $ randomRIO (100,800)
    a <- liftIO $ randomRIO (0.1,0.3)
    r <- rootNode
    synth <- OSC.UTCr (t + latency) !> s_new synthDef AddToTail r [("freq", f), ("amp", a)]
    fork $ do
        let t' = t + sustain
        pauseThreadUntil t'
        OSC.UTCr (t' + latency) !> s_release 0 synth
        return ()
    let t' = t + delta
    pauseThreadUntil t'
    b <- keepRunning quit
    when b $ grainLoop quit synthDef delta sustain t'

-- You need the hsc3-server-internal package in order to use the internal server
--run = withDefaultInternal
run = withDefaultSynth

latency = 0.03
 
newBreakHandler :: IO (MVar ())
newBreakHandler = do
    quit <- newEmptyMVar
    void $ installHandler keyboardSignal
            (Catch $ putStrLn "Quitting..." >> putMVar quit ())
            Nothing
    return quit
 
main :: IO ()
main = do
    quit <- newBreakHandler
    run $ do
        sd <- immediately !> async (d_recv "hsc3-server:sine" sine) >>= extract
        fork statusLoop
        grainLoop quit sd 0.03 0.06 =<< liftIO OSC.utcr
    takeMVar quit