Cleaning up RTree

rtree/rtree.cabal

@@ -11,6 +11,7 @@ build-type:     Simple
 library
   exposed-modules:
       Control.Monad.Reduce
+      Control.Monad.RTree
       Control.RTree
       Data.Valuation
   other-modules:

rtree/src/Control/Monad/RTree.hs

+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | A naive implementation of the rtree.
+module Control.Monad.RTree (
+  -- * RTree
+  RTree,
+  extract,
+  inputs,
+  reduce,
+
+  -- * RTreeT and RTreeN
+  RTreeT (..),
+  extractT,
+  reduceT,
+  RTreeN (..),
+  extractN,
+
+  -- * Re-exports
+  module Control.Monad.Reduce,
+) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Reduce
+import Control.Monad.State
+import qualified Data.Foldable as Foldable
+
+-- | The simple RTree
+data RTree i
+  = Done !i
+  | Split (RTree i) !(RTree i)
+  deriving (Functor, Foldable)
+
+instance Applicative RTree where
+  pure = Done
+  (<*>) = ap
+
+instance Monad RTree where
+  ma >>= f = case ma of
+    Done i -> f i
+    Split lhs rhs -> Split (lhs >>= f) (rhs >>= f)
+
+instance MonadReduce RTree where
+  split = Split
+
+-- | Extract the top value from the RTree.
+extract :: RTree i -> i
+extract = \case
+  Split _ rhs -> extract rhs
+  Done i -> i
+{-# INLINE extract #-}
+
+-- | A simple wrapper around @toList@
+inputs :: RTree i -> [i]
+inputs = Foldable.toList
+
+-- | Reduce the tree
+reduce :: (MonadPlus m) => (i -> m Bool) -> RTree i -> m i
+reduce p = checkgo
+ where
+  checkgo r = do
+    t <- p (extract r)
+    guard t *> go r
+  go = \case
+    Done i -> pure i
+    Split lhs rhs -> checkgo lhs <|> go rhs
+{-# INLINE reduce #-}
+
+-- | An RTreeT Node
+data RTreeN m i
+  = DoneN !i
+  | SplitN !(RTreeT m i) !(RTreeN m i)
+  deriving (Functor, Foldable)
+
+newtype RTreeT m i = RTreeT {unRTreeT :: m (RTreeN m i)}
+  deriving (Functor, Foldable)
+
+instance (Monad m) => Applicative (RTreeT m) where
+  pure = RTreeT . pure . DoneN
+  (<*>) = ap
+
+instance (Monad m) => Monad (RTreeT m) where
+  RTreeT ma >>= f = RTreeT $ do
+    ma >>= go
+   where
+    go = \case
+      DoneN i -> unRTreeT (f i)
+      SplitN lhs rhs -> SplitN (lhs >>= f) <$> go rhs
+
+instance (MonadState s m) => MonadState s (RTreeT m) where
+  state f = RTreeT (DoneN <$> state f)
+
+-- | Extract a value from an @RTreeT@
+extractT :: (Functor m) => RTreeT m b -> m b
+extractT (RTreeT m) = extractN <$> m
+{-# INLINE extractT #-}
+
+extractN :: RTreeN m i -> i
+extractN = \case
+  DoneN i -> i
+  SplitN _ rhs -> extractN rhs
+{-# INLINE extractN #-}
+
+-- | Reduction in @RTreeT@
+reduceT
+  :: forall i m n
+   . (Monad m, MonadPlus n)
+  => (forall a. m a -> n a)
+  -- ^ A function to lift m into n
+  -> (i -> n Bool)
+  -> RTreeT m i
+  -> n i
+reduceT lift_ p = checkgo
+ where
+  checkgo r = do
+    r' <- lift_ (unRTreeT r)
+    t <- p (extractN r')
+    unless t mzero
+    go r'
+  go = \case
+    DoneN i -> pure i
+    SplitN lhs rhs -> checkgo lhs <|> go rhs
+{-# INLINE reduceT #-}

rtree/src/Control/Monad/Reduce.hs

@@ -3,46 +3,31 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ViewPatterns #-}
 
 {- |
 Module: Control.Monad.Reduce
 -}
 module Control.Monad.Reduce (
+  -- * MonadReduce
   MonadReduce (..),
-
-  -- * Constructors
   (<|),
   (|>),
-  splitOn,
-  given,
-  givenThat,
-  givenWith,
-  check,
-  checkThat,
-  conditionalGivenThat,
 
   -- * Combinators
   collect,
-  collectReverse,
   collectNonEmpty,
   collectNonEmpty',
 
-  -- * Algorithms
-  ddmin,
-  linearSearch,
-  linearSearch',
-  binarySearch,
-  exponentialSearch,
+  -- * MonadReducePlus
+  MonadReducePlus,
+  given,
 
   -- * Helpers
-  MonadReducePlus,
   onBoth,
   liftMaybe,
   liftMaybeT,
@@ -54,127 +39,75 @@ import Control.Monad.Trans.Maybe
 import qualified Data.List.NonEmpty as NE
 import Data.Maybe
 
-import Control.Monad.State
-import Data.Valuation (Truth (..))
-import qualified Data.Valuation as Val
-
 -- {- | A reducer should extract itself
 -- @
 --  extract . red = id
 -- @
 -- -}
--- lawReduceId :: (MonadReduce l m, Eq i) => (i -> m i) -> i -> Bool
+-- lawReduceId :: (MonadReduce m, Eq i) => (i -> m i) -> i -> Bool
 -- lawReduceId red i = extract (red i) == i
 
 -- | The Monad Reduce class.
-class (Monad m) => MonadReduce l m | m -> l where
-  {-# MINIMAL (splitWith | checkWith), bottom #-}
+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.
-  splitWith :: Maybe (Truth l) -> m i -> m i -> m i
-  splitWith l r1 r2 =
-    checkWith l >>= \case
+  split :: m i -> m i -> m i
+  split r1 r2 =
+    check >>= \case
       False -> r1
       True -> r2
-  {-# INLINE splitWith #-}
+  {-# 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.
-  checkWith :: Maybe (Truth l) -> m Bool
-  checkWith l = splitWith l (pure False) (pure True)
-  {-# INLINE checkWith #-}
-
-  -- | An unrecoverable bottom, which claims that the predicate would always fail on this
-  -- input.
-  bottom :: m ()
-
--- | Split with no label.
-split :: (MonadReduce l m) => m i -> m i -> m i
-split = splitWith Nothing
-{-# INLINE split #-}
+  check :: m Bool
+  check = split (pure False) (pure True)
+  {-# INLINE check #-}
 
 -- | Infix split.
-(<|) :: (MonadReduce l m) => m i -> m i -> m i
+(<|) :: (MonadReduce m) => m i -> m i -> m i
 (<|) = split
 {-# INLINE (<|) #-}
 
 infixr 3 <|
 
 -- | Infix split, to the right.
-(|>) :: (MonadReduce l m) => m i -> m i -> m i
+(|>) :: (MonadReduce m) => m i -> m i -> m i
 r1 |> r2 = r2 <| r1
 {-# INLINE (|>) #-}
 
 infixl 3 |>
 
--- | Split on a label.
-splitOn :: (MonadReduce l m) => Truth l -> m i -> m i -> m i
-splitOn l = splitWith (Just l)
-{-# INLINE splitOn #-}
-
--- | Split the world on a fact. False it does not happen, and True it does happen.
-check :: (MonadReduce l m) => m Bool
-check = checkWith Nothing
-{-# INLINE check #-}
+type MonadReducePlus m = (MonadReduce m, MonadPlus m)
 
--- | Split the world on a labeled fact. False it does not happen, and True it does happen.
-checkThat :: (MonadReduce l m) => Truth l -> m Bool
-checkThat l = checkWith (Just l)
-{-# INLINE checkThat #-}
+instance (MonadReduce m) => MonadReduce (MaybeT m) where
+  split (MaybeT lhs) (MaybeT rhs) = MaybeT (split lhs rhs)
 
 -- | Continues if the fact is true.
-given :: (MonadReducePlus l m) => m ()
-given = givenWith Nothing
+given :: (MonadReducePlus m) => m ()
+given = split mzero (pure ())
 {-# INLINE given #-}
 
--- | Continues if the labeled fact is true.
-givenWith :: (MonadReducePlus l m) => Maybe (Truth l) -> m ()
-givenWith l = splitWith l mzero (pure ())
-{-# INLINE givenWith #-}
-
--- | Continues if the labeled fact is true.
-givenThat :: (MonadReducePlus l m) => Truth l -> m ()
-givenThat l = givenWith (Just l)
-{-# INLINE givenThat #-}
-
 -- | Given a list of item try to remove each of them from the list.
-collect :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> m [b]
+collect :: (MonadReduce m) => (a -> MaybeT m b) -> [a] -> m [b]
 collect fn = fmap catMaybes . traverse (runMaybeT . fn)
 {-# INLINE collect #-}
 
--- | Given a list of item try to remove each of them from the list, but from the other direction
-collectReverse :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> m [b]
-collectReverse fn = fmap (reverse . catMaybes) . traverse (runMaybeT . fn) . reverse
-{-# INLINE collectReverse #-}
-
 -- | Given a list of item try to remove each of them, but keep atleast one.
-collectNonEmpty' :: (MonadReducePlus l m) => (a -> m b) -> [a] -> m [b]
+collectNonEmpty' :: (MonadReducePlus m) => (a -> m b) -> [a] -> m [b]
 collectNonEmpty' fn as =
   NE.toList <$> collectNonEmpty fn as
 {-# INLINE collectNonEmpty' #-}
 
 -- | Given a list of item try to remove each of them, but keep atleast one.
-collectNonEmpty :: (MonadReducePlus l m) => (a -> m b) -> [a] -> m (NE.NonEmpty b)
+collectNonEmpty :: (MonadReducePlus m) => (a -> m b) -> [a] -> m (NE.NonEmpty b)
 collectNonEmpty fn as = do
   as' <- fmap catMaybes . traverse (optional . fn) $ as
   maybe mzero pure $ NE.nonEmpty as'
 {-# INLINE collectNonEmpty #-}
 
-conditionalGivenThat :: (MonadReducePlus l m) => [l] -> Truth l -> m ()
-conditionalGivenThat [] t = givenThat t
-conditionalGivenThat (a : as) t = do
-  splitOn
-    (Val.is a)
-    (splitOn (Val.not t) bottom mzero)
-    (conditionalGivenThat as t)
-
-type MonadReducePlus l m = (MonadReduce l m, MonadPlus m)
-
-instance (MonadReduce l m) => MonadReduce l (MaybeT m) where
-  bottom = MaybeT{runMaybeT = Just <$> bottom}
-  splitWith m (MaybeT lhs) (MaybeT rhs) = MaybeT (splitWith m lhs rhs)
-
 -- | Helper that lifts a maybe into MonadPlus (or MaybeT)
 liftMaybe :: (Alternative m) => Maybe a -> m a
 liftMaybe = maybe empty pure
@@ -186,65 +119,3 @@ liftMaybeT m = runMaybeT m >>= liftMaybe
 onBoth :: (MonadPlus m) => m a -> m a -> (a -> a -> m a) -> m a
 onBoth mlhs mrhs fn =
   join $ (fn <$> mlhs <*> mrhs) <|> fmap pure mrhs <|> fmap pure mlhs
-
-{- | Given a list of ordered options, choose the first that statisfy the constraints,
-returning the last element if nothing else matches.
--}
-linearSearch :: (MonadReduce l m) => NE.NonEmpty i -> m i
-linearSearch = foldr1 (<|) . fmap pure
-
-{- | Given a list of ordered options, choose the first that statisfy the
-constraints, potentially returning nothing.
--}
-linearSearch' :: (MonadReduce l m, MonadPlus m) => [i] -> m i
-linearSearch' is = do
-  mp <- linearSearch (NE.fromList (fmap Just is ++ [Nothing]))
-  liftMaybe mp
-
--- | Given
-ddmin :: (MonadReduce l m) => [i] -> m [i]
-ddmin = \case
-  [] -> pure []
-  [a] -> pure [a]
-  as -> go 2 as
- where
-  go n lst
-    | n' <= 0 = pure lst
-    | otherwise = do
-        r <- runMaybeT $ linearSearch' (partitions n' lst ++ composites n' lst)
-        case r of
-          Nothing -> go (n * 2) lst <| pure lst -- (for efficiency :D)
-          Just lst' -> ddmin lst'
-   where
-    n' = length lst `div` n
-  partitions n lst =
-    case lst of
-      [] -> []
-      _ -> let (h, r) = splitAt n lst in h : partitions n r
-  composites n lst =
-    case lst of
-      [] -> []
-      _ -> let (h, r) = splitAt n lst in r : fmap (h ++) (composites n r)
-
-{- | Given a progression of inputs that are progressively larger, pick the smallest using
-binary search.
--}
-binarySearch :: (MonadReduce l m) => NE.NonEmpty i -> m i
-binarySearch = \case
-  a NE.:| [] -> pure a
-  d -> binarySearch l <| binarySearch f
-   where
-    (NE.fromList -> f, NE.fromList -> l) = NE.splitAt (NE.length d `div` 2) d
-
-{- | Given a progression of inputs that are progressively larger, pick the smallest using
-binary search.
--}
-exponentialSearch :: (MonadReduce l m) => NE.NonEmpty i -> m i
-exponentialSearch = go 1
- where
-  go n = \case
-    d
-      | n >= NE.length d -> binarySearch d
-      | otherwise -> go (n * 2) l <| binarySearch f
-     where
-      (NE.fromList -> f, NE.fromList -> l) = NE.splitAt n d