You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
90 lines
3.0 KiB
90 lines
3.0 KiB
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)
|
|
import Elab.Eval (substitute, trueCaseSentinel)
|
|
|
|
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) (sub x VI1 <$> m))
|
|
truthAssignments (VINot (VNe (HVar x) Seq.Empty)) m = pure (Map.insert x (VI, VI0) (sub x VI0 <$> m))
|
|
truthAssignments (VCase _ _ (VNe (HVar x) _) _) m = pure (Map.insert x (VI, VVar trueCaseSentinel) m)
|
|
truthAssignments _ m = pure m
|
|
|
|
sub :: Name -> Value -> (NFType, NFEndp) -> (Value, Value)
|
|
sub x v (a, b) = (substitute (Map.singleton x v) a, substitute (Map.singleton x v) b)
|
|
|
|
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
|