|
|
- module Elab.Eval.Formula where
-
- import qualified Data.Map.Strict as Map
- import qualified Data.Sequence as Seq
- import qualified Data.Set as Set
- import Data.Map.Strict (Map)
- import Data.Set (Set)
-
- import Syntax
-
- import {-# SOURCE #-} Elab.WiredIn (inot, ior, iand)
-
- toDnf :: Value -> Maybe Value
- toDnf = fmap (dnf2Val . normalise) . val2Dnf where
- val2Dnf (VNe _ _) = Nothing
- val2Dnf x = toDnf x where
- toDnf (VIAnd x y) = idist <$> toDnf (inot x) <*> toDnf (inot y)
- toDnf (VIOr x y) = ior <$> toDnf x <*> toDnf y
- toDnf (VINot x) = inot <$> toDnf x
- toDnf VI0 = pure VI0
- toDnf VI1 = pure VI1
- toDnf v@(VNe _ Seq.Empty) = pure v
- toDnf _ = Nothing
-
- dnf2Val xs = Set.foldl ior VI0 (Set.map (Set.foldl iand VI1) xs)
-
- type Nf = Set (Set Value)
-
- normalise :: Value -> Nf
- normalise = normaliseOr where
- normaliseOr (VIOr x y) = Set.singleton (normaliseAnd x) <> normaliseOr y
- normaliseOr x = Set.singleton (normaliseAnd x)
-
- normaliseAnd (VIAnd x y) = Set.insert x (normaliseAnd y)
- normaliseAnd x = Set.singleton x
-
- compareDNFs :: Value -> Value -> Bool
- compareDNFs (VIOr x y) (VIOr x' y') =
- let (a, a') = swap x y
- (b, b') = swap x' y'
- in compareDNFs a b && compareDNFs a' b'
- compareDNFs (VIAnd x y) (VIAnd x' y') =
- let (a, a') = swap x x'
- (b, b') = swap y y'
- in compareDNFs a a' && compareDNFs b b'
- compareDNFs x y = x == y
-
- swap :: Ord b => b -> b -> (b, b)
- swap x y =
- if x <= y then (x, y) else (y, x)
-
- possible :: Map Head Bool -> Value -> (Bool, Map Head Bool)
- possible sc (VINot (VNe n Seq.Empty)) =
- case Map.lookup n sc of
- Just True -> (False, sc)
- _ -> (True, Map.insert n False sc)
- possible sc (VNe n Seq.Empty) =
- case Map.lookup n sc of
- Just False -> (False, sc)
- _ -> (True, Map.insert n True sc)
- possible sc (VIAnd x y) =
- let (a, sc') = possible sc x
- (b, sc'') = possible sc' y
- in (a && b, sc'')
- possible sc (VIOr x y) =
- case possible sc x of
- (True, sc') -> (True, sc')
- (False, _) -> possible sc y
- possible sc VI0 = (False, sc)
- possible sc VI1 = (True, sc)
- possible sc _ = (False, sc)
-
- truthAssignments :: NFEndp -> Map Name (NFType, NFEndp) -> [Map Name (NFType, NFEndp)]
- truthAssignments VI0 _ = []
- truthAssignments VI1 m = pure m
- truthAssignments (VIOr x y) m = truthAssignments x m ++ truthAssignments y m
- truthAssignments (VIAnd x y) m = truthAssignments x =<< truthAssignments y m
- truthAssignments (VNe (HVar x) Seq.Empty) m = pure (Map.insert x (VI, VI1) m)
- truthAssignments (VINot (VNe (HVar x) Seq.Empty)) m = pure (Map.insert x (VI, VI0) m)
- truthAssignments _ m = pure m
-
- idist :: Value -> Value -> Value
- idist (VIOr x y) z = (x `idist` z) `ior` (y `idist` z)
- idist z (VIOr x y) = (z `idist` x) `ior` (z `idist` y)
- idist z x = iand z x
|