home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / demo / prolog / Main.hs < prev    next >
Encoding:
Text File  |  1994-09-27  |  2.9 KB  |  84 lines  |  [TEXT/YHS2]
  1. --
  2. -- Prolog interpreter top level module
  3. -- Mark P. Jones November 1990
  4. --
  5. -- uses Haskell B. version 0.99.3
  6. --
  7.  
  8. module Main(main) where
  9.  
  10. import PrologData
  11. import Parse
  12. import Interact
  13. import Subst
  14. import Engine
  15. import Version
  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") `do` (\quit->Quit)
  23.                `orelse`
  24.            just (okay NoChange)
  25.                `orelse`
  26.            just (sptok "??") `do` (\show->Show)
  27.                `orelse`
  28.            just clause `do` Fact
  29.                `orelse`
  30.            just (sptok "?-" `seq` termlist) `do` (\(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.5 (" ++ version ++ ")\n\n"
  38.  
  39. main             :: IO ()
  40. main              = putStr signOn >>
  41.                     putStr ("Reading " ++ stdlib ++ "...\n") >>
  42.             (try (readFile stdlib)
  43.                       (\_ -> putStr "Library not found\n" >> return "")) >>=
  44.                    interpreter
  45.  
  46. stdlib           :: String
  47. stdlib            = "$HASKELL/progs/demo/prolog/stdlib"
  48.  
  49. interpreter      :: String -> IO ()
  50. interpreter lib   = getContents stdin >>= (\inn -> putStr (loop startDb inn))
  51.                     where startDb = foldl addClause emptyDb clauses
  52.                           clauses = [r | ((r,""):_)<-map clause (lines lib)]
  53.  
  54. loop             :: Database -> String -> String
  55. loop db           = readln "> " (exec db . fst . head . command)
  56.  
  57. exec             :: Database -> Command -> String -> String
  58. exec db (Fact r)  = skip                              (loop (addClause db r))
  59. exec db (Query q) = demonstrate db q
  60. exec db Show      = writeln (show db)                 (loop db)
  61. exec db Error     = writeln "I don't understand\n"    (loop db)
  62. exec db Quit      = writeln "Thank you and goodbye\n" end
  63. exec db NoChange  = skip                              (loop db)
  64.  
  65. --- Handle printing of solutions etc...
  66.  
  67. solution      :: [Id] -> Subst -> [String]
  68. solution vs s  = [ show (Var i) ++ " = " ++ show v
  69.                                 | (i,v) <- [ (i,s i) | i<-vs ], v /= Var i ]
  70.  
  71. demonstrate     :: Database -> [Term] -> Interactive
  72. demonstrate db q = printOut (map (solution vs) (prove db q))
  73.  where vs               = (nub . concat . map varsIn) q
  74.        printOut []      = writeln "no.\n"     (loop db)
  75.        printOut ([]:bs) = writeln "yes.\n"    (loop db)
  76.        printOut (b:bs)  = writeln (doLines b) (nextReqd bs)
  77.        doLines          = foldr1 (\xs ys -> xs ++ "\n" ++ ys)
  78.        nextReqd bs      = writeln " "
  79.                             (readch (\c->if c==';'
  80.                                            then writeln ";\n" (printOut bs)
  81.                                            else writeln "\n"  (loop db)) "")
  82.  
  83. --- End of Main.hs
  84.