Small cleanup

rtree.cabal

@@ -12,6 +12,7 @@ library
   exposed-modules:
       Control.Monad.Reduce
       Control.RTree
+      Data.Valuation
   other-modules:
       Paths_rtree
   hs-source-dirs:

src/Control/Monad/Reduce.hs

@@ -40,10 +40,11 @@ module Control.Monad.Reduce (
 
   -- * Helpers
   onBoth,
+  liftMaybe,
 ) where
 
+import Control.Applicative
 import Control.Monad
-import Control.Monad.Trans
 import Control.Monad.Trans.Maybe
 import qualified Data.List.NonEmpty as NE
 import Data.Maybe
@@ -145,15 +146,14 @@ collectNonEmpty fn as = do
 instance (MonadReduce l m) => MonadReduce l (MaybeT m) where
   splitWith m (MaybeT lhs) (MaybeT rhs) = MaybeT (splitWith m lhs rhs)
 
+-- | Helper that lifts a maybe into MonadPlus (or MaybeT)
+liftMaybe :: (MonadPlus m) => Maybe a -> m a
+liftMaybe = maybe mzero pure
+
 -- | Returns either of the maybes or combines them if both have values.
-onBoth :: (Monad m) => MaybeT m a -> MaybeT m a -> (a -> a -> MaybeT m a) -> MaybeT m a
-onBoth mlhs mrhs fn = MaybeT do
-  runMaybeT mlhs >>= \case
-    Nothing -> runMaybeT mrhs
-    Just l ->
-      runMaybeT mrhs >>= \case
-        Nothing -> pure (Just l)
-        Just r -> runMaybeT (fn l r)
+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.
@@ -164,8 +164,10 @@ linearSearch = foldr1 (<|) . fmap pure
 {- | Given a list of ordered options, choose the first that statisfy the
 constraints, potentially returning nothing.
 -}
-linearSearch' :: (MonadReduce l m) => [i] -> MaybeT m i
-linearSearch' is = MaybeT $ linearSearch (NE.fromList (fmap Just is ++ [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]

src/Control/RTree.hs

@@ -35,22 +35,22 @@ module Control.RTree (
 
 import Control.Applicative
 import Control.Monad.Reader
+import Control.Monad.State.Strict
 import Data.Functor.Identity
-import qualified Data.Map.Strict as Map
 
 import Control.Monad.Reduce
-import Control.Monad.State.Strict
+import qualified Data.Valuation as Val
+
+type Valuation = Val.Valuation
 
 data RTree l i
   = SplitWith (Maybe l) (RTree l i) !(RTree l i)
   | Done i
   deriving (Functor)
 
-type Valuation l = Map.Map l Bool
-
 extract :: (Ord l) => Valuation l -> RTree l i -> i
 extract v = \case
-  SplitWith ml lhs rhs -> case ml >>= (`Map.lookup` v) of
+  SplitWith ml lhs rhs -> case ml >>= Val.truthValue v of
     Just False -> extract v lhs
     _ -> extract v rhs
   Done i -> i
@@ -79,10 +79,10 @@ reduce p = checkgo
   checkgo v r = p (extract v r) *> go v r
   go v = \case
     Done i -> pure i
-    SplitWith (Just l) lhs rhs -> case Map.lookup l v of
+    SplitWith (Just l) lhs rhs -> case Val.truthValue v l of
       Just True -> checkgo v rhs
       Just False -> checkgo v lhs
-      Nothing -> checkgo (Map.insert l False v) lhs <|> go (Map.insert l True v) rhs
+      Nothing -> checkgo (Val.setTruthValue v l False) lhs <|> go (Val.setTruthValue v l True) rhs
     SplitWith Nothing lhs rhs -> (checkgo v lhs <|> go v rhs)
 {-# INLINE reduce #-}
 
@@ -104,10 +104,10 @@ instance (Monad m, Ord l) => MonadReduce l (IRTreeT l m) where
         ReState (uncons -> (a, as)) v ->
           pure (a, ReState as v)
       Just l -> \case
-        ReState as v@(Map.lookup l -> Just x) ->
+        ReState as v@((`Val.truthValue` l) -> Just x) ->
           pure (x, ReState as v)
         ReState (uncons -> (a, as)) v ->
-          pure (a, ReState as (Map.insert l a v))
+          pure (a, ReState as (Val.setTruthValue v l a))
    where
     uncons [] = (True, [])
     uncons (a : as) = (a, as)

src/Data/Valuation.hs

+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Data.Valuation (
+  Valuation,
+
+  -- * Constructors
+  singleton,
+  fromMap,
+  fromPairs,
+
+  -- * Destructors
+  toMap,
+  toPairs,
+
+  -- * Access
+  setTruthValue,
+  truthValue,
+  condition,
+
+  -- * Helpers
+  viaMap,
+  viaMapF,
+) where
+
+import Data.Functor.Identity
+import qualified Data.Map.Strict as Map
+
+newtype Valuation l = Valuation {toMap :: Map.Map l Bool}
+
+singleton :: (Ord l) => l -> Bool -> Valuation l
+singleton l t = fromMap $ Map.singleton l t
+
+viaMap :: (Map.Map l Bool -> Map.Map l Bool) -> Valuation l -> Valuation l
+viaMap fn = runIdentity . viaMapF (Identity . fn)
+
+viaMapF :: (Functor f) => (Map.Map l Bool -> f (Map.Map l Bool)) -> Valuation l -> f (Valuation l)
+viaMapF fn = fmap fromMap . fn . toMap
+
+fromMap :: Map.Map l Bool -> Valuation l
+fromMap = Valuation
+
+fromPairs :: (Ord l) => [(l, Bool)] -> Valuation l
+fromPairs = Valuation . Map.fromList
+
+toPairs :: Valuation l -> [(l, Bool)]
+toPairs = Map.toList . toMap
+
+truthValue :: (Ord l) => Valuation l -> l -> Maybe Bool
+truthValue (Valuation m) = (`Map.lookup` m)
+
+{- | Conditions a valuation with key value pair, if it conficts with the valuation,
+it returns Nothing
+-}
+condition :: (Ord l) => Valuation l -> l -> Bool -> Maybe (Valuation l)
+condition v l t =
+  viaMapF
+    ( Map.alterF
+        \case
+          Just t' | t' /= t -> Nothing
+          _ -> Just (Just t)
+        l
+    )
+    v
+
+setTruthValue :: (Ord l) => Valuation l -> l -> Bool -> Valuation l
+setTruthValue v l t = viaMap (Map.insert l t) v