From 17fc3d3c4658886e1c0a34bfc08c01e1662a250e Mon Sep 17 00:00:00 2001
From: Christian Gram Kalhauge <chrg@dtu.dk>
Date: Fri, 16 Feb 2024 10:08:30 +0100
Subject: [PATCH] Work in progress
---
rtree/.gitignore | 1 +
rtree/.hspec | 4 +
rtree/src/Control/Monad/RTree.hs | 36 +++---
rtree/src/Control/Monad/Reduce.hs | 44 ++-----
rtree/src/Data/RPath.hs | 54 ++++++++
rtree/test/expected/rlist-drawrtree | 8 ++
rtree/test/src/Control/Monad/RTreeSpec.hs | 142 ++++++++--------------
rtree/test/src/Data/Expr.hs | 67 ++++++++++
8 files changed, 209 insertions(+), 147 deletions(-)
create mode 100644 rtree/.hspec
create mode 100644 rtree/src/Data/RPath.hs
create mode 100644 rtree/test/expected/rlist-drawrtree
create mode 100644 rtree/test/src/Data/Expr.hs
diff --git a/rtree/.gitignore b/rtree/.gitignore
index 508061b..6b62980 100644
--- a/rtree/.gitignore
+++ b/rtree/.gitignore
@@ -1 +1,2 @@
actual
+.hspec-failures
diff --git a/rtree/.hspec b/rtree/.hspec
new file mode 100644
index 0000000..3117928
--- /dev/null
+++ b/rtree/.hspec
@@ -0,0 +1,4 @@
+--failure-report .hspec-failures
+--rerun
+--rerun-all-on-success
+--fail-fast
diff --git a/rtree/src/Control/Monad/RTree.hs b/rtree/src/Control/Monad/RTree.hs
index f64aa26..18cc816 100644
--- a/rtree/src/Control/Monad/RTree.hs
+++ b/rtree/src/Control/Monad/RTree.hs
@@ -7,6 +7,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
{-# LANGUAGE UndecidableInstances #-}
-- | A naive implementation of the rtree.
@@ -24,26 +25,29 @@ module Control.Monad.RTree (
extractT,
reduceT,
RTreeN (..),
- unStateT,
flattenT,
-- * Re-exports
module Control.Monad.Reduce,
+ module Data.RPath,
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Reduce
-import Control.Monad.State
+import Control.Monad.Trans
+import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
import Data.Foldable
import Data.Foldable.WithIndex
import Data.Function ((&))
+import Data.RPath
+import qualified Data.Sequence as Seq
-- | The simple RTree
data RTree i
= Done !i
- | Split (RTree i) !(RTree i)
+ | Split ~(RTree i) !(RTree i)
deriving (Functor, Foldable)
instance Applicative RTree where
@@ -60,9 +64,9 @@ instance MonadReduce RTree where
instance FoldableWithIndex RPath RTree where
ifoldMap f =
- [] & fix \rec rs -> \case
- Done i -> f (fromChoiceList (reverse rs)) i
- Split lhs rhs -> rec (False : rs) lhs <> rec (True : rs) rhs
+ Seq.empty & fix \rec rs -> \case
+ Done i -> f (fromChoiceList (toList rs)) i
+ Split lhs rhs -> rec (rs Seq.|> True) lhs <> rec (rs Seq.|> False) rhs
-- | Extract the top value from the RTree.
extract :: RTree i -> i
@@ -96,11 +100,15 @@ drawRTree pp = concat . go
]
-- | Reduce the tree
-reduce :: (MonadPlus m) => (i -> m Bool) -> RTree i -> m i
-reduce p = checkgo
+reduce
+ :: (Monad m)
+ => (i -> m Bool)
+ -> RTree i
+ -> m (Maybe i)
+reduce p = runMaybeT . checkgo
where
checkgo r = do
- t <- p (extract r)
+ t <- lift $ p (extract r)
guard t *> go r
go = \case
Done i -> pure i
@@ -129,9 +137,6 @@ instance (Monad m) => Monad (RTreeT m) where
instance (Monad m) => MonadReduce (RTreeT m) where
split lhs rhs = RTreeT (pure $ SplitN lhs rhs)
-instance (MonadState s m) => MonadState s (RTreeT m) where
- state f = RTreeT (DoneN <$> state f)
-
-- | Extract a value from an @RTreeT@
extractT :: (Monad m) => RTreeT m b -> m b
extractT (RTreeT m) = m >>= extractN
@@ -143,13 +148,6 @@ extractN = \case
SplitN _ rhs -> extractT rhs
{-# INLINE extractN #-}
-unStateT :: (Monad m) => RTreeT (StateT s m) i -> s -> RTreeT m (i, s)
-unStateT (RTreeT (StateT sf)) s = RTreeT do
- (t, s') <- sf s
- case t of
- DoneN i -> pure $ DoneN (i, s')
- SplitN lhs rhs -> pure $ SplitN (unStateT lhs s') (unStateT rhs s')
-
flattenT :: RTreeT Identity i -> RTree i
flattenT (RTreeT (Identity t)) = case t of
DoneN i -> Done i
diff --git a/rtree/src/Control/Monad/Reduce.hs b/rtree/src/Control/Monad/Reduce.hs
index dd40119..ae55bb9 100644
--- a/rtree/src/Control/Monad/Reduce.hs
+++ b/rtree/src/Control/Monad/Reduce.hs
@@ -27,11 +27,6 @@ module Control.Monad.Reduce (
collectNonEmpty,
collectNonEmpty',
- -- * RPath
- RPath,
- fromChoiceList,
- toChoiceList,
-
-- * Helpers
onBoth,
liftMaybe,
@@ -40,13 +35,11 @@ module Control.Monad.Reduce (
import Control.Applicative
import Control.Monad
+import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Maybe
-import Data.Bool
import qualified Data.List.NonEmpty as NE
import Data.Maybe
-import Data.String
-import qualified Data.Vector.Unboxed as VU
-- {- | A reducer should extract itself
-- @
@@ -60,19 +53,16 @@ import qualified Data.Vector.Unboxed as VU
class (Monad m) => MonadReduce m where
{-# MINIMAL (split | check) #-}
- -- | Split the world into the a reduced world (left) without an element and a world
- -- with that element (right). Optionally, labeled with l.
split :: m i -> m i -> m i
split r1 r2 =
check >>= \case
- False -> r1
- True -> r2
+ True -> r1
+ False -> r2
{-# INLINE split #-}
- -- | Check with returns a boolean, that can be used to split the input into a world where
- -- the optional truth assignement is satisfiable and where it is not.
+ -- | Check if the predicate is true.
check :: m Bool
- check = split (pure False) (pure True)
+ check = split (pure True) (pure False)
{-# INLINE check #-}
-- | Infix split.
@@ -135,25 +125,9 @@ onBoth mlhs mrhs fn =
Just rhs -> fn lhs rhs
instance (MonadReduce m) => MonadReduce (StateT s m) where
- check = StateT (\s -> split (pure (False, s)) (pure (True, s)))
+ check = StateT (\s -> split (pure (True, s)) (pure (False, s)))
{-# INLINE check #-}
-{- | A reduction path, can be used as an index into reduction tree.
-Is isomorphic to a list of choices.
--}
-newtype RPath = RPath {rPathAsVector :: VU.Vector Bool}
- deriving (Eq, Ord)
-
--- | Create a reduction path from a list of choices
-fromChoiceList :: [Bool] -> RPath
-fromChoiceList = RPath . VU.fromList
-
--- | Get a list of choices from a reduction path.
-toChoiceList :: RPath -> [Bool]
-toChoiceList = VU.toList . rPathAsVector
-
-instance Show RPath where
- show = show . map (bool '0' '1') . toChoiceList
-
-instance IsString RPath where
- fromString = fromChoiceList . map (== '1')
+instance (MonadReduce m) => MonadReduce (ReaderT r m) where
+ check = ReaderT (\_ -> split (pure True) (pure False))
+ {-# INLINE check #-}
diff --git a/rtree/src/Data/RPath.hs b/rtree/src/Data/RPath.hs
new file mode 100644
index 0000000..9d8bf61
--- /dev/null
+++ b/rtree/src/Data/RPath.hs
@@ -0,0 +1,54 @@
+module Data.RPath (
+ -- * RPath
+ RPath,
+ fromChoiceList,
+ toChoiceList,
+
+ -- * As a predicate
+ toPredicate,
+ toPredicateDebug,
+) where
+
+import Data.Bool
+import Data.IORef (atomicModifyIORef, newIORef)
+import Data.Maybe
+import Data.String
+import qualified Data.Vector.Unboxed as VU
+
+{- | A reduction path, can be used as an index into reduction tree.
+Is isomorphic to a list of choices.
+-}
+newtype RPath = RPath {rPathAsVector :: VU.Vector Bool}
+ deriving (Eq, Ord)
+
+toPredicate :: RPath -> IO (i -> IO Bool)
+toPredicate (RPath v) = do
+ idx <- newIORef (-1)
+ pure . const $ do
+ idx' <- atomicModifyIORef idx (\n -> (n + 1, n))
+ pure (fromMaybe True (v VU.!? idx'))
+
+toPredicateDebug :: (Show i) => RPath -> IO (i -> IO Bool)
+toPredicateDebug rp@(RPath v) = do
+ idx <- newIORef (-1)
+ pure $ \i -> do
+ idx' <- atomicModifyIORef idx (\n -> (n + 1, n))
+ print (rp, idx', i)
+ pure (fromMaybe True (v VU.!? idx'))
+
+-- | Create a reduction path from a list of choices
+fromChoiceList :: [Bool] -> RPath
+fromChoiceList = RPath . VU.fromList
+
+-- | Get a list of choices from a reduction path.
+toChoiceList :: RPath -> [Bool]
+toChoiceList = VU.toList . rPathAsVector
+
+instance Show RPath where
+ show = show . map (bool '0' '1') . toChoiceList
+
+instance Read RPath where
+ readsPrec i s = [(fromString a, r) | (a, r) <- readsPrec i s]
+
+instance IsString RPath where
+ fromString = fromChoiceList . map (== '1')
diff --git a/rtree/test/expected/rlist-drawrtree b/rtree/test/expected/rlist-drawrtree
new file mode 100644
index 0000000..71b5ad7
--- /dev/null
+++ b/rtree/test/expected/rlist-drawrtree
@@ -0,0 +1,8 @@
+┳â”┳â”┳┠[1,2,3]
+┃ ┃ ┗┠[1,2]
+┃ â”—â”┳┠[1,3]
+┃ ┗┠[1]
+â”—â”┳â”┳┠[2,3]
+ ┃ ┗┠[2]
+ â”—â”┳┠[3]
+ â”—â” []
diff --git a/rtree/test/src/Control/Monad/RTreeSpec.hs b/rtree/test/src/Control/Monad/RTreeSpec.hs
index 79a8d12..b4433f1 100644
--- a/rtree/test/src/Control/Monad/RTreeSpec.hs
+++ b/rtree/test/src/Control/Monad/RTreeSpec.hs
@@ -6,11 +6,11 @@
module Control.Monad.RTreeSpec where
-import Control.Applicative
import Control.Monad.Identity (Identity (runIdentity))
import Control.Monad.RTree
import Control.Monad.State
import Control.Monad.Trans.Maybe
+import Data.Expr as Expr
import Data.Foldable
import Data.Functor
import qualified Data.Map.Strict as Map
@@ -27,71 +27,11 @@ rBool = split (pure False) (pure True)
rList :: (MonadReduce m) => [a] -> m [a]
rList = collect (given $>)
-data Expr
- = Var !String
- | Cnt !Int
- | Opr !Expr !Expr
- | Let !String !Expr !Expr
- deriving (Show, Eq)
-
-rExpr
- :: (MonadReducePlus m, MonadState (Map.Map String (Either String Expr)) m)
- => Expr
- -> m Expr
-rExpr e = case e of
- Cnt i -> do
- given $> Cnt i
- Var k -> do
- v <- liftMaybe =<< gets (Map.lookup k)
- case v of
- Left k' -> given $> Var k'
- Right x -> rExpr x
- Opr e1 e2 -> onBoth (rExpr e1) (rExpr e2) \e1' e2' ->
- case (e1', e2') of
- (Cnt a, Cnt b) -> pure (Cnt (a + b)) <| pure (Opr e1' e2')
- _ow -> pure $ Opr e1' e2'
- Let k e1 e2 -> do
- e1' <- rExpr e1
- split
- (modifyIn (Map.insert k (Right e1')) $ rExpr e2)
- (Let k e1' <$> modifyIn (Map.insert k (Left k)) (rExpr e2))
-
-modifyIn :: (Alternative m, MonadState s m) => (s -> s) -> m b -> m b
-modifyIn fn mx = do
- s <- get
- put (fn s)
- x <- optional mx
- put s
- liftMaybe x
-
-prettyExprS :: Int -> Expr -> String -> String
-prettyExprS d = \case
- Var x -> showString x
- Opr l r ->
- showParen (d > addPrec) $
- prettyExprS (addPrec + 1) l
- . showString " + "
- . prettyExprS (addPrec + 1) r
- Cnt i -> shows i
- Let x e1 e2 ->
- showParen (d > letPrec) $
- showString x
- . showString " := "
- . prettyExprS (letPrec + 1) e1
- . showString "; "
- . prettyExprS letPrec e2
- where
- addPrec = 2
- letPrec = 1
-
-prettyExprWithConfig :: (Maybe Expr, Map.Map String (Either String Expr)) -> String
-prettyExprWithConfig (e, _) =
- maybe "⊥" (flip (prettyExprS 0) "") e
-
spec :: Spec
spec = do
rtreeSpec
rtreeTSpec
+ examplesSpec
rtreeTSpec :: Spec
rtreeTSpec = describe "RTreeT" do
@@ -102,29 +42,6 @@ rtreeTSpec = describe "RTreeT" do
it "should input like RTree" do
equiv (rList [1, 2, 3 :: Int]) inputs (toList :: RTreeT Identity [Int] -> [[Int]])
- describe "rExpr" do
- let handle str e = describe str do
- let me = runMaybeT $ rExpr e
- it "should extract" do
- extract (runStateT me Map.empty)
- `shouldBe` (Just e, Map.empty)
- it "should draw the same" do
- golden
- ("test/expected/" <> str)
- (drawRTree prettyExprWithConfig (runStateT me Map.empty))
-
- handle "small-opr-expr" $
- Opr (Cnt 1) (Cnt 2)
-
- handle "small-let-expr" $
- Let "x" (Cnt 1) (Opr (Cnt 2) (Var "x"))
-
- handle "double-let-expr" $
- Let "x" (Cnt 1) (Let "y" (Cnt 2) (Opr (Var "x") (Var "y")))
-
- handle "double-overloading-let-expr" $
- Let "x" (Cnt 1) (Let "x" (Cnt 2) (Opr (Var "x") (Var "x")))
-
equiv
:: (Show b, MonadReduce x, MonadReduce y, Eq b)
=> (forall m. (MonadReduce m) => m a)
@@ -154,12 +71,51 @@ rtreeSpec = describe "RTree" do
describe "iinputs" do
it "should get all inputs from rList" do
iinputs (rList [1, 2, 3 :: Int])
- `shouldBe` [ ("000", [])
- , ("001", [3])
- , ("010", [2])
- , ("011", [2, 3])
- , ("100", [1])
- , ("101", [1, 3])
- , ("110", [1, 2])
- , ("111", [1, 2, 3])
+ `shouldBe` [ ("111", [])
+ , ("110", [3])
+ , ("101", [2])
+ , ("100", [2, 3])
+ , ("011", [1])
+ , ("010", [1, 3])
+ , ("001", [1, 2])
+ , ("000", [1, 2, 3])
]
+
+ describe "drawRTree" do
+ it "should pretty print it's tree" do
+ golden
+ "test/expected/rlist-drawrtree"
+ (drawRTree show (rList [1, 2, 3 :: Int]))
+
+examplesSpec :: Spec
+examplesSpec = do
+ describe "rExpr" do
+ handle "small-opr-expr" $
+ Opr (Cnt 1) (Cnt 2)
+
+ handle "small-let-expr" $
+ Let "x" (Cnt 1) (Opr (Cnt 2) (Var "x"))
+
+ handle "double-let-expr" $
+ Let "x" (Cnt 1) (Let "y" (Cnt 2) (Opr (Var "x") (Var "y")))
+
+ handle "double-overloading-let-expr" $
+ Let "x" (Cnt 1) (Let "x" (Cnt 2) (Opr (Var "x") (Var "x")))
+ where
+ handle str e = describe (str <> " (" <> prettyExprS 0 e ")") do
+ let me = runMaybeT $ Expr.rExpr e
+ it "should extract" do
+ extract (runStateT me Map.empty)
+ `shouldBe` (Just e, Map.empty)
+
+ let re = evalStateT me Map.empty
+
+ it "should draw the same" do
+ golden
+ ("test/expected/" <> str)
+ (drawRTree (maybe "⊥" (flip (prettyExprS 0) "")) re)
+
+ it "should reduce like iinputs" do
+ forM_ (iinputs re) \(ii, e') -> do
+ p <- toPredicate ii
+ reduce p re `shouldReturn` Just e'
diff --git a/rtree/test/src/Data/Expr.hs b/rtree/test/src/Data/Expr.hs
new file mode 100644
index 0000000..48ea44d
--- /dev/null
+++ b/rtree/test/src/Data/Expr.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Data.Expr where
+
+import Control.Applicative
+import Control.Monad.Reduce
+import Control.Monad.State
+import Data.Functor
+import qualified Data.Map.Strict as Map
+
+data Expr
+ = Var !String
+ | Cnt !Int
+ | Opr !Expr !Expr
+ | Let !String !Expr !Expr
+ deriving (Show, Eq)
+
+rExpr
+ :: (MonadReducePlus m, MonadState (Map.Map String (Either String Expr)) m)
+ => Expr
+ -> m Expr
+rExpr e = case e of
+ Cnt i -> do
+ given $> Cnt i
+ Var k -> do
+ v <- liftMaybe =<< gets (Map.lookup k)
+ case v of
+ Left k' -> given $> Var k'
+ Right x -> rExpr x
+ Opr e1 e2 -> onBoth (rExpr e1) (rExpr e2) $ \e1' e2' ->
+ case (e1', e2') of
+ (Cnt a, Cnt b) -> pure (Cnt (a + b)) <| pure (Opr e1' e2')
+ _ow -> pure $ Opr e1' e2'
+ Let k e1 e2 -> do
+ e1' <- rExpr e1
+ split
+ (modifyIn (Map.insert k (Right e1')) $ rExpr e2)
+ (Let k e1' <$> modifyIn (Map.insert k (Left k)) (rExpr e2))
+
+modifyIn :: (Alternative m, MonadState s m) => (s -> s) -> m b -> m b
+modifyIn fn mx = do
+ s <- get
+ put (fn s)
+ x <- optional mx
+ put s
+ liftMaybe x
+
+prettyExprS :: Int -> Expr -> String -> String
+prettyExprS d = \case
+ Var x -> showString x
+ Opr l r ->
+ showParen (d > addPrec) $
+ prettyExprS (addPrec + 1) l
+ . showString " + "
+ . prettyExprS (addPrec + 1) r
+ Cnt i -> shows i
+ Let x e1 e2 ->
+ showParen (d > letPrec) $
+ showString x
+ . showString " := "
+ . prettyExprS (letPrec + 1) e1
+ . showString "; "
+ . prettyExprS letPrec e2
+ where
+ addPrec = 2
+ letPrec = 1
--
GitLab