Timing.hs

{-
Rohan Drape: Haskell-Cafe, 2006-11-08
-}

import qualified Sound.OpenSoundControl.Transport.Monad.IO as TIO
import Sound.OpenSoundControl(OSC(Bundle))
import Sound.OpenSoundControl.Time
          (Time(UTCr), utcr, pauseThread, pauseThreadUntil, )
import Sound.OpenSoundControl.Transport.Monad(send, )
import Sound.OpenSoundControl.Transport.UDP (UDP)
import Sound.SC3
          (UGen, out, s_new, n_run, n_free,
           Rate(AR,KR), sinOsc, envGen, envPerc',
           EnvCurve(EnvNum), DoneAction(RemoveSynth),
           AddAction(AddToTail), )
import qualified Sound.SC3.Server.PlayEasy as Play
import Control.Concurrent (forkIO)
import Control.Monad.Trans (liftIO)


-- * from old Rhs.Schedule module
{-
http://slavepianos.org/rd/sw/sw-76
Build-Depends: Rhs >=0.1 && <0.2
-}
type UTC = Double
type Interval = Double
type Action = UTC -> IO (Maybe Interval)

-- | Apply action at indicated time and reschedule after interval.
at :: Double -> Action -> IO ()
at t f = pauseThreadUntil t >> f t >>= resched t f

-- | Rescheduler
resched :: Interval -> Action -> (Maybe Interval) -> IO ()
resched _ _ Nothing = return ()
resched t f (Just i) = at (t+i) f


-- * custom code

ping :: UGen -> UGen -> UGen
ping f a = out 0 (sinOsc AR f 0 * e)
     where c = EnvNum (-4.0)
           e = envGen KR 1 a 0 1 RemoveSynth (envPerc' 0.1 0.6 1 [c,c])

latency :: Double
latency = 0.05

bundle :: Double -> [OSC] -> OSC
bundle t m = Bundle (UTCr $ t + latency) m

scPutStrLn :: String -> TIO.T UDP ()
scPutStrLn = liftIO . putStrLn

pinger :: IO ()
pinger =
   let f t = Play.withSC3 $
                do send (bundle t [s_new "ping" 42 AddToTail 1 []])
--                   send (n_run (-1) True)
                   send (bundle (t+0.1) [n_run [(42, False)], n_free [42]])
--                   send (bundle (t+0.1) [])
--                   send (n_free [101])
--                   send (bundle (t+0.1) [s_new "pong" 5 AddToTail 1 []])
                   scPutStrLn "Sending ping"
                   return (Just 1.0)
   in  do now <- utcr
          at (fromInteger (ceiling now)) f

main :: IO ()
main =
   Play.withSC3 $
       do scPutStrLn "Sending Ping Instrument"
          Play.sync (Play.d_recv_synthdef "ping" (ping 880 0.1))
--          sync (d_recv_synthdef "pong" (ping 660 0.1))
          scPutStrLn "Resetting scsynth"
          Play.reset
          scPutStrLn "Starting schedule thread"
          liftIO $ forkIO pinger
          scPutStrLn "Delaying main thread"
          liftIO $ pauseThread 30
          scPutStrLn "End of delay, exiting"