Skip to content
Snippets Groups Projects
Commit 865c273e authored by chrg's avatar chrg
Browse files

Cleaning up RTree

parent 4056b202
No related branches found
No related tags found
No related merge requests found
...@@ -11,6 +11,7 @@ build-type: Simple ...@@ -11,6 +11,7 @@ build-type: Simple
library library
exposed-modules: exposed-modules:
Control.Monad.Reduce Control.Monad.Reduce
Control.Monad.RTree
Control.RTree Control.RTree
Data.Valuation Data.Valuation
other-modules: other-modules:
......
{-# 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 #-}
...@@ -3,46 +3,31 @@ ...@@ -3,46 +3,31 @@
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{- | {- |
Module: Control.Monad.Reduce Module: Control.Monad.Reduce
-} -}
module Control.Monad.Reduce ( module Control.Monad.Reduce (
-- * MonadReduce
MonadReduce (..), MonadReduce (..),
-- * Constructors
(<|), (<|),
(|>), (|>),
splitOn,
given,
givenThat,
givenWith,
check,
checkThat,
conditionalGivenThat,
-- * Combinators -- * Combinators
collect, collect,
collectReverse,
collectNonEmpty, collectNonEmpty,
collectNonEmpty', collectNonEmpty',
-- * Algorithms -- * MonadReducePlus
ddmin, MonadReducePlus,
linearSearch, given,
linearSearch',
binarySearch,
exponentialSearch,
-- * Helpers -- * Helpers
MonadReducePlus,
onBoth, onBoth,
liftMaybe, liftMaybe,
liftMaybeT, liftMaybeT,
...@@ -54,127 +39,75 @@ import Control.Monad.Trans.Maybe ...@@ -54,127 +39,75 @@ import Control.Monad.Trans.Maybe
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import Data.Maybe import Data.Maybe
import Control.Monad.State
import Data.Valuation (Truth (..))
import qualified Data.Valuation as Val
-- {- | A reducer should extract itself -- {- | A reducer should extract itself
-- @ -- @
-- extract . red = id -- 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 -- lawReduceId red i = extract (red i) == i
-- | The Monad Reduce class. -- | The Monad Reduce class.
class (Monad m) => MonadReduce l m | m -> l where class (Monad m) => MonadReduce m where
{-# MINIMAL (splitWith | checkWith), bottom #-} {-# MINIMAL (split | check) #-}
-- | Split the world into the a reduced world (left) without an element and a world -- | Split the world into the a reduced world (left) without an element and a world
-- with that element (right). Optionally, labeled with l. -- with that element (right). Optionally, labeled with l.
splitWith :: Maybe (Truth l) -> m i -> m i -> m i split :: m i -> m i -> m i
splitWith l r1 r2 = split r1 r2 =
checkWith l >>= \case check >>= \case
False -> r1 False -> r1
True -> r2 True -> r2
{-# INLINE splitWith #-} {-# INLINE split #-}
-- | Check with returns a boolean, that can be used to split the input into a world where -- | 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. -- the optional truth assignement is satisfiable and where it is not.
checkWith :: Maybe (Truth l) -> m Bool check :: m Bool
checkWith l = splitWith l (pure False) (pure True) check = split (pure False) (pure True)
{-# INLINE checkWith #-} {-# INLINE check #-}
-- | 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 #-}
-- | Infix split. -- | Infix split.
(<|) :: (MonadReduce l m) => m i -> m i -> m i (<|) :: (MonadReduce m) => m i -> m i -> m i
(<|) = split (<|) = split
{-# INLINE (<|) #-} {-# INLINE (<|) #-}
infixr 3 <| infixr 3 <|
-- | Infix split, to the right. -- | 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 r1 |> r2 = r2 <| r1
{-# INLINE (|>) #-} {-# INLINE (|>) #-}
infixl 3 |> infixl 3 |>
-- | Split on a label. type MonadReducePlus m = (MonadReduce m, MonadPlus m)
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 #-}
-- | Split the world on a labeled fact. False it does not happen, and True it does happen. instance (MonadReduce m) => MonadReduce (MaybeT m) where
checkThat :: (MonadReduce l m) => Truth l -> m Bool split (MaybeT lhs) (MaybeT rhs) = MaybeT (split lhs rhs)
checkThat l = checkWith (Just l)
{-# INLINE checkThat #-}
-- | Continues if the fact is true. -- | Continues if the fact is true.
given :: (MonadReducePlus l m) => m () given :: (MonadReducePlus m) => m ()
given = givenWith Nothing given = split mzero (pure ())
{-# INLINE given #-} {-# 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. -- | 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) collect fn = fmap catMaybes . traverse (runMaybeT . fn)
{-# INLINE collect #-} {-# 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. -- | 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 = collectNonEmpty' fn as =
NE.toList <$> collectNonEmpty fn as NE.toList <$> collectNonEmpty fn as
{-# INLINE collectNonEmpty' #-} {-# INLINE collectNonEmpty' #-}
-- | Given a list of item try to remove each of them, but keep atleast one. -- | 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 collectNonEmpty fn as = do
as' <- fmap catMaybes . traverse (optional . fn) $ as as' <- fmap catMaybes . traverse (optional . fn) $ as
maybe mzero pure $ NE.nonEmpty as' maybe mzero pure $ NE.nonEmpty as'
{-# INLINE collectNonEmpty #-} {-# 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) -- | Helper that lifts a maybe into MonadPlus (or MaybeT)
liftMaybe :: (Alternative m) => Maybe a -> m a liftMaybe :: (Alternative m) => Maybe a -> m a
liftMaybe = maybe empty pure liftMaybe = maybe empty pure
...@@ -186,65 +119,3 @@ liftMaybeT m = runMaybeT m >>= liftMaybe ...@@ -186,65 +119,3 @@ liftMaybeT m = runMaybeT m >>= liftMaybe
onBoth :: (MonadPlus m) => m a -> m a -> (a -> a -> m a) -> m a onBoth :: (MonadPlus m) => m a -> m a -> (a -> a -> m a) -> m a
onBoth mlhs mrhs fn = onBoth mlhs mrhs fn =
join $ (fn <$> mlhs <*> mrhs) <|> fmap pure mrhs <|> fmap pure mlhs 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
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment