home *** CD-ROM | disk | FTP | other *** search
/ PSION CD 2 / PsionCDVol2.iso / Programs / 876 / hugs.sis / Prolog.hs < prev    next >
Encoding:
Text File  |  2000-09-21  |  4.3 KB  |  129 lines
  1. -- Representation of Prolog Terms, Clauses and Databases
  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 Prolog
  9.     ( Id, Term(..), Clause(..), Database
  10.     , varsIn, renClauses, addClause, emptyDb, termlist, clause
  11.     ) where
  12.  
  13. import List
  14. import CombParse
  15.  
  16. infix 6 :-
  17.  
  18. --- Prolog Terms:
  19.  
  20. type Id       = (Int,String)
  21. type Atom     = String
  22. data Term     = Var Id | Struct Atom [Term]
  23. data Clause   = Term :- [Term]
  24. data Database = Db [(Atom,[Clause])]
  25.  
  26. instance Eq Term where
  27.     Var v       == Var w       =  v==w
  28.     Struct a ts == Struct b ss =  a==b && ts==ss
  29.     _           == _           =  False
  30.  
  31. --- Determine the list of variables in a term:
  32.  
  33. varsIn              :: Term -> [Id]
  34. varsIn (Var i)       = [i]
  35. varsIn (Struct i ts) = (nub . concat . map varsIn) ts
  36.  
  37. renameVars                  :: Int -> Term -> Term
  38. renameVars lev (Var (n,s))   = Var (lev,s)
  39. renameVars lev (Struct s ts) = Struct s (map (renameVars lev) ts)
  40.  
  41. --- Functions for manipulating databases (as an abstract datatype)
  42.  
  43. emptyDb      :: Database
  44. emptyDb       = Db []
  45.  
  46. renClauses                  :: Database -> Int -> Term -> [Clause]
  47. renClauses db n (Var _)      = []
  48. renClauses db n (Struct a _) = [ r tm:-map r tp | (tm:-tp)<-clausesFor a db ]
  49.                                where r = renameVars n
  50.  
  51. clausesFor           :: Atom -> Database -> [Clause]
  52. clausesFor a (Db rss) = case dropWhile (\(n,rs) -> n<a) rss of
  53.                          []         -> []
  54.                          ((n,rs):_) -> if a==n then rs else []
  55.  
  56. addClause :: Database -> Clause -> Database
  57. addClause (Db rss) r@(Struct a _ :- _)
  58.            = Db (update rss)
  59.              where update []            = [(a,[r])]
  60.                    update (h@(n,rs):rss')
  61.                           | n==a        = (n,rs++[r]) : rss'
  62.                   | n<a         = h : update rss'
  63.                           | otherwise   = (a,[r]) : h : rss'
  64.  
  65. --- Output functions (defined as instances of Show):
  66.  
  67. instance Show Term where
  68.   showsPrec p (Var (n,s))
  69.               | n==0        = showString s
  70.               | otherwise   = showString s . showChar '_' . shows n
  71.   showsPrec p (Struct a []) = showString a
  72.   showsPrec p (Struct a ts) = showString a . showChar '('
  73.                                            . showWithSep "," ts
  74.                                            . showChar ')'
  75.  
  76. instance Show Clause where
  77.    showsPrec p (t:-[]) = shows t . showChar '.'
  78.    showsPrec p (t:-gs) = shows t . showString ":-"
  79.                                  . showWithSep "," gs
  80.                                  . showChar '.'
  81.  
  82. instance Show Database where
  83.     showsPrec p (Db [])  = showString "-- Empty Database --\n"
  84.     showsPrec p (Db rss) = foldr1 (\u v-> u . showChar '\n' . v)
  85.                                   [ showWithTerm "\n" rs | (i,rs)<-rss ]
  86.  
  87. --- Local functions for use in defining instances of Show:
  88.  
  89. showWithSep          :: Show a => String -> [a] -> ShowS
  90. showWithSep s [x]     = shows x
  91. showWithSep s (x:xs)  = shows x . showString s . showWithSep s xs
  92.  
  93. showWithTerm         :: Show a => String -> [a] -> ShowS
  94. showWithTerm s xs     = foldr1 (.) [shows x . showString s | x<-xs]
  95.  
  96. --- String parsing functions for Terms and Clauses:
  97. --- Local definitions:
  98.  
  99. letter       :: Parser Char
  100. letter        = sat (\c->isAlpha c || isDigit c || c `elem` ":;+=-*&%$#@?/.~!")
  101.  
  102. variable     :: Parser Term
  103. variable      = sat isUpper `pseq` many letter `pam` makeVar
  104.                 where makeVar (initial,rest) = Var (0,(initial:rest))
  105.  
  106. struct       :: Parser Term
  107. struct        = many letter `pseq` (sptok "(" `pseq` termlist `pseq` sptok ")"
  108.                                        `pam` (\(o,(ts,c))->ts)
  109.                                   `orelse`
  110.                                    okay [])
  111.                 `pam` (\(name,terms)->Struct name terms)
  112.  
  113. --- Exports:
  114.  
  115. term         :: Parser Term
  116. term          = sp (variable `orelse` struct)
  117.  
  118. termlist     :: Parser [Term]
  119. termlist      = listOf term (sptok ",")
  120.  
  121. clause       :: Parser Clause
  122. clause        = sp struct `pseq` (sptok ":-" `pseq` listOf term (sptok ",")
  123.                                  `pam` (\(from,body)->body)
  124.                                 `orelse` okay [])
  125.                           `pseq` sptok "."
  126.                      `pam` (\(head,(goals,dot))->head:-goals)
  127.  
  128. --- End of Prolog.hs
  129.