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