Skip to content
Snippets Groups Projects
Commit 17fc3d3c authored by chrg's avatar chrg
Browse files

Work in progress

parent 1b00c98f
No related branches found
No related tags found
No related merge requests found
actual actual
.hspec-failures
--failure-report .hspec-failures
--rerun
--rerun-all-on-success
--fail-fast
...@@ -7,6 +7,7 @@ ...@@ -7,6 +7,7 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
-- | A naive implementation of the rtree. -- | A naive implementation of the rtree.
...@@ -24,26 +25,29 @@ module Control.Monad.RTree ( ...@@ -24,26 +25,29 @@ module Control.Monad.RTree (
extractT, extractT,
reduceT, reduceT,
RTreeN (..), RTreeN (..),
unStateT,
flattenT, flattenT,
-- * Re-exports -- * Re-exports
module Control.Monad.Reduce, module Control.Monad.Reduce,
module Data.RPath,
) where ) where
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
import Control.Monad.Identity import Control.Monad.Identity
import Control.Monad.Reduce 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
import Data.Foldable.WithIndex import Data.Foldable.WithIndex
import Data.Function ((&)) import Data.Function ((&))
import Data.RPath
import qualified Data.Sequence as Seq
-- | The simple RTree -- | The simple RTree
data RTree i data RTree i
= Done !i = Done !i
| Split (RTree i) !(RTree i) | Split ~(RTree i) !(RTree i)
deriving (Functor, Foldable) deriving (Functor, Foldable)
instance Applicative RTree where instance Applicative RTree where
...@@ -60,9 +64,9 @@ instance MonadReduce RTree where ...@@ -60,9 +64,9 @@ instance MonadReduce RTree where
instance FoldableWithIndex RPath RTree where instance FoldableWithIndex RPath RTree where
ifoldMap f = ifoldMap f =
[] & fix \rec rs -> \case Seq.empty & fix \rec rs -> \case
Done i -> f (fromChoiceList (reverse rs)) i Done i -> f (fromChoiceList (toList rs)) i
Split lhs rhs -> rec (False : rs) lhs <> rec (True : rs) rhs Split lhs rhs -> rec (rs Seq.|> True) lhs <> rec (rs Seq.|> False) rhs
-- | Extract the top value from the RTree. -- | Extract the top value from the RTree.
extract :: RTree i -> i extract :: RTree i -> i
...@@ -96,11 +100,15 @@ drawRTree pp = concat . go ...@@ -96,11 +100,15 @@ drawRTree pp = concat . go
] ]
-- | Reduce the tree -- | Reduce the tree
reduce :: (MonadPlus m) => (i -> m Bool) -> RTree i -> m i reduce
reduce p = checkgo :: (Monad m)
=> (i -> m Bool)
-> RTree i
-> m (Maybe i)
reduce p = runMaybeT . checkgo
where where
checkgo r = do checkgo r = do
t <- p (extract r) t <- lift $ p (extract r)
guard t *> go r guard t *> go r
go = \case go = \case
Done i -> pure i Done i -> pure i
...@@ -129,9 +137,6 @@ instance (Monad m) => Monad (RTreeT m) where ...@@ -129,9 +137,6 @@ instance (Monad m) => Monad (RTreeT m) where
instance (Monad m) => MonadReduce (RTreeT m) where instance (Monad m) => MonadReduce (RTreeT m) where
split lhs rhs = RTreeT (pure $ SplitN lhs rhs) 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@ -- | Extract a value from an @RTreeT@
extractT :: (Monad m) => RTreeT m b -> m b extractT :: (Monad m) => RTreeT m b -> m b
extractT (RTreeT m) = m >>= extractN extractT (RTreeT m) = m >>= extractN
...@@ -143,13 +148,6 @@ extractN = \case ...@@ -143,13 +148,6 @@ extractN = \case
SplitN _ rhs -> extractT rhs SplitN _ rhs -> extractT rhs
{-# INLINE extractN #-} {-# 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 i -> RTree i
flattenT (RTreeT (Identity t)) = case t of flattenT (RTreeT (Identity t)) = case t of
DoneN i -> Done i DoneN i -> Done i
......
...@@ -27,11 +27,6 @@ module Control.Monad.Reduce ( ...@@ -27,11 +27,6 @@ module Control.Monad.Reduce (
collectNonEmpty, collectNonEmpty,
collectNonEmpty', collectNonEmpty',
-- * RPath
RPath,
fromChoiceList,
toChoiceList,
-- * Helpers -- * Helpers
onBoth, onBoth,
liftMaybe, liftMaybe,
...@@ -40,13 +35,11 @@ module Control.Monad.Reduce ( ...@@ -40,13 +35,11 @@ module Control.Monad.Reduce (
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
import Control.Monad.Reader
import Control.Monad.State import Control.Monad.State
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Data.Bool
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import Data.Maybe import Data.Maybe
import Data.String
import qualified Data.Vector.Unboxed as VU
-- {- | A reducer should extract itself -- {- | A reducer should extract itself
-- @ -- @
...@@ -60,19 +53,16 @@ import qualified Data.Vector.Unboxed as VU ...@@ -60,19 +53,16 @@ import qualified Data.Vector.Unboxed as VU
class (Monad m) => MonadReduce m where class (Monad m) => MonadReduce m where
{-# MINIMAL (split | check) #-} {-# 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 :: m i -> m i -> m i
split r1 r2 = split r1 r2 =
check >>= \case check >>= \case
False -> r1 True -> r1
True -> r2 False -> r2
{-# INLINE split #-} {-# INLINE split #-}
-- | Check with returns a boolean, that can be used to split the input into a world where -- | Check if the predicate is true.
-- the optional truth assignement is satisfiable and where it is not.
check :: m Bool check :: m Bool
check = split (pure False) (pure True) check = split (pure True) (pure False)
{-# INLINE check #-} {-# INLINE check #-}
-- | Infix split. -- | Infix split.
...@@ -135,25 +125,9 @@ onBoth mlhs mrhs fn = ...@@ -135,25 +125,9 @@ onBoth mlhs mrhs fn =
Just rhs -> fn lhs rhs Just rhs -> fn lhs rhs
instance (MonadReduce m) => MonadReduce (StateT s m) where 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 #-} {-# INLINE check #-}
{- | A reduction path, can be used as an index into reduction tree. instance (MonadReduce m) => MonadReduce (ReaderT r m) where
Is isomorphic to a list of choices. check = ReaderT (\_ -> split (pure True) (pure False))
-} {-# INLINE check #-}
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')
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')
┳━┳━┳━ [1,2,3]
┃ ┃ ┗━ [1,2]
┃ ┗━┳━ [1,3]
┃ ┗━ [1]
┗━┳━┳━ [2,3]
┃ ┗━ [2]
┗━┳━ [3]
┗━ []
...@@ -6,11 +6,11 @@ ...@@ -6,11 +6,11 @@
module Control.Monad.RTreeSpec where module Control.Monad.RTreeSpec where
import Control.Applicative
import Control.Monad.Identity (Identity (runIdentity)) import Control.Monad.Identity (Identity (runIdentity))
import Control.Monad.RTree import Control.Monad.RTree
import Control.Monad.State import Control.Monad.State
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Data.Expr as Expr
import Data.Foldable import Data.Foldable
import Data.Functor import Data.Functor
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
...@@ -27,71 +27,11 @@ rBool = split (pure False) (pure True) ...@@ -27,71 +27,11 @@ rBool = split (pure False) (pure True)
rList :: (MonadReduce m) => [a] -> m [a] rList :: (MonadReduce m) => [a] -> m [a]
rList = collect (given $>) 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 :: Spec
spec = do spec = do
rtreeSpec rtreeSpec
rtreeTSpec rtreeTSpec
examplesSpec
rtreeTSpec :: Spec rtreeTSpec :: Spec
rtreeTSpec = describe "RTreeT" do rtreeTSpec = describe "RTreeT" do
...@@ -102,29 +42,6 @@ rtreeTSpec = describe "RTreeT" do ...@@ -102,29 +42,6 @@ rtreeTSpec = describe "RTreeT" do
it "should input like RTree" do it "should input like RTree" do
equiv (rList [1, 2, 3 :: Int]) inputs (toList :: RTreeT Identity [Int] -> [[Int]]) 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 equiv
:: (Show b, MonadReduce x, MonadReduce y, Eq b) :: (Show b, MonadReduce x, MonadReduce y, Eq b)
=> (forall m. (MonadReduce m) => m a) => (forall m. (MonadReduce m) => m a)
...@@ -154,12 +71,51 @@ rtreeSpec = describe "RTree" do ...@@ -154,12 +71,51 @@ rtreeSpec = describe "RTree" do
describe "iinputs" do describe "iinputs" do
it "should get all inputs from rList" do it "should get all inputs from rList" do
iinputs (rList [1, 2, 3 :: Int]) iinputs (rList [1, 2, 3 :: Int])
`shouldBe` [ ("000", []) `shouldBe` [ ("111", [])
, ("001", [3]) , ("110", [3])
, ("010", [2]) , ("101", [2])
, ("011", [2, 3]) , ("100", [2, 3])
, ("100", [1]) , ("011", [1])
, ("101", [1, 3]) , ("010", [1, 3])
, ("110", [1, 2]) , ("001", [1, 2])
, ("111", [1, 2, 3]) , ("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'
{-# 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
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment