moduleNetwork.Netclock.ClientwhereimportSound.OpenSoundControlimportControl.Concurrent(threadDelay)importSound.OpenSoundControlimportControl.Concurrent.MVarimportControl.Concurrent(forkIO)importData.ListimportData.MaybeimportqualifiedNetwork.SocketasNimportData.FunctionimportControl.MonaddataBpsChange=BpsChange{changeBps::Double,changeTime::Double,changeBeat::Double}instanceShowBpsChangewhereshowchange="bps "++show(changeBpschange)++" time "++show(changeTimechange)++" beat "++show(changeBeatchange)-- Bps changes are ordered by beat value, and considered the same if-- they happen at the same time.instanceEqBpsChangewhere(==)=(==)`on`changeBeatinstanceOrdBpsChangewherecompare=compare`on`changeBeat-- Wait until the the given beat value.waitBeat::BpsChange->Double->IO()waitBeatchangebeat=doletlogicalTime=changeTimechange+((beat-changeBeatchange)/changeBpschange)realNow<-utcrletdiff=logicalTime-realNowletdelay=floor$diff*1000000.0when(diff>0)$threadDelaydelayreturn()clocked::String->String->String->Int->(Int->IO())->IO()clockedusernameclientIpserverIptpbf=domBps<-newEmptyMVarforkIO$bpsListenusernameclientIpserverIpmBpschange<-updateBpsmBps0realNow<-utcrletdiff=realNow-changeTimechangebps=changeBpschangebeat=changeBeatchange+(diff*bps)tick=floorbeat*tpbforkIO$loopmBpstickreturn()whereloop::MVar(BpsChange,[BpsChange])->Int->IO()loopmBpstick=doletbeat=fromIntegraltick/fromIntegraltpbcurrent<-updateBpsmBpsbeatwaitBeatcurrentbeatftickloopmBps(tick+1)updateBps::MVar(BpsChange,[BpsChange])->Double->IO(BpsChange)updateBpsmBpsbeat=domodifyMVar_mBps(\x->return(nextChangexbeat))(current,others)<-readMVarmBpsreturncurrentnextChange::(BpsChange,[BpsChange])->Double->(BpsChange,[BpsChange])nextChangechangeset@(_,[])_=changesetnextChangechangeset@(change,change':changes)beat=ifand[beat>0,beat<changeBeatchange']thenchangesetelsenextChange(change',changes)beatbpsListen::String->String->String->MVar(BpsChange,[BpsChange])->IO()bpsListenusernameclientIpserverIpmBps=dolocalServer<-udpServerclientIp0localPort<-udpPortlocalServer-- hack to get the integer port number outletlocalPortI=fromIntegral$read$showlocalPortregisterusernameclientIpserverIplocalPortIstart<-readChangelocalServerputMVarmBps(start,[])bpsListenLoopmBpslocalServerbpsListenLoopmBpslocalServer=dochange<-readChangelocalServeraddChangemBpschangebpsListenLoopmBpslocalServeraddChange::MVar(BpsChange,[BpsChange])->BpsChange->IO()addChangemBpsnewBps|changeBpsnewBps<=0=return()|otherwise=modifyMVar_mBps(\(x,xs)->return(x,insertnewBpsxs))register::String->String->String->Int->IO(UDP)registerusernameclientIpserverIplocalPort=dosc<-openUDPserverIp57120letm=Message"/clock/register"[Stringusername,StringclientIp,IntlocalPort,Int1]sendscmreturnsctoFloat(Floatf)=ftoFloat(Intf)=fromIntegralfreadChangelocalServer=dobundle<-recvlocalServerlet(Bundletmessage)=bundlelet(Message_(absBeat:bps:_))=headmessageabsBeatF=toFloatabsBeatbpsF=toFloatbpslettime=(as_utcrt)returnBpsChange{changeBps=bpsF,changeTime=time,changeBeat=absBeatF}