module Network.Netclock.Client where
import Sound.OSC.FD
import Sound.OSC.Core
import Sound.OSC.Type
import Control.Concurrent (threadDelay, forkIO)
import Control.Concurrent.MVar
import Data.List
import Data.Maybe
import qualified Network.Socket as N
import Data.Function
import Control.Monad
import qualified Data.ByteString.Char8 as C
data BpsChange = BpsChange {changeBps :: Double,
changeTime :: Double,
changeBeat :: Double
}
instance Show BpsChange where
show change = "bps " ++ show (changeBps change)
++ " time " ++ show (changeTime change)
++ " beat " ++ show (changeBeat change)
instance Eq BpsChange where
(==) = (==) `on` changeBeat
instance Ord BpsChange where
compare = compare `on` changeBeat
scport = 57120
logicalTime :: BpsChange -> Double -> Double
logicalTime change beat =
changeTime change + ((beat changeBeat change) / changeBps change)
waitBeat :: BpsChange -> Double -> IO ()
waitBeat change beat =
do let logicalNow = logicalTime change beat
realNow <- time
let diff = logicalNow realNow
let delay = floor $ diff * 1000000.0
when (diff > 0) $ threadDelay delay
return ()
sched :: String -> String -> String -> Int -> IO () -> IO ()
sched username clientIp serverIp t f =
do mBps <- newEmptyMVar
forkIO $ bpsListen username clientIp serverIp mBps
change <- updateBps mBps 0
realNow <- time
let diff = realNow changeTime change
bps = changeBps change
beat = changeBeat change + (diff * bps)
nextbeat = fromIntegral $ ((floor beat) + t*2) ((floor beat) `mod` t)
current <- updateBps mBps nextbeat
forkIO $ do waitBeat current (nextbeat 1/32)
f
return()
clocked :: String -> String -> String -> Int -> (BpsChange -> Int -> IO ()) -> IO ()
clocked username clientIp serverIp tpb f =
do mBps <- newEmptyMVar
forkIO $ bpsListen username clientIp serverIp mBps
change <- updateBps mBps 0
realNow <- time
let diff = realNow changeTime change
bps = changeBps change
beat = changeBeat change + (diff * bps)
tick = floor beat * tpb
loop mBps tick
where
loop :: MVar (BpsChange, [BpsChange]) -> Int -> IO ()
loop mBps tick =
do let beat = fromIntegral tick / fromIntegral tpb
current <- updateBps mBps beat
let bps = changeBps current
waitBeat current beat
f current tick
loop mBps (tick + 1)
updateBps :: MVar (BpsChange, [BpsChange]) -> Double -> IO (BpsChange)
updateBps mBps beat = do modifyMVar_ mBps (\x -> return (nextChange x beat))
(current, others) <- readMVar mBps
return current
nextChange :: (BpsChange, [BpsChange]) -> Double -> (BpsChange, [BpsChange])
nextChange changeset@(_, []) _ = changeset
nextChange changeset@(change, change':changes) beat
= if and [beat > 0, beat < changeBeat change']
then changeset
else nextChange (change', changes) beat
bpsListen :: String -> String -> String -> MVar (BpsChange, [BpsChange]) -> IO ()
bpsListen username clientIp serverIp mBps =
do localServer <- udpServer clientIp 0
localPort <- udpPort localServer
let localPortI = fromIntegral $ read $ show localPort
register username clientIp serverIp localPortI
start <- readChange localServer
putMVar mBps (start, [])
bpsListenLoop mBps localServer
bpsListenLoop mBps localServer =
do change <- readChange localServer
addChange mBps change
bpsListenLoop mBps localServer
addChange :: MVar (BpsChange, [BpsChange]) -> BpsChange -> IO ()
addChange mBps newBps | changeBps newBps <= 0 = return ()
| otherwise = modifyMVar_ mBps ( \(x, xs) -> return (x, insert newBps xs) )
register :: String -> String -> String -> Int -> IO (UDP)
register username clientIp serverIp localPort =
do sc <- openUDP serverIp scport
let m = message "/clock/register" [string username,
string clientIp,
int32 localPort,
int32 1
]
sendOSC sc m
return sc
toFloat (Float f) = f
toFloat (Int32 f) = fromIntegral f
readChange :: UDP -> IO (BpsChange)
readChange localServer =
do bundle <- recvBundle localServer
let (Bundle t message) = bundle
let (Message _ (absBeat:bps:_)) = Data.List.head message
absBeatF = fromJust $ d_get absBeat
bpsF = fromJust $ d_get bps
return BpsChange {changeBps = bpsF,
changeTime = t,
changeBeat = absBeatF
}