Haskell Quiz/Inference Engine/Solution Kristof

module Main where
import Prelude hiding (lookup)
import Char
import Maybe
import Monad
import Control.Monad.Error
import List hiding (lookup, insert)
import Data.Map as Map hiding (map, null, union, delete, mapMaybe, (\\))
import Text.Printf
import Text.Regex
import System.IO
    
data Answer = Yes | No | DontKnow
type Relation = Map Class [Class]
data Class = SomeClass Int | Class String
           deriving (Eq, Ord, Show)

data KB = KB {isDB :: Relation, hasDB :: Relation,
              isntDB :: Relation, lastID :: Int}

data Rule   = All | None | SomeAre | SomeArent
            deriving (Show)
data Action = Question Rule String String | Stmt Rule String String | Describe String
            deriving (Show)

(?) a  b c = if a then b else c

fail_msg    = "I didn't understand that phrase."
unknown :: String -> String
unknown str = printf "I don't know anything about %s." str
              
-- Find all the nodes that can be reached from 
-- the nodes in xs, using the given map.  
nodes_from :: [Class] -> Relation -> [Class]
nodes_from xs map = snd $ traverse [] xs [] where
  traverse visited [] rest = (visited, rest)
  traverse visited (x:xs) rest = case x `elem` visited of
    True  -> traverse visited xs rest
    False -> let (v2, branch) = traverse (x:visited) 
                                (fromMaybe [] $ lookup x map) rest2
                 (v3, rest2)  = traverse v2 xs rest
             in (v3, x:branch)

supersets x kb = nodes_from [Class x] (isDB kb)

overlapping_sets x kb = 
  let subsets = nodes_from [Class x] (hasDB kb)
  in nodes_from subsets (isDB kb)

complement_set x kb = 
  let compl = nub $ concatMap (\x -> fromMaybe [] $ lookup x (isntDB kb)) $
              supersets x kb
  in nodes_from compl (hasDB kb)
      
complement_subsets x kb =
  let compl = nub $ concatMap (\x -> fromMaybe [] $ lookup x (isntDB kb)) $
              nodes_from [Class x] (hasDB kb)
  in nodes_from compl (hasDB kb)

all_are x y kb    = (Class y) `elem` supersets x kb
no_are x y kb     = (Class y) `elem` complement_set x kb
some_are x y kb   = (Class y) `elem` overlapping_sets x kb
some_arent x y kb = no_are x y kb || 
                    (Class y) `elem` complement_subsets x kb
                    
kbmember n kb = let 
  cls = Class (map toLower n) 
  in member cls (isDB kb) ||
     member cls (hasDB kb) ||
     member cls (isntDB kb)
  
parse_rule :: String -> KB -> Either String Action  
parse_rule inp kb = let
  str = map toLower $ unwords $ words inp
  
  check_word n = if kbmember n kb then 
                   Right n else Left (unknown n)
  
  check2 cons n m = do
    check_word n; check_word m
    Right (cons n m)
    
  -- try each combination of pairs agains the words
  -- in the knowledgebase
  try_pairs cons (n:m@(h:t)) = 
    check2 cons n (unwords m) `mplus`
    try_pairs cons ((n++" "++h):t)
  try_pairs cons _ = Left (unknown "such a thing")
  
  stmt rule rx =
    do [n, m] <- matchRegex (mkRegex rx) str
       Just $ Right $ Stmt rule n m
    
  question2 rule rx =
    do [n, m] <- matchRegex (mkRegex rx) str
       Just $ check2 (Question rule) n m
  
  question1 rule rx =
    do [s] <- matchRegex (mkRegex rx) str
       Just $ try_pairs (Question rule) (words s)
       
  describe = do [n] <- matchRegex (mkRegex "describe ([^.]+)\\.?") str
                Just $ if kbmember n kb 
                       then Right $ Describe n
                       else Left $ unknown n
  
  parsed = msum [
    stmt All "all (.+) are ([^.]+)\\.?",
    stmt None "no (.+) are ([^.]+)\\.?",
    stmt SomeArent "some (.+) are not ([^.]+)\\.?",
    stmt SomeAre "some (.+) are ([^.]+)\\.?",
    question2 SomeArent "are any (.+) not (.+)\\?",
    question1 All "are all (.+)\\?",
    question1 None "are no (.+)\\?",
    question1 SomeAre "are any (.+)\\?",
    describe]

  in fromMaybe (Left fail_msg) parsed

check_statement kb rule n m = case rule of
  All -> 
    all_are    n m kb ? Yes $
    some_arent n m kb ? No  $
    DontKnow
  None -> 
    no_are     n m kb ? Yes $
    some_are   n m kb ? No  $
    DontKnow
  SomeAre -> 
    some_are n m kb ? Yes $
    no_are   n m kb ? No  $
    DontKnow
  SomeArent -> 
    some_arent n m kb ? Yes $
    all_are n m kb    ? No  $
    DontKnow
    
show_confirm rule s s2 =
  case rule of
    All       -> printf "Yes, all %s are %s.\n" s s2
    None      -> printf "Yes, no %s are %s.\n" s s2
    SomeAre   -> printf "Yes, some %s are %s.\n" s s2
    SomeArent -> printf "Yes, some %s are not %s.\n" s s2

show_negate rule s s2 =
  case rule of
    All       -> printf "No, not all %s are %s.\n" s s2
    None      -> printf "No, some %s are %s.\n" s s2
    SomeAre   -> printf "No, no %s are %s.\n" s s2
    SomeArent -> printf "No, all %s are %s.\n" s s2

insert_rel :: Class -> Class -> Relation -> Relation
insert_rel n m db = insert n (m: (fromMaybe [] $ lookup n db)) db

insert_is_rel n m (KB isDB hasDB ndb l) =
  KB (insert_rel n m isDB) 
     (insert_rel m n hasDB)
     ndb l

insert_isnt_rel n m kb =  
  kb {isntDB = insert_rel m n $ 
               insert_rel n m (isntDB kb)}

new_id kb = (SomeClass $ lastID kb,
             kb {lastID = 1 + lastID kb})

add_rule (Stmt rule s t) kb = let
  n = Class s; m = Class t 
  in case rule of
    All       -> insert_is_rel n m kb
    None      -> kb {isntDB = insert_rel n m (isntDB kb)}
    SomeAre   -> let (it, kb') = new_id kb
                 in insert_is_rel it n $
                    insert_is_rel it m kb'
    SomeArent -> let (it, kb') = new_id kb
                 in insert_is_rel it n $
                    kb' {isntDB = insert_rel it m (isntDB kb)}

process_statement :: Action -> KB -> IO KB
process_statement (Question rule n m) kb = 
  do case check_statement kb rule n m of
       Yes -> show_confirm rule n m
       No  -> show_negate rule n m
       DontKnow -> putStrLn "I don't know."
     return kb
    
process_statement stmt@(Stmt rule n m) kb = 
  case check_statement kb rule n m of
    Yes -> do putStrLn "I know."; return kb
    No  -> do putStrLn "Sorry, that contradicts what I already know.";
              return kb
    DontKnow -> do putStrLn "OK."; return (add_rule stmt kb)
    
process_statement (Describe b) kb =
  let get_classes l = [x | (Class x) <- l]
      all  = delete b (get_classes $ supersets b kb)
      some = (get_classes $ overlapping_sets b kb) \\ (b:all)
      none = get_classes $ complement_set b kb
      somenot = (get_classes $ complement_subsets b kb) \\ (b:none)
  in do
    mapM_ (printf "All %s are %s.\n" b) all
    mapM_ (printf "Some %s are %s.\n" b) some
    mapM_ (printf "No %s are %s.\n" b) none
    mapM_ (printf "Some %s are not %s.\n" b) somenot
    return kb
  
main = respond (KB Map.empty Map.empty Map.empty 0) where
  respond :: KB -> IO ()
  respond kb = do
    putStr "> "; hFlush stdout
    l <- getLine
    case parse_rule l kb of
      Left err    -> do 
        putStrLn err; respond kb
      Right action -> do
        kb' <- process_statement action kb
        respond kb'