47 lines
1.3 KiB
Haskell
47 lines
1.3 KiB
Haskell
module Logic.Statement.Eval where
|
|
|
|
import Logic.Statement (Statement(..), atoms)
|
|
|
|
import Data.List (intercalate)
|
|
import Data.Either (fromRight)
|
|
|
|
data Bucket
|
|
= Tautology
|
|
| Contradiction
|
|
| Contingent
|
|
deriving (Eq, Show)
|
|
|
|
bucket :: Statement -> Bucket
|
|
bucket s
|
|
| and values = Tautology
|
|
| all not values = Contradiction
|
|
| otherwise = Contingent
|
|
where
|
|
values = [fromRight undefined $ eval assignments s | assignments <- enumerate $ atoms s]
|
|
|
|
eval :: [(String, Bool)] -> Statement -> Either String Bool
|
|
eval assignments = aux
|
|
where
|
|
aux (Atom key) = maybe (Left key) Right $ lookup key assignments
|
|
aux (Not s) = not <$> aux s
|
|
aux (And s1 s2) = (&&) <$> aux s1 <*> aux s2
|
|
aux (Or s1 s2) = (||) <$> aux s1 <*> aux s2
|
|
aux (Implies s1 s2) = not <$> ((&&) <$> aux s1 <*> (not <$> aux s2))
|
|
aux (Iff s1 s2) = (==) <$> aux s1 <*> aux s2
|
|
|
|
enumerate :: [a] -> [[(a, Bool)]]
|
|
enumerate keys = map reverse $ aux start
|
|
where
|
|
aux assignments = (assignments:) $
|
|
case next assignments of
|
|
Nothing -> []
|
|
Just (assignments') -> aux assignments'
|
|
|
|
start = map (, False) keys
|
|
|
|
next [] = Nothing
|
|
next ((key, False):rest) = Just $ (key, True):rest
|
|
next ((key, True):rest) = ((key, False):) <$> (next rest)
|
|
|
|
implies :: Bool -> Bool -> Bool
|
|
implies b1 b2 = not b1 || b2
|