1 files changed, 121 insertions, 0 deletions
diff --git a/progs/demo/prolog/PrologData.hs b/progs/demo/prolog/PrologData.hs
new file mode 100644
index 0000000..4ff3173
--- /dev/null
+++ b/progs/demo/prolog/PrologData.hs
@@ -0,0 +1,121 @@
+--
+-- Representation of Prolog Terms, Clauses and Databases
+-- Mark P. Jones November 1990
+--
+-- uses Haskell B. version 0.99.3
+--
+module PrologData(Id(..), Atom(..), Term(..), term, termlist, varsIn,
+                  Clause((:*)), clause,
+                  Database, emptyDb, renClauses, addClause) where
+
+import Parse
+
+infix 6 :*
+
+--- Prolog Terms:
+
+type Id       = (Int,String)
+type Atom     = String
+data Term     = Var Id | Struct Atom [Term]
+                deriving Eq
+data Clause   = Term :* [Term]
+data Database = Db [(Atom,[Clause])]
+
+--- Determine the list of variables in a term:
+
+varsIn              :: Term -> [Id]
+varsIn (Var i)       = [i]
+varsIn (Struct i ts) = (nub . concat . map varsIn) ts
+
+renameVars                  :: Int -> Term -> Term
+renameVars lev (Var (n,s))   = Var (lev,s)
+renameVars lev (Struct s ts) = Struct s (map (renameVars lev) ts)
+
+--- Functions for manipulating databases (as an abstract datatype)
+
+emptyDb      :: Database
+emptyDb       = Db []
+
+renClauses                  :: Database -> Int -> Term -> [Clause]
+renClauses db n (Var _)      = []
+renClauses db n (Struct a _) = [ r tm:*map r tp | (tm:*tp)<-clausesFor a db ]
+                               where r = renameVars n
+
+clausesFor           :: Atom -> Database -> [Clause]
+clausesFor a (Db rss) = case dropWhile (\(n,rs) -> n<a) rss of
+                         []         -> []
+                         ((n,rs):_) -> if a==n then rs else []
+
+addClause :: Database -> Clause -> Database
+addClause (Db rss) r@(Struct a _ :* _)
+         = Db (initialPart ++
+               case lastPart of
+                 []            -> [(a,[r])]
+                 ((n,rs):rss') -> if a==n then (n,rs++[r]):rss'
+                                          else (a,[r]):lastPart)
+           where (initialPart,lastPart) = span (\(n,rs) -> n<a) rss
+
+--- Output functions (defined as instances of Text):
+
+instance Text Term where
+  showsPrec p (Var (n,s))
+              | n==0        = showString s
+              | otherwise   = showString s . showChar '_' . shows n
+  showsPrec p (Struct a []) = showString a
+  showsPrec p (Struct a ts) = showString a . showChar '('
+                                           . showWithSep "," ts
+                                           . showChar ')'
+
+instance Text Clause where
+   showsPrec p (t:*[]) = shows t . showChar '.'
+   showsPrec p (t:*gs) = shows t . showString ":-"
+                                 . showWithSep "," gs
+                                 . showChar '.'
+
+instance Text Database where
+    showsPrec p (Db [])  = showString "-- Empty Database --\n"
+    showsPrec p (Db rss) = foldr1 (\u v-> u . showChar '\n' . v)
+                                  [ showWithTerm "\n" rs | (i,rs)<-rss ]
+
+--- Local functions for use in defining instances of Text:
+
+showWithSep          :: Text a => String -> [a] -> ShowS
+showWithSep s [x]     = shows x
+showWithSep s (x:xs)  = shows x . showString s . showWithSep s xs
+
+showWithTerm         :: Text a => String -> [a] -> ShowS
+showWithTerm s xs     = foldr1 (.) [shows x . showString s | x<-xs]
+
+--- String parsing functions for Terms and Clauses:
+--- Local definitions:
+
+letter       :: Parser Char
+letter        = sat (\c -> isAlpha c || isDigit c || c `elem` ":;+=-*&%$#@?/.~!")
+
+variable     :: Parser Term
+variable      = sat isUpper `seq` many letter `do` makeVar
+                where makeVar (initial,rest) = Var (0,(initial:rest))
+
+struct       :: Parser Term
+struct        = many letter `seq` (sptok "(" `seq` termlist `seq` sptok ")"
+                                       `do` (\(o,(ts,c))->ts)
+                                  `orelse`
+                                   okay [])
+                `do` (\(name,terms)->Struct name terms)
+
+--- Exports:
+
+term         :: Parser Term
+term          = sp (variable `orelse` struct)
+
+termlist     :: Parser [Term]
+termlist      = listOf term (sptok ",")
+
+clause       :: Parser Clause
+clause        = sp struct `seq` (sptok ":-" `seq` listOf term (sptok ",")
+                                 `do` (\(from,body)->body)
+                                `orelse` okay [])
+                          `seq` sptok "."
+                     `do` (\(head,(goals,dot))->head:*goals)
+
+--- End of PrologData.hs