home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / hugs101.zip / hugs101sc.zip / hugsdist / demos / Expert / Main.hs < prev    next >
Text File  |  1995-02-14  |  4KB  |  90 lines
  1. {------------------------------------------------------------------------------
  2.                                  EXPERT SYSTEM
  3.  
  4. This prototype expert system program uses the modules `result.g', `table.g',
  5. `knowledge.g', `match.g' and `search.g'. The main program reads in the file
  6. `animals', treats the first line as the main goal to be solved, and converts
  7. the remaining lines into the table of definitions representing the permanent
  8. knowledge about the problem area. The program then solves the main goal and
  9. displays the questions and solutions to the user, using the answers to the
  10. questions to continue the search for solutions. Each answer should be `yes' or
  11. `no'. After each solution, the user is asked whether the solution is adequate
  12. or whether the search should be continued for alternative solutions.
  13. ------------------------------------------------------------------------------}
  14.  
  15. module Main where
  16. import Result
  17. import Table
  18. import Knowledge
  19. import Match
  20. import Search
  21.  
  22. -- The `main' function reads in the data file before interacting with user.
  23. -- The `process' function takes the contents of the file and the input from the
  24. -- user and produces the output. It builds an initial goal and a definition
  25. -- table from the file contents, and an information table from the user's
  26. -- input, and calls the `solve' function. The list of questions and solutions
  27. -- from this call is stripped to remove duplicate questions, and displayed as
  28. -- output.  The questions are also extracted and used to help build the
  29. -- information table which contains question-and-answer pairs.
  30.  
  31. main rs =
  32.    GetProgName : GetArgs :
  33.    let (r0:r1:rrs) = rs in
  34.    case r1 of
  35.       StrList [filename] -> getData filename rrs
  36.       StrList [] -> getData "animals" rrs
  37.       StrList args -> case r0 of
  38.          Str prog -> [AppendChan stderr ("Usage: " ++ prog ++ " datafile\n")]
  39.          Failure _ -> []
  40.  
  41. getData filename rs =
  42.    ReadFile filename :
  43.    let (r:rrs) = rs in
  44.    case r of
  45.       Failure ioerr -> [AppendChan stderr
  46.          ("Unable to read file " ++ filename ++ "\n")]
  47.       Str contents -> interact (process contents) rrs
  48.  
  49. process contents input =
  50.    "Solving: " ++ showPhrase problem ++ "\n" ++
  51.    display results (vars problem) replies
  52.    where
  53.    problem = goal (words (head (lines contents)))
  54.    defs = definitions (tail (lines contents))
  55.    info = enterList newTable [(q,a) | (Question q, a) <- zip results replies]
  56.    replies = [words l /= ["no"] | l <- lines input]
  57.    db = (defs,info)
  58.    newsoln = Soln newTable ['X' : show n | n<-[0..]]
  59.    results = strip [] (solve db newsoln problem)
  60.  
  61. -- The `strip' function takes the list of questions and solutions from the main
  62. -- call to `solve' and removes all but the first occurrence of each question,
  63. -- to make sure that the user is not asked the same question twice. The first
  64. -- argument is a list of the questions seen so far.
  65.  
  66. strip qs [] = []
  67. strip qs (Question q : rs) =
  68.    if elem q qs then strip qs rs else
  69.    Question q : strip (q:qs) rs
  70. strip qs (soln:rs) = soln : strip qs rs
  71.  
  72. -- The display function displays a list of questions and solutions as a
  73. -- character stream. It also takes the list of variable names in the original
  74. -- goal to interpret solution environments using `showVars', and the list of
  75. -- answers from the user to determine whether to continue displaying more
  76. -- solutions.
  77.  
  78. display [] xs as = "No (more) solutions\n"
  79. display (Question q : rs) xs as =
  80.    "Is it true that " ++ q ++ "?\n" ++ display rs xs (tail as)
  81. display (Soln env vs : rs) xs as =
  82.    "Solution: " ++ sol ++ ". More?\n" ++ etc  where
  83.    sol = showVars env xs
  84.    etc = if as == [] || head as == False then "" else display rs xs (tail as)
  85.  
  86. showVars env vs =
  87.    foldr1 join (map showVar vs) where
  88.    join x y = x ++ "; " ++ y
  89.    showVar v = v ++ " = " ++ showPhrase (subst env (Var v))
  90.