module Nettle.FRPControl.AFRPUtils
(
Nil,
(:::),
Rep (..),
SFInput(..),
SensorChans,
SFOutput(..),
Actuators,
sfDriver
) where
import Control.Concurrent
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import Control.Monad
import Nettle.FRPControl.AFRP
import Data.Monoid hiding (All)
data Nil
data (:::) x xs = (:::) (x, xs)
infixr 5 :::
data Rep a where
RNil :: Rep Nil
RCons :: Rep b -> Rep (a ::: b)
type family SFInput t
type instance SFInput Nil = ()
type instance SFInput ((:::) x xs) = (Maybe x, SFInput xs)
missing :: Rep a -> SFInput a
missing RNil = ()
missing (RCons rb) = (Nothing, missing rb)
type family SensorChans t
type instance SensorChans Nil = ()
type instance SensorChans (a ::: bs) = (Chan a, SensorChans bs)
mkSensor :: Rep s -> SensorChans s -> IO (Chan (SFInput s))
mkSensor RNil () = newChan
mkSensor (RCons rb) (aCh, bChs) =
do bCh <- mkSensor rb bChs
multiplexChanPair rb aCh bCh
multiplexChanPair :: Rep b ->
Chan a ->
Chan (SFInput b) ->
IO (Chan (SFInput (a ::: b)))
multiplexChanPair RNil aCh _ = do
abCh <- newChan
forkIO $ forever (readChan aCh >>= writeChan abCh . (\a -> (Just a, ())))
return abCh
multiplexChanPair rb aCh bCh = do
abCh <- newChan
forkIO $ readWriter aCh (\a -> (Just a, missing rb)) abCh
forkIO $ readWriter bCh (\b -> (Nothing, b)) abCh
return abCh
where readWriter srcCh f destCh =
forever (readChan srcCh >>= writeChan destCh . f)
type family SFOutput t
type instance SFOutput Nil = ()
type instance SFOutput (a ::: bs) = (a, SFOutput bs)
type family Actuators t
type instance Actuators Nil = ()
type instance Actuators (a ::: bs) = (a -> IO (), Actuators bs)
actuateVector :: Rep s -> Actuators s -> SFOutput s -> IO ()
actuateVector RNil () ()
= return ()
actuateVector (RCons rb) (actA, actsB) (a, b)
= actA a >> actuateVector rb actsB b
sfDriver :: Rep s
-> SensorChans s
-> Rep t
-> Actuators t
-> SF (SFInput s) (SFOutput t)
-> IO ()
sfDriver repS chS repT chT sf =
do
sensorCh <- mkSensor repS chS
let actuator = actuateVector repT chT
let sense = readChan sensorCh
let a0 = missing repS
let aMissing = Just (missing repS)
sfDriverAux a0 sense aMissing actuator sf
sfDriverAux :: a -> IO a -> Maybe a -> (b -> IO ()) -> SF a b -> IO ()
sfDriverAux a0 sensor clockInput actuator sf = do
lastSenseTimeVar <- newEmptyMVar
inCh <- newChan :: IO (Chan (Maybe a))
let initiator = initReact lastSenseTimeVar
let sensor'' = sensor' inCh lastSenseTimeVar
forkIO $ genClockSignal inCh
forkIO $ genNormalSignal inCh
reactimate initiator sensor'' actuator' sf
where
initReact lastSenseTimeVar =
do
t <- getCurrentTime
putMVar lastSenseTimeVar t
return a0
sensor' ch lastSenseTimeVar _ =
do
ma <- readChan ch
t' <- getCurrentTime
t <- swapMVar lastSenseTimeVar t'
let delta = fromRational (toRational (diffUTCTime t' t))
return (delta, ma)
actuator' changed b = actuator b >> return False
genClockSignal ch =
forever (threadDelay clockCycle >> writeChan ch clockInput)
where clockCycle = 1000
genNormalSignal ch = forever (sensor >>= writeChan ch . Just)