diff --git a/Data/Recursive/FastSet.hs b/Data/Recursive/FastSet.hs new file mode 100644 index 0000000..d4b87d1 --- /dev/null +++ b/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 = + diff --git a/Data/Recursive/Propagator/Class.hs b/Data/Recursive/Propagator/Class.hs index ce0fd10..25c1ff6 100644 --- a/Data/Recursive/Propagator/Class.hs +++ b/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 diff --git a/Data/Recursive/Propagator/Seminaive.hs b/Data/Recursive/Propagator/Seminaive.hs new file mode 100644 index 0000000..173c36d --- /dev/null +++ b/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 diff --git a/rec-def.cabal b/rec-def.cabal index 09f39a7..80cef3a 100644 --- a/rec-def.cabal +++ b/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