module Control.Monad.Adaptive
( Adaptive
, Changeable
, Modifiable
, readMod
, InM(..)
, change
, propagate
, run
, inCh
, NewMod(..)
, newMod
) where
import Prelude
import Control.Monad(ap,unless)
import Control.Monad.Adaptive.MonadUtil
import Control.Monad.Adaptive.Ref
import qualified Control.Monad.Adaptive.OrderedList as OL
import Control.Monad.Adaptive.OrderedList(OrderedList)
import qualified Control.Monad.Adaptive.PriorityQueue as PQ
import Control.Monad.Adaptive.PriorityQueue(PriorityQueue)
class InM m' where
inM :: Ref m r => m a -> m' m r a
class (Monad (n m r), Ref m r) => NewMod n m r where
newModBy :: (a -> a -> Bool) -> Changeable m r a -> n m r (Modifiable m r a)
newMod :: (Eq a, NewMod n m r) =>
Changeable m r a -> n m r (Modifiable m r a)
change :: Ref m r => Modifiable m r a -> a -> Adaptive m r ()
propagate :: Ref m r => Adaptive m r ()
readMod :: Ref m r => Modifiable m r a -> Changeable m r a
run :: Ref m r => Adaptive m r a -> m a
inCh :: Ref m r => Changeable m r a -> Adaptive m r a
type ReComp m r = (Adaptive m r (), TimeStamp m r, TimeStamp m r)
startTime (_,s,_) = s
type TimeStamp m r = OL.Record m r ()
newtype Adaptive m r a =
Ad ((r (PriorityQueue (ReComp m r)), r (TimeStamp m r)) ->
OrderedList m r () a)
newtype Changeable m r a = Ch (K (Adaptive m r ()) a)
type K b a = (a -> b) -> b
newtype Modifiable m r a = Mo (r a, r (a -> Adaptive m r ()), r [ReComp m r])
cont :: Ref m r =>
((a -> Adaptive m r ()) -> Adaptive m r ()) -> Changeable m r a
cont m = Ch m
deCh (Ch m) = m
deAd (Ad m) = m
inAd :: Ref m r => Adaptive m r a -> Changeable m r a
inAd m = Ch $ (m >>=)
class InOL m' where
inOL :: Ref m r => OrderedList m r () b -> m' m r b
instance InOL Adaptive where
inOL m = Ad $ const m
instance InOL Changeable where
inOL m = inAd (inOL m)
instance Ref m r => Ref (Changeable m r) r where
newRef v = inM $ newRef v
readRef x = inM $ readRef x
writeRef x v = inM $ writeRef x v
instance Ref m r => Monad (Changeable m r) where
return a = Ch $ \k -> k a
Ch m >>= f = Ch $ \k -> m $ \a -> deCh (f a) k
instance Ref m r => Functor (Changeable m r) where
fmap f m = m >>= return . f
instance Ref m r => Ref (Adaptive m r) r where
newRef v = inM $ newRef v
readRef x = inM $ readRef x
writeRef x v = inM $ writeRef x v
instance Ref m r => Monad (Adaptive m r) where
return a = Ad $ \e -> return a
Ad m >>= f = Ad $ \e -> m e >>= \a -> deAd (f a) e
instance Ref m r => Functor (Adaptive m r) where
fmap f m = m >>= return . f
readMod (Mo (r,chg,es)) = do
start <- inAd stepTime
cont $ \k -> do
let reader = do readRef r >>= k
now <- readCurrentTime
mapRef ((reader,start,now):) es
reader
pqRef :: Ref m r => Adaptive m r (r (PriorityQueue (ReComp m r)))
pqRef = Ad $ \ (pq,ct) -> return pq
readPq :: Ref m r => Adaptive m r (PriorityQueue (ReComp m r))
readPq = pqRef >>= readRef
writePq a = pqRef >>= flip writeRef a
ctRef :: Ref m r => Adaptive m r (r (TimeStamp m r))
ctRef = Ad $ \ (pq,ct) -> return ct
readCurrentTime :: Ref m r => Adaptive m r (TimeStamp m r)
readCurrentTime = ctRef >>= readRef
writeCurrentTime a = ctRef >>= flip writeRef a
stepTime :: Ref m r => Adaptive m r (TimeStamp m r)
stepTime = do
readCurrentTime >>= inOL . flip OL.insert () >>= writeCurrentTime
readCurrentTime
instance InM Changeable where
inM m = Ch $ (inM m >>=)
instance InM Adaptive where
inM m = Ad $ const (OL.inM m)
change (Mo (r,changeR,es)) a = do
chg <- readRef changeR
chg a
propagate = do
let prop = do
pq <- readPq
case PQ.min pq of
Nothing -> return ()
Just ((reader,start,stop),pq') -> do
writePq pq'
unlessM (inOL (OL.deleted start)) $ do
inOL (OL.spliceOut start stop)
writeCurrentTime start
reader
prop
now <- readCurrentTime
prop
writeCurrentTime now
run m = OL.run $ do
pq <- newRef PQ.empty
ct <- OL.base >>= newRef
deAd m (pq,ct)
inCh (Ch m) = do
x <- newRef (error "inCh")
m (writeRef x)
readRef x
instance EqRef r => Eq (Modifiable m r a) where
(Mo (r1,_,_)) == (Mo (r2,_,_)) = eqRef r1 r2
newMod = newModBy (==)
instance Ref m r => NewMod Changeable m r where
newModBy c ch = inAd $ newModBy c ch
insertPQ :: Ref m r =>
r [ReComp m r] -> Adaptive m r ()
insertPQ esR = do
es <- readRef esR
pqR <- pqRef
readRef pqR >>= ins es >>= writeRef pqR
where
ins [] pq = return pq
ins (e:es) pq = PQ.insertM (\x y -> inOL $
OL.order (startTime x) (startTime y))
e pq >>= ins es
instance Ref m r => NewMod Adaptive m r where
newModBy cmp c = do
m <- newRef (error "newMod")
changeR <- newRef (error "changeR")
es <- newRef []
let writeFirst v = do
writeRef m v
now <- stepTime
writeRef changeR (writeAgain now)
writeAgain t v = do
v' <- readRef m
unless (cmp v' v) $ do
writeRef m v
insertPQ es
writeRef es []
writeCurrentTime t
writeRef changeR writeFirst
inCh $ do
v <- c
write <- readRef changeR
inAd $ write v
return (Mo (m, changeR, es))