Skip to content
Snippets Groups Projects
Valuation.hs 2.15 KiB
Newer Older
  • Learn to ignore specific revisions
  • chrg's avatar
    chrg committed
    {-# LANGUAGE BlockArguments #-}
    {-# LANGUAGE LambdaCase #-}
    
    module Data.Valuation (
      Valuation,
    
      -- * Constructors
      singleton,
      fromMap,
      fromPairs,
    
      -- * Destructors
      toMap,
      toPairs,
    
      -- * Access
    
    chrg's avatar
    chrg committed
      withTruth,
    
    chrg's avatar
    chrg committed
      truthValue,
      condition,
    
    
    chrg's avatar
    chrg committed
      -- * Truth
      Truth (..),
      not,
      is,
      isNot,
    
    
    chrg's avatar
    chrg committed
      -- * Helpers
      viaMap,
      viaMapF,
    ) where
    
    import Data.Functor.Identity
    import qualified Data.Map.Strict as Map
    
    
    chrg's avatar
    chrg committed
    import Prelude hiding (not)
    import qualified Prelude
    
    -- | A Single truth assignment
    data Truth l = Truth
      { label :: !l
      , truth :: !Bool
      }
    
    is :: l -> Truth l
    is l = Truth{label = l, truth = True}
    {-# INLINE is #-}
    
    isNot :: l -> Truth l
    isNot l = Truth{label = l, truth = False}
    {-# INLINE isNot #-}
    
    not :: Truth l -> Truth l
    not (Truth l t) = Truth l (Prelude.not t)
    
    
    chrg's avatar
    chrg committed
    newtype Valuation l = Valuation {toMap :: Map.Map l Bool}
    
    
    chrg's avatar
    chrg committed
    singleton :: (Ord l) => Truth l -> Valuation l
    singleton (Truth l t) = fromMap $ Map.singleton l t
    {-# INLINE singleton #-}
    
    chrg's avatar
    chrg committed
    
    viaMap :: (Map.Map l Bool -> Map.Map l Bool) -> Valuation l -> Valuation l
    viaMap fn = runIdentity . viaMapF (Identity . fn)
    
    chrg's avatar
    chrg committed
    {-# INLINE viaMap #-}
    
    chrg's avatar
    chrg committed
    
    viaMapF :: (Functor f) => (Map.Map l Bool -> f (Map.Map l Bool)) -> Valuation l -> f (Valuation l)
    viaMapF fn = fmap fromMap . fn . toMap
    
    chrg's avatar
    chrg committed
    {-# INLINE viaMapF #-}
    
    chrg's avatar
    chrg committed
    
    fromMap :: Map.Map l Bool -> Valuation l
    fromMap = Valuation
    
    chrg's avatar
    chrg committed
    {-# INLINE fromMap #-}
    
    chrg's avatar
    chrg committed
    
    fromPairs :: (Ord l) => [(l, Bool)] -> Valuation l
    fromPairs = Valuation . Map.fromList
    
    chrg's avatar
    chrg committed
    {-# INLINE fromPairs #-}
    
    chrg's avatar
    chrg committed
    
    toPairs :: Valuation l -> [(l, Bool)]
    toPairs = Map.toList . toMap
    
    chrg's avatar
    chrg committed
    {-# INLINE toPairs #-}
    
    chrg's avatar
    chrg committed
    
    truthValue :: (Ord l) => Valuation l -> l -> Maybe Bool
    truthValue (Valuation m) = (`Map.lookup` m)
    
    chrg's avatar
    chrg committed
    {-# INLINE truthValue #-}
    
    chrg's avatar
    chrg committed
    
    {- | Conditions a valuation with key value pair, if it conficts with the valuation,
    it returns Nothing
    -}
    
    chrg's avatar
    chrg committed
    condition :: (Ord l) => Valuation l -> Truth l -> Maybe (Valuation l)
    condition v (Truth l t) =
    
    chrg's avatar
    chrg committed
      viaMapF
        ( Map.alterF
            \case
              Just t' | t' /= t -> Nothing
              _ -> Just (Just t)
            l
        )
        v
    
    chrg's avatar
    chrg committed
    {-# INLINE condition #-}
    
    chrg's avatar
    chrg committed
    
    
    chrg's avatar
    chrg committed
    withTruth :: (Ord l) => Valuation l -> Truth l -> Valuation l
    withTruth v (Truth l t) = viaMap (Map.insert l t) v
    {-# INLINE withTruth #-}