1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
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
|