Work in progress

rtree/.gitignore

 actual
+.hspec-failures

rtree/.hspec

+--failure-report .hspec-failures
+--rerun
+--rerun-all-on-success
+--fail-fast

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

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 #-}

rtree/src/Data/RPath.hs

+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')

rtree/test/expected/rlist-drawrtree

+┳━┳━┳━ [1,2,3]
+┃ ┃ ┗━ [1,2]
+┃ ┗━┳━ [1,3]
+┃   ┗━ [1]
+┗━┳━┳━ [2,3]
+  ┃ ┗━ [2]
+  ┗━┳━ [3]
+    ┗━ []

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'

rtree/test/src/Data/Expr.hs

+{-# 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