Some more small utility functions

diff --git a/src/Dyna/XXX/DataUtils.hs b/src/Dyna/XXX/DataUtils.hs
index 4443264800f9fb944b817a6910b223fd419be2ba..a8d7f18bbf896c4889cc4ef043ecd4c14f46e8a0 100644 (file)
--- a/src/Dyna/XXX/DataUtils.hs
+++ b/src/Dyna/XXX/DataUtils.hs
@@ -9,6 +9,8 @@ module Dyna.XXX.DataUtils (
   mapUpsert,
   -- ** Insertion into a map of lists
   mapInOrApp,
+  -- ** Unification-style utilities
+  mapSemiprune,
   -- * 'Data.Set' utilities
   -- ** Quantification
   setExists, setForall
@@ -55,3 +57,28 @@ mapInOrApp k v m = M.alter (\mv -> Just $ v:nel mv) k m
  where
   nel Nothing  = []
   nel (Just x) = x
+
+
+-- | For all those times one builds a map which may yield non-productive
+-- steps of variable-to-variable aliasing.  Note that this function may
+-- leave the map with identity mappings, which should be carefully
+-- interpreted by the user (probably as a free variable)
+mapSemiprune :: (Ord k)
+             => (v -> Maybe k) -- ^ Is this a variable link?
+             -> (k -> v)               -- ^ What should we store to indicate
+                                -- a pointer to this variable?
+             -> k               -- ^ Initial variable
+             -> M.Map k v              -- ^ In this map
+             -> (k, M.Map k v) -- ^ (terminus of chain, pruned map)
+mapSemiprune q p k m = case M.lookup k m >>= q of
+                         Nothing -> (k, m)
+                         Just k' -> go (S.singleton k) k'
+ where
+  go v k' =
+    case M.lookup k' m >>= q of
+      Nothing                     -> (k', setAll m v k')
+      Just k'' | k'' `S.member` v -> (k'', setAll m v k'') -- (M.delete k'' m) (S.delete k'' v) k'')
+      Just k''                    -> go (k' `S.insert` v) k''
+
+  setAll m' v k' = M.fromList (map (\x -> (x,p k')) $ S.toList v)
+                   `M.union` m'

diff --git a/src/Dyna/XXX/MonadUtils.hs b/src/Dyna/XXX/MonadUtils.hs
index 9cfd7b32f143a6b68ac711e8fde47711fbfb56fc..4b636429d04f3c7a2d33d8cae5c052161127f310 100644 (file)
--- a/src/Dyna/XXX/MonadUtils.hs
+++ b/src/Dyna/XXX/MonadUtils.hs
@@ -1,8 +1,45 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
-module Dyna.XXX.MonadUtils(bracketState, incState) where
+module Dyna.XXX.MonadUtils(
+  -- * Data utilities generalizing 'Dyna.XXX.DataUtils'
+  mapForallM, mapExistsM,
+  -- * Logic utilities
+  andM, andM1, orM, orM1, allM, anyM,
+  -- * MonadState utilities
+  bracketState, incState,
+  -- * Context classes
+  MC(..),
+) where
 
-import Control.Monad.State
+import           Control.Applicative
+import           Control.Monad.State
+import qualified Data.Map  as M
+
+andM :: Monad m => m Bool -> m Bool -> m Bool
+andM x y = x >>= flip andM1 y 
+
+andM1 :: Monad m => Bool -> m Bool -> m Bool
+andM1 False _ = return False
+andM1 True  x = x
+
+orM :: Monad m => m Bool -> m Bool -> m Bool
+orM x y = x >>= flip orM1 y
+
+orM1 :: Monad m => Bool -> m Bool -> m Bool
+orM1 True  _ = return True
+orM1 False x = x
+
+allM :: Monad m => [m Bool] -> m Bool
+allM = foldM andM1 True
+
+anyM :: Monad m => [m Bool] -> m Bool
+anyM = foldM orM1 False
+
+mapForallM, mapExistsM :: (Monad m)
+                       => (k -> v -> m Bool) -> M.Map k v -> m Bool
+mapForallM p m = M.foldrWithKey (\k v -> (andM $ p k v)) (return True ) m
+mapExistsM p m = M.foldrWithKey (\k v -> (orM  $ p k v)) (return False) m
 
 bracketState :: (MonadState s m) => s -> m t -> m (t, s)
 bracketState bs m = do
@@ -13,9 +50,14 @@ bracketState bs m = do
  put s
  return (r, bs)
 
-
 incState :: (Num a, MonadState a m) => m a
 incState = do
   s <- get
   put $! (s+1)
   return s
+
+-- | Assert the the monad @m@ has a context of type @k -> v@.
+class (Monad m) => MC m k v where
+  clookup :: k -> m v
+  cassign :: k -> v -> m ()
+  cfresh  :: m k