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