home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / hugs_1 / demos_prolog_hs_Main < prev    next >
Encoding:
Text File  |  1996-08-12  |  3.1 KB  |  92 lines
  1. -- Prolog interpreter top level module
  2. -- Mark P. Jones November 1990, modified for Gofer 20th July 1991,
  3. -- and for Hugs 1.3 June 1996.
  4. --
  5. -- Suitable for use with Hugs 1.3.
  6. --
  7.  
  8. module Main where
  9.  
  10. import CombParse
  11. import Prolog
  12. import Interact
  13. import Subst
  14. import StackEngine
  15.  
  16. --- Command structure and parsing:
  17.  
  18. data Command = Fact Clause | Query [Term] | Show | Error | Quit | NoChange
  19.  
  20. command :: Parser Command
  21. command  = just (sptok "bye" `orelse` sptok "quit") `pam` (\quit->Quit)
  22.                `orelse`
  23.            just (okay NoChange)
  24.                `orelse`
  25.            just (sptok "??") `pam` (\show->Show)
  26.                `orelse`
  27.            just clause `pam` Fact
  28.                `orelse`
  29.            just (sptok "?-" `pseq` termlist) `pam` (\(q,ts)->Query ts)
  30.                `orelse`
  31.            okay Error
  32.  
  33. --- Main program read-solve-print loop:
  34.  
  35. signOn           :: String
  36. signOn            = "Mini Prolog Version 1.5g (" ++ version ++ ")\n\n"
  37.  
  38. main             :: IO ()
  39. main              = do putStr signOn
  40.                        putStr ("Reading " ++ stdlib)
  41.                clauses <- readLibrary stdlib
  42.                        interpreter clauses
  43.  
  44. readLibrary lib   = do is <- readFile lib
  45.                        let parse   = map clause (lines is)
  46.                            clauses = [ r | ((r,""):_) <- parse ]
  47.                            reading = ['.'| c <- clauses] ++ "done\n"
  48.                        putStr reading
  49.                return clauses
  50.             `catch` \err ->
  51.                     do putStr "...not found\n"
  52.                        return []
  53.  
  54. stdlib           :: String
  55. stdlib            = "stdlib"
  56.  
  57. interpreter      :: [Clause] -> IO ()
  58. interpreter lib   = do is <- getContents
  59.                        putStr (loop startDb is)
  60.                     where startDb = foldl addClause emptyDb lib
  61.  
  62. loop             :: Database -> String -> String
  63. loop db           = readLine "> " (exec db . fst . head . command)
  64.  
  65. exec             :: Database -> Command -> String -> String
  66. exec db (Fact r)  = loop (addClause db r)
  67. exec db (Query q) = demonstrate db q
  68. exec db Show      = writeStr (show db)                 (loop db)
  69. exec db Error     = writeStr "I don't understand\n"    (loop db)
  70. exec db Quit      = writeStr "Thank you and goodbye\n" end
  71. exec db NoChange  = loop db
  72.  
  73. --- Handle printing of solutions etc...
  74.  
  75. solution      :: [Id] -> Subst -> [String]
  76. solution vs s  = [ show (Var i) ++ " = " ++ show v
  77.                                 | (i,v) <- [ (i,s i) | i<-vs ], v /= Var i ]
  78.  
  79. demonstrate     :: Database -> [Term] -> Interact
  80. demonstrate db q = printOut (map (solution vs) (prove db q))
  81.  where vs               = (nub . concat . map varsIn) q
  82.        printOut []      = writeStr "no.\n"     (loop db)
  83.        printOut ([]:bs) = writeStr "yes.\n"    (loop db)
  84.        printOut (b:bs)  = writeStr (doLines b) (nextReqd bs)
  85.        doLines          = foldr1 (\xs ys -> xs ++ "\n" ++ ys)
  86.        nextReqd bs      = writeStr " "
  87.                           (readChar end
  88.                            (\c-> if c==';' then writeStr ";\n" (printOut bs)
  89.                                            else writeStr "\n"  (loop db)))
  90.  
  91. --- End of Main.hs
  92.