seminaive propagators

Data/Recursive/FastSet.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, ScopedTypeVariables #-}
+module Data.Recursive.FastSet
+where
+
+import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.Map.Merge.Lazy
+import Data.Set
+import Data.Coerce
+
+import Data.POrder
+import Data.Recursive.R.Internal
+import Data.Recursive.Propagator.Seminaive
+import qualified Data.Recursive.Propagator.Seminaive as Seminaive
+import Data.Recursive.Propagator.Class
+
+newtype FastSet a = FastSet { fastSet :: Set a }
+  deriving (Show, Eq, Ord)
+
+instance Eq a => POrder (FastSet a)
+instance Eq a => Bottom (FastSet a) where bottom = FastSet empty
+
+instance Ord a => ChangeAction (S.Set a) (FastSet a) where
+  update = coerce union
+  kickoff = fastSet
+  noChange dx x y = coerce isSubsetOf dx x
+
+instance Ord a => Change (FastSet a) where type Delta (FastSet a) = Set a
+
+instance Ord a => HasPropagator (FastSet a) where
+  type Prop (FastSet a) = Seminaive.Prop (FastSet a)
+
+rEmpty :: Ord a => R (FastSet a)
+rEmpty = mkR bottom
+
+rInsert :: Ord a => a -> R (FastSet a) -> R (FastSet a)
+-- We could remove x from the delta to a here, but it shouldn't be necessary.
+rInsert x = defR1 $ lift1simple (coerce $ S.insert x) (S.delete x)
+
+rFilter :: Ord a => (a -> Bool) -> R (FastSet a) -> R (FastSet a)
+rFilter f = defR1 $ lift1simple (coerce $ S.filter f) (S.filter f)
+
+rUnion :: forall a. Ord a => R (FastSet a) -> R (FastSet a) -> R (FastSet a)
+rUnion = defR2 $ lift2 init f1 f2
+  where
+    init :: FastSet a -> FastSet a -> (FastSet a, (FastSet a, FastSet a))
+    init a b = (coerce S.union a b, (a, b))
+    f1, f2 :: Update (FastSet a) -> (FastSet a, FastSet a) -> (Set a, (FastSet a, FastSet a))
+    f1 ua (a,b) = (delta ua `S.difference` fastSet b, (new ua, b))
+    f2 ub (a,b) = (delta ub `S.difference` fastSet a, (a, new ub))
+
+-- I can find a better way to do this.
+rUnions :: Ord a => [R (FastSet a)] -> R (FastSet a)
+rUnions = Prelude.foldl rUnion rEmpty
+
+rFromList :: Ord a => [a] -> R (FastSet a)
+rFromList = mkR . FastSet . S.fromList
+
+
+-- Okay, let's try it out!
+trans :: forall a. Ord a => [(a, a)] -> M.Map a [a]
+trans edges = M.map (S.toList . fastSet . getR) sets
+  where
+    g = M.fromListWith (<>) $
+        [(v2, []) | (_, v2) <- edges] ++
+        [(v1, [v2]) | (v1, v2) <- edges]
+    sets :: M.Map a (R (FastSet a))
+    sets = M.map reachable g
+    reachable vs = rUnion (rFromList vs) $ rUnions [ sets M.! v' | v' <- vs ]
+
+
+-- -- Let's do the same for maps.
+-- instance (Eq k, POrder v) => POrder (M.Map k v)
+-- -- NB. being mapped to bottom is the same as being absent.
+-- instance (Eq k, POrder v) => Bottom (M.Map k v) where bottom = M.empty
+-- instance (Ord k, Bottom v, ChangeAction dv v) => ChangeAction (M.Map k dv) (M.Map k v) where
+--   update = merge (mapMissing g) (mapMissing $ const id) (zipWithMatched $ const update)
+--     where g k da = update da bottom
+--   diff y x = 
+

Data/Recursive/Propagator/Class.hs

@@ -14,6 +14,7 @@ import Data.Coerce
 import qualified Data.Recursive.Propagator.Naive as Naive
 import Data.Recursive.Propagator.P2
 import Data.POrder
+import qualified Data.Recursive.Propagator.Seminaive as Seminaive
 
 -- | The Propagator class defines some functions shared by different propagator
 -- implementations. This backs the generic "Data.Recursive.R.Internal" wrapper.
@@ -28,6 +29,11 @@ instance Bottom x => Propagator (Naive.Prop x) x where
     newConstProp = Naive.newProp
     readProp = Naive.readProp
 
+instance (Bottom a, Seminaive.Change a) => Propagator (Seminaive.Prop a) a where
+    newProp = Seminaive.newProp bottom
+    newConstProp = Seminaive.newProp
+    readProp = Seminaive.readProp
+
 instance Propagator PBool Bool where
     newProp = coerce newP2
     newConstProp False = coerce newP2

Data/Recursive/Propagator/Seminaive.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}
+module Data.Recursive.Propagator.Seminaive
+where
+
+import qualified Data.Set as S
+import Data.Set (Set)
+import Control.Monad (unless)
+import Control.Concurrent.MVar
+import Data.IORef
+-- import Data.Maybe
+
+import Data.POrder
+
+class (Eq a, Bottom a) => ChangeAction da a where
+  -- laws:
+  -- 1. update (kickoff x) bottom == x
+  -- 2. (update dx x == y) implies ((x == y) == noChange dx x y)
+  update :: da -> a -> a
+  kickoff :: a -> da
+  noChange :: da -> a -> a -> Bool
+  noChange dx x y = x == y
+class ChangeAction (Delta a) a => Change a where type Delta a
+
+-- Might want to make this strict in both fields?
+data Update a = Update { delta :: Delta a, new :: a }
+
+-- Change propagator.
+-- We assume each propagator has exactly one writer.
+data Prop a = Prop
+  { cell :: IORef a
+  , lock :: MVar ()
+  , listeners :: IORef [Update a -> IO ()]
+  }
+
+newProp :: a -> IO (Prop a)
+newProp x = do
+  cell <- newIORef x
+  lock <- newMVar ()
+  notify <- newIORef []
+  pure $ Prop cell lock notify
+
+updateProp :: Change a => Prop a -> IO (Delta a) -> IO ()
+updateProp (Prop cell lock notify) func = do
+  () <- takeMVar lock
+  old <- readIORef cell
+  delta <- func
+  let new = update delta old
+  let nop = noChange delta old new
+  let u = Update delta new
+  unless nop $ writeIORef cell new
+  putMVar lock ()
+  unless nop $ mapM_ ($ u) =<< readIORef notify
+
+readProp = readIORef . cell
+
+watchProp :: Change a => Prop a -> (Update a -> IO ()) -> IO ()
+watchProp (Prop _ _ notify) f = atomicModifyIORef' notify (\fs -> (f:fs, ()))
+
+initProp :: Change a => Prop a -> IO a -> IO ()
+initProp p init = updateProp p $ do
+                    old <- readProp p
+                    new <- init
+                    if old == bottom
+                    then pure (kickoff new)
+                    else error "Tried to re-initialize a propagator!"
+
+changeProp :: Change a => Prop a -> Delta a -> IO ()
+changeProp p delta = updateProp p (pure delta)
+
+-- "simple" versions assume the derivative doesn't need access to anything but
+-- deltas.
+lift1simple :: (Change a, Change b) =>
+               (a -> b) -> (Delta a -> Delta b) ->
+               Prop a -> Prop b -> IO ()
+lift1simple f df p1 p = do
+  watchProp p1 $ changeProp p . df . delta
+  initProp p $ f <$> readProp p1
+
+lift2simple :: (Change a, Change b, Change c) =>
+               (a -> b -> c) -> (Delta a -> Delta c) -> (Delta b -> Delta c) ->
+               Prop a -> Prop b -> Prop c -> IO ()
+lift2simple f df1 df2 p1 p2 p = do
+  watchProp p1 $ changeProp p . df1 . delta
+  watchProp p2 $ changeProp p . df2 . delta
+  initProp p $ f <$> readProp p1 <*> readProp p2
+
+-- Regular versions need an explicit state type.
+updateRefWith :: IORef s -> (a -> s -> (b, s)) -> a -> IO b
+updateRefWith ref f a = do (b, s) <- f a <$> readIORef ref
+                           b <$ writeIORef ref s
+
+lift1 :: (Change a, Change b) =>
+         (a -> (b, state)) ->
+         (Update a -> state -> (Delta b, state)) ->
+         Prop a -> Prop b -> IO ()
+lift1 f df p1 p = do
+  state <- newIORef undefined
+  initProp p $ do
+    watchProp p1 $ updateProp p . updateRefWith state df
+    (b, s) <- f <$> readProp p1
+    b <$ writeIORef state s
+
+lift2 :: (Change a, Change b, Change c) =>
+         (a -> b -> (c, state)) ->
+         (Update a -> state -> (Delta c, state)) ->
+         (Update b -> state -> (Delta c, state)) ->
+         Prop a -> Prop b -> Prop c -> IO ()
+lift2 f df1 df2 p1 p2 p = do
+  state <- newIORef undefined
+  initProp p $ do
+    watchProp p1 $ updateProp p . updateRefWith state df1
+    watchProp p2 $ updateProp p . updateRefWith state df2
+    (c, s) <- f <$> readProp p1 <*> readProp p2
+    c <$ writeIORef state s

rec-def.cabal

@@ -63,6 +63,8 @@ library
     exposed-modules: Data.Recursive.Propagator.Naive
     exposed-modules: Data.Recursive.Propagator.Class
     exposed-modules: Data.Recursive.Propagator.P2
+    exposed-modules: Data.Recursive.Propagator.Seminaive
+    exposed-modules: Data.Recursive.FastSet
 
     build-depends:    base >= 4.9 && < 5
     build-depends:    containers >= 0.5.11 && < 0.7