Coverage report: /development/source/library/org/datagraph/spocq-shard/src/core/patmatch.lisp

Kind	Covered	All	%
expression	117	346	33.8
branch	30	70	42.9

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: org.datagraph.spocq.implementation; -*-

2

3

(in-package :org.datagraph.spocq.implementation)

4

5

(:documentation "This file defines the DISTINCT operator for the 'org.datagraph.spocq' RDF engine."

6

7

(copyright

8

9

Two bug fixes By Richard Fateman, rjf@cs.berkeley.edu October 92.

10

11

12

(long-description

13

"This is based on the 'File pat-match.lisp: Pattern matcher from section 6.2' from Norvig's

14

'Principles of AI Programming' under its [license](http://norvig.com/license.html), with

15

modifications to

16

- integrate in the spocq implementation package

17

- rename conflicting operators

18

- add the operator, ?bind, which adds a bindings to the current environment

19

20

Several of the macro expansions for algebra operators speculate with the rule-based-translator

21

preliminary to a 'standard' expansion to recognize and translate idioms."))

22

23

24

(defconstant fail nil "Indicates pat-match failure")

25

26

(defvar no-bindings '((t . t))

27

"Indicates pat-match success, with no variables.")

28

29

30

(defun match-variable-p (x)

31

"Is x a variable (a symbol beginning with `?')?"

32

(and (symbolp x) (equal (char (symbol-name x) 0) #\?)))

33

34

(defun get-binding (var bindings)

35

"Find a (variable . value) pair in a binding list."

36

(assoc var bindings))

37

38

(defun binding-var (binding)

39

"Get the variable part of a single binding."

40

(car binding))

41

42

(defun binding-val (binding)

43

"Get the value part of a single binding."

44

(cdr binding))

45

46

(defun make-binding (var val) (cons var val))

47

48

(defun lookup (var bindings)

49

"Get the value part (for var) from a binding list."

50

(binding-val (get-binding var bindings)))

51

52

(defun extend-bindings (var val bindings)

53

"Add a (var . value) pair to a binding list."

54

(cons (make-binding var val)

55

;; Once we add a "real" binding,

56

;; we can get rid of the dummy no-bindings

57

(if (eq bindings no-bindings)

58

nil

59

bindings)))

60

61

(defun match-variable (var input bindings)

62

"Does VAR match input? Uses (or updates) and returns bindings."

63

(let ((binding (get-binding var bindings)))

64

(cond ((not binding) (extend-bindings var input bindings))

65

((equal input (binding-val binding)) bindings)

66

(t fail))))

67

68

(setf (get '?is 'single-match) 'match-is)

69

(setf (get '?or 'single-match) 'match-or)

70

(setf (get '?and 'single-match) 'match-and)

71

(setf (get '?not 'single-match) 'match-not)

72

73

(setf (get '?* 'segment-match) 'segment-match)

74

(setf (get '?+ 'segment-match) 'segment-match+)

75

(setf (get '?? 'segment-match) 'segment-match?)

76

(setf (get '?if 'segment-match) 'match-if)

77

78

(defun segment-pattern-p (pattern)

79

"Is this a segment-matching pattern like ((?* var) . pat)?"

80

(and (consp pattern) (consp (first pattern))

81

(symbolp (first (first pattern)))

82

(segment-match-fn (first (first pattern)))))

83

84

(defun single-pattern-p (pattern)

85

"Is this a single-matching pattern?

86

E.g. (?is x predicate) (?and . patterns) (?or . patterns)."

87

(and (consp pattern)

88

(single-match-fn (first pattern))))

89

90

(defun segment-matcher (pattern input bindings)

91

"Call the right function for this kind of segment pattern."

92

(funcall (segment-match-fn (first (first pattern)))

93

pattern input bindings))

94

95

(defun single-matcher (pattern input bindings)

96

"Call the right function for this kind of single pattern."

97

(funcall (single-match-fn (first pattern))

98

(rest pattern) input bindings))

99

100

(defun segment-match-fn (x)

101

"Get the segment-match function for x,

102

if it is a symbol that has one."

103

(when (symbolp x) (get x 'segment-match)))

104

105

(defun single-match-fn (x)

106

"Get the single-match function for x,

107

if it is a symbol that has one."

108

(when (symbolp x) (get x 'single-match)))

109

110

(defun match-is (var-and-pred input bindings)

111

"Succeed and bind var if the input satisfies pred,

112

where var-and-pred is the list (var pred)."

113

(let* ((var (first var-and-pred))

114

(pred (second var-and-pred))

115

(new-bindings (pat-match var input bindings)))

116

(if (or (eq new-bindings fail)

117

(not (funcall pred input)))

118

fail

119

new-bindings)))

120

121

(defun match-and (patterns input bindings)

122

"Succeed if all the patterns match the input."

123

(cond ((eq bindings fail) fail)

124

((null patterns) bindings)

125

(t (match-and (rest patterns) input

126

(pat-match (first patterns) input

127

bindings)))))

128

129

(defun match-or (patterns input bindings)

130

"Succeed if any one of the patterns match the input."

131

(if (null patterns)

132

fail

133

(let ((new-bindings (pat-match (first patterns)

134

input bindings)))

135

(if (eq new-bindings fail)

136

(match-or (rest patterns) input bindings)

137

new-bindings))))

138

139

(defun match-not (patterns input bindings)

140

"Succeed if none of the patterns match the input.

141

This will never bind any variables."

142

(if (match-or patterns input bindings)

143

fail

144

bindings))

145

146

(defun segment-match (pattern input bindings &optional (start 0))

147

"Match the segment pattern ((?* var) . pat) against input."

148

(let ((var (second (first pattern)))

149

(pat (rest pattern)))

150

(if (null pat)

151

(match-variable var input bindings)

152

(let ((pos (first-match-pos (first pat) input start)))

153

(if (null pos)

154

fail

155

(let ((b2 (pat-match

156

pat (subseq input pos)

157

(match-variable var (subseq input 0 pos)

158

bindings))))

159

;; If this match failed, try another longer one

160

(if (eq b2 fail)

161

(segment-match pattern input bindings (+ pos 1))

162

b2)))))))

163

164

(defun first-match-pos (pat1 input start)

165

"Find the first position that pat1 could possibly match input,

166

starting at position start. If pat1 is non-constant, then just

167

return start."

168

(cond ((and (atom pat1) (not (match-variable-p pat1)))

169

(position pat1 input :start start :test #'equal))

170

((<= start (length input)) start) ;*** fix, rjf 10/1/92 (was <)

171

(t nil)))

172

173

(defun segment-match+ (pattern input bindings)

174

"Match one or more elements of input."

175

(segment-match pattern input bindings 1))

176

177

(defun segment-match? (pattern input bindings)

178

"Match zero or one element of input."

179

(let ((var (second (first pattern)))

180

(pat (rest pattern)))

181

(or (pat-match (cons var pat) input bindings)

182

(pat-match pat input bindings))))

183

184

(defun match-if (pattern input bindings)

185

"Test an arbitrary expression involving variables.

186

The pattern looks like ((?if code) . rest)."

187

;; *** fix, rjf 10/1/92 (used to eval binding values)

188

(and (progv (mapcar #'car bindings)

189

(mapcar #'cdr bindings)

190

(eval (second (first pattern))))

191

(pat-match (rest pattern) input bindings)))

192

193

(defun pat-match-abbrev (symbol expansion)

194

"Define symbol as a macro standing for a pat-match pattern."

195

(setf (get symbol 'expand-pat-match-abbrev)

196

(expand-pat-match-abbrev expansion)))

197

198

(defun expand-pat-match-abbrev (pat)

199

"Expand out all pattern matching abbreviations in pat."

200

(cond ((and (symbolp pat) (get pat 'expand-pat-match-abbrev)))

201

((atom pat) pat)

202

(t (cons (expand-pat-match-abbrev (first pat))

203

(expand-pat-match-abbrev (rest pat))))))

204

205

206

;;; binding operator

207

208

(setf (get '?bind 'segment-match) 'bind-match-variable)

209

210

(defun bind-match-variable (pattern input bindings)

211

"bind a variable to the value of an arbitrary expression.

212

The pattern looks like ((?bind (variable code) ...) . rest)."

213

214

(destructuring-bind ((?bind . new-bindings) . remaining-pattern) pattern

215

(declare (ignore ?bind))

216

(progv (mapcar #'car bindings)

217

(mapcar #'cdr bindings)

218

(loop for (variable expression) in new-bindings

219

do (setf bindings (extend-bindings variable (eval expression) bindings))) )

220

(pat-match remaining-pattern input bindings)))

221

222

223

;;; interface

224

225

(defun pat-match (pattern input &optional (bindings no-bindings))

226

"Match pattern against input in the context of the bindings"

227

(cond ((eq bindings fail) fail)

228

((match-variable-p pattern)

229

(match-variable pattern input bindings))

230

((eql pattern input) bindings)

231

((segment-pattern-p pattern)

232

(segment-matcher pattern input bindings))

233

((single-pattern-p pattern) ; ***

234

(single-matcher pattern input bindings)) ; ***

235

((and (consp pattern) (consp input))

236

(pat-match (rest pattern) (rest input)

237

(pat-match (first pattern) (first input)

238

bindings)))

239

(t fail)))

240

241

(defun rule-based-translator

242

(input rules &key (matcher #'pat-match)

243

(rule-if #'first) (rule-then #'rest) (action #'sublis))

244

"Find the first rule in rules that matches input,

245

and apply the action to that rule."

246

(some

247

#'(lambda (rule)

248

(let ((result (funcall matcher (funcall rule-if rule)

249

input)))

250

(if (not (eq result fail))

251

(funcall action result (funcall rule-then rule)))))

252

rules))

253

254

;;; (pat-match '(test ?x (?bind (?y (cons ?x ?x))) ?z) '(test 1 2))