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