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 -- partain: some changes taken from Hugs 1.0 demo version
    8 --
    9 module PrologData(Id, Atom, Term(..), term, termlist, varsIn,
   10                   Clause((:==)), clause,
   11                   Database, emptyDb, renClauses, addClause, Parser ) where
   12 
   13 import Parse
   14 import List(nub)--1.3
   15 import Char(isAlpha,isDigit,isUpper)
   16 
   17 infix 6 :==
   18 
   19 --- Prolog Terms:
   20 
   21 type Id       = (Int,String)
   22 type Atom     = String
   23 data Term     = Var Id | Struct Atom [Term]
   24 data Clause   = Term :== [Term]
   25 data Database = Db [(Atom,[Clause])]
   26 
   27 instance Eq Term where
   28     Var v       == Var w       =  v==w
   29     Struct a ts == Struct b ss =  a==b && ts==ss
   30     _           == _           =  False
   31 
   32 --- Determine the list of variables in a term:
   33 
   34 varsIn              :: Term -> [Id]
   35 varsIn (Var i)       = [i]
   36 varsIn (Struct i ts) = (nub . concat . map varsIn) ts
   37 
   38 renameVars                  :: Int -> Term -> Term
   39 renameVars lev (Var (n,s))   = Var (lev,s)
   40 renameVars lev (Struct s ts) = Struct s (map (renameVars lev) ts)
   41 
   42 --- Functions for manipulating databases (as an abstract datatype)
   43 
   44 emptyDb      :: Database
   45 emptyDb       = Db []
   46 
   47 renClauses                  :: Database -> Int -> Term -> [Clause]
   48 renClauses db n (Var _)      = []
   49 renClauses db n (Struct a _) = [ r tm:==map r tp | (tm:==tp)<-clausesFor a db ]
   50                                where r = renameVars n
   51 
   52 clausesFor           :: Atom -> Database -> [Clause]
   53 clausesFor a (Db rss) = case dropWhile (\(n,rs) -> n<a) rss of
   54                          []         -> []
   55                          ((n,rs):_) -> if a==n then rs else []
   56 
   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 Text):
   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 Text:
   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 `seQ` many letter `doo` makeVar
  104                 where makeVar (initial,rest) = Var (0,(initial:rest))
  105 
  106 struct       :: Parser Term
  107 struct        = many letter `seQ` (sptok "(" `seQ` termlist `seQ` sptok ")"
  108                                        `doo` (\(o,(ts,c))->ts)
  109                                   `orelse`
  110                                    okay [])
  111                 `doo` (\(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 `seQ` (sptok ":==" `seQ` listOf term (sptok ",")
  123                                  `doo` (\(from,body)->body)
  124                                 `orelse` okay [])
  125                           `seQ` sptok "."
  126                      `doo` (\(head,(goals,dot))->head:==goals)
  127 
  128 --- End of PrologData.hs