Browse code
feat: add datalog
Edward Langley authored on 14/03/2023 17:01:10
Showing 1 changed files
Showing 1 changed files
1 | 1 |
new file mode 100644 |
... | ... |
@@ -0,0 +1,324 @@ |
1 |
+(defpackage :fwoar.lisp-sandbox.datalog |
|
2 |
+ (:use :cl ) |
|
3 |
+ (:export )) |
|
4 |
+(in-package :fwoar.lisp-sandbox.datalog) |
|
5 |
+ |
|
6 |
+(defun entity-gen (min-id max-id) |
|
7 |
+ (when (< max-id min-id) |
|
8 |
+ (rotatef max-id min-id)) |
|
9 |
+ (lambda () |
|
10 |
+ (+ min-id (random (- max-id min-id))))) |
|
11 |
+ |
|
12 |
+(defun select (options) |
|
13 |
+ (let ((options (coerce options 'vector))) |
|
14 |
+ (lambda () |
|
15 |
+ (elt options (random (length options)))))) |
|
16 |
+ |
|
17 |
+(defun fact-gen (entity-gen |
|
18 |
+ attribute-gen |
|
19 |
+ value-gen) |
|
20 |
+ (lambda () |
|
21 |
+ (list (funcall entity-gen) |
|
22 |
+ (funcall attribute-gen) |
|
23 |
+ (funcall value-gen)))) |
|
24 |
+ |
|
25 |
+(defun facts-gen (n |
|
26 |
+ entity-gen |
|
27 |
+ attribute-gen |
|
28 |
+ value-gen) |
|
29 |
+ (let ((gen (fact-gen entity-gen attribute-gen value-gen))) |
|
30 |
+ (loop repeat n |
|
31 |
+ collect (funcall gen)))) |
|
32 |
+ |
|
33 |
+ |
|
34 |
+(defun alist->triples (alist) |
|
35 |
+ (mapcar (data-lens:juxt 'sxhash |
|
36 |
+ 'car |
|
37 |
+ 'cdr) |
|
38 |
+ alist)) |
|
39 |
+ |
|
40 |
+(defun plist->triples (plist) |
|
41 |
+ (loop for (k v) on plist by #'cddr |
|
42 |
+ collect (list (sxhash plist) |
|
43 |
+ k |
|
44 |
+ v))) |
|
45 |
+ |
|
46 |
+(defgeneric to-triples (object) |
|
47 |
+ (:documentation "convert OBJECT to a list of EAV triples") |
|
48 |
+ (:method-combination append) |
|
49 |
+ (:method append ((object hash-table)) |
|
50 |
+ (serapeum:with-collector (c) |
|
51 |
+ (let ((object-id (sxhash object))) |
|
52 |
+ (maphash (lambda (k v) |
|
53 |
+ (typecase v |
|
54 |
+ (string (c (list object-id k v))) |
|
55 |
+ (vector (map nil |
|
56 |
+ (lambda (it) |
|
57 |
+ (c (list object-id k it))) |
|
58 |
+ v)) |
|
59 |
+ (t (c (list object-id k v))))) |
|
60 |
+ object)))) |
|
61 |
+ (:method append ((object package)) |
|
62 |
+ (serapeum:with-collector (c) |
|
63 |
+ (flet ((handle-symbol (s) |
|
64 |
+ (when (boundp s) |
|
65 |
+ (c (list object :binding/variable s)) |
|
66 |
+ (alexandria:when-let ((doc (documentation s 'variable))) |
|
67 |
+ (c (list s :documentation/variable doc)))) |
|
68 |
+ (cond ((macro-function s) |
|
69 |
+ (c (list object :binding/macro s))) |
|
70 |
+ ((fboundp s) |
|
71 |
+ (c (list object :binding/function s)))) |
|
72 |
+ (alexandria:when-let ((doc (documentation s 'function))) |
|
73 |
+ (c (list s :documentation/function doc))) |
|
74 |
+ (alexandria:when-let ((doc (documentation s 'setf))) |
|
75 |
+ (c (list s :documentation/setf doc))))) |
|
76 |
+ (c (list object |
|
77 |
+ :package/name |
|
78 |
+ (package-name object))) |
|
79 |
+ (mapcar (lambda (nickname) |
|
80 |
+ (c (list object |
|
81 |
+ :package/nickname |
|
82 |
+ nickname))) |
|
83 |
+ (package-nicknames object)) |
|
84 |
+ (mapcar (lambda (use) |
|
85 |
+ (c (list object |
|
86 |
+ :package/uses |
|
87 |
+ use))) |
|
88 |
+ (package-use-list object)) |
|
89 |
+ (do-symbols (s object) |
|
90 |
+ (when (eql object |
|
91 |
+ (symbol-package s)) |
|
92 |
+ (c (list object |
|
93 |
+ (case (nth-value 1 |
|
94 |
+ (find-symbol (symbol-name s) |
|
95 |
+ object)) |
|
96 |
+ (:external :symbol/external) |
|
97 |
+ (:internal :symbol/internal) |
|
98 |
+ (:inherited :symbol/accessible)) |
|
99 |
+ s)) |
|
100 |
+ (handle-symbol s)))))) |
|
101 |
+ (:method append ((object cons)) |
|
102 |
+ (serapeum:with-collector (c) |
|
103 |
+ (let ((object-id (sxhash object))) |
|
104 |
+ (destructuring-bind (car . cdr) object |
|
105 |
+ (if (consp car) |
|
106 |
+ (progn (c (list object-id :car (sxhash car))) |
|
107 |
+ (mapc #'c (to-triples car))) |
|
108 |
+ (c (list object-id :car car))) |
|
109 |
+ (if (consp cdr) |
|
110 |
+ (progn (c (list object-id :cdr (sxhash cdr))) |
|
111 |
+ (mapc #'c (to-triples cdr))) |
|
112 |
+ (c (list object-id :cdr cdr)))))))) |
|
113 |
+ |
|
114 |
+(defmethod to-triples append ((object plump:element)) |
|
115 |
+ (serapeum:with-collector (c) |
|
116 |
+ (let ((object-id object)) |
|
117 |
+ (c (list object-id :tag (plump:tag-name object)) |
|
118 |
+ (list object-id :it object)) |
|
119 |
+ (alexandria:when-let* ((children (plump:children object)) |
|
120 |
+ (text (and (= 1 (length children)) |
|
121 |
+ (plump:textual-node-p (elt children 0)) |
|
122 |
+ (elt children 0)))) |
|
123 |
+ (c (list object-id :text (plump:text text)))) |
|
124 |
+ (map nil (lambda (it) |
|
125 |
+ (c (list object-id :child it))) |
|
126 |
+ (plump:child-elements object)) |
|
127 |
+ (c (list object-id :next (plump:next-element object))) |
|
128 |
+ (maphash (lambda (k v) |
|
129 |
+ (c (list object-id :attribute k)) |
|
130 |
+ (cond |
|
131 |
+ ((equal k "class") |
|
132 |
+ (mapcar (lambda (it) |
|
133 |
+ (c (list object-id k it))) |
|
134 |
+ (serapeum:split-sequence-if #'serapeum:whitespacep v))) |
|
135 |
+ (t (c (list object-id k v))))) |
|
136 |
+ (plump:attributes object)) |
|
137 |
+ (map nil (lambda (child) |
|
138 |
+ (mapc #'c |
|
139 |
+ (to-triples child))) |
|
140 |
+ (plump:child-elements object))))) |
|
141 |
+ |
|
142 |
+(defvar *database* |
|
143 |
+ '() |
|
144 |
+ "The set of triples to query") |
|
145 |
+(defvar *attribute-index*) |
|
146 |
+(defvar *attribute-cardinality*) |
|
147 |
+(defvar *entity-index*) |
|
148 |
+ |
|
149 |
+(defun calculate-attribute-cardinality (database) |
|
150 |
+ (fw.lu:prog1-bind (result (make-hash-table :test 'equal)) |
|
151 |
+ (loop |
|
152 |
+ for triple in database |
|
153 |
+ for attribute = (attribute triple) |
|
154 |
+ do |
|
155 |
+ (incf (gethash attribute result 0))))) |
|
156 |
+ |
|
157 |
+(defun ea-keygen () |
|
158 |
+ (lambda (triple) |
|
159 |
+ (list (list (entity triple) |
|
160 |
+ (attribute triple)) |
|
161 |
+ (list nil |
|
162 |
+ (attribute triple)) |
|
163 |
+ (list (entity triple) |
|
164 |
+ nil)))) |
|
165 |
+ |
|
166 |
+(defun two-level-index (database key-gen) |
|
167 |
+ "Given a database and a key generator, create a hash-table with all the key-gen values" |
|
168 |
+ (loop with result = (make-hash-table :test 'equal) |
|
169 |
+ for triple in database |
|
170 |
+ do |
|
171 |
+ (loop for key in (funcall key-gen triple) |
|
172 |
+ do |
|
173 |
+ (push triple |
|
174 |
+ (gethash key |
|
175 |
+ result))) |
|
176 |
+ finally (return result))) |
|
177 |
+ |
|
178 |
+(defun variablep (it) |
|
179 |
+ "Is IT a variable?" |
|
180 |
+ (and (symbolp it) |
|
181 |
+ (eql #\? (elt (symbol-name it) 0)))) |
|
182 |
+ |
|
183 |
+(defgeneric entity (thing) |
|
184 |
+ (:documentation "get the entity for THING") |
|
185 |
+ (:method ((thing cons)) |
|
186 |
+ (first thing))) |
|
187 |
+ |
|
188 |
+(defgeneric attribute (thing) |
|
189 |
+ (:documentation "get the attribute for THING") |
|
190 |
+ (:method ((thing cons)) |
|
191 |
+ (second thing))) |
|
192 |
+ |
|
193 |
+(defgeneric value (thing) |
|
194 |
+ (:documentation "get the value for THING") |
|
195 |
+ (:method ((thing cons)) |
|
196 |
+ (third thing))) |
|
197 |
+ |
|
198 |
+(defun filter-by-pattern (pattern bindings database) |
|
199 |
+ "Given BINDINGS, for each fact in DATABASE determine if PATTERN matches." |
|
200 |
+ (flet ((is-bound (variable) |
|
201 |
+ (cdr (assoc variable bindings)))) |
|
202 |
+ (let* ((database (let* ((entity (entity pattern)) |
|
203 |
+ (entity-b (is-bound entity)) |
|
204 |
+ (attribute (attribute pattern)) |
|
205 |
+ (attribute-b (is-bound attribute))) |
|
206 |
+ (cond ((and (not (variablep entity)) |
|
207 |
+ (not (variablep attribute))) |
|
208 |
+ (or (gethash (list entity |
|
209 |
+ attribute) |
|
210 |
+ *attribute-index*) |
|
211 |
+ database)) |
|
212 |
+ ((and (not (variablep entity))) |
|
213 |
+ (or (gethash (list entity nil) |
|
214 |
+ *attribute-index*) |
|
215 |
+ database)) |
|
216 |
+ ((and entity-b |
|
217 |
+ (not (variablep attribute))) |
|
218 |
+ (or (gethash (list entity-b attribute) |
|
219 |
+ *attribute-index*) |
|
220 |
+ database)) |
|
221 |
+ ((and entity-b |
|
222 |
+ attribute-b) |
|
223 |
+ (or (gethash (list entity-b attribute-b) |
|
224 |
+ *attribute-index*) |
|
225 |
+ database)) |
|
226 |
+ ((and (not (variablep attribute))) |
|
227 |
+ (or (gethash (list nil attribute) |
|
228 |
+ *attribute-index*) |
|
229 |
+ database)) |
|
230 |
+ ((and (not (variablep entity)) |
|
231 |
+ attribute-b) |
|
232 |
+ (or (gethash (list entity attribute-b) |
|
233 |
+ *attribute-index*) |
|
234 |
+ database)) |
|
235 |
+ (t |
|
236 |
+ database))))) |
|
237 |
+ (labels ((check-pattern-part (pattern target handle-binding) |
|
238 |
+ (cond |
|
239 |
+ ((consp pattern) |
|
240 |
+ (destructuring-bind (var . check) pattern |
|
241 |
+ (alexandria:if-let ((bound |
|
242 |
+ (serapeum:assocdr var |
|
243 |
+ bindings))) |
|
244 |
+ (when (equal bound (funcall check target)) |
|
245 |
+ t) |
|
246 |
+ (alexandria:when-let ((val (funcall check target))) |
|
247 |
+ (funcall handle-binding (cons var val)) |
|
248 |
+ t)))) |
|
249 |
+ ((variablep pattern) |
|
250 |
+ (alexandria:if-let ((bound |
|
251 |
+ (serapeum:assocdr pattern |
|
252 |
+ bindings))) |
|
253 |
+ (when (equal bound target) |
|
254 |
+ t) |
|
255 |
+ (progn |
|
256 |
+ (funcall handle-binding (cons pattern target)) |
|
257 |
+ t))) |
|
258 |
+ (t (equal target pattern)))) |
|
259 |
+ (check-pattern (triple) |
|
260 |
+ (let ((new-bindings ())) |
|
261 |
+ (values (every 'identity |
|
262 |
+ (mapcar (lambda (pat tar) |
|
263 |
+ (check-pattern-part pat tar |
|
264 |
+ (lambda (it) |
|
265 |
+ (push it new-bindings)))) |
|
266 |
+ pattern |
|
267 |
+ triple)) |
|
268 |
+ new-bindings)))) |
|
269 |
+ (let ((out-bindings ())) |
|
270 |
+ (dolist (triple database out-bindings) |
|
271 |
+ (multiple-value-bind (matched new-bindings) |
|
272 |
+ (check-pattern triple) |
|
273 |
+ (when matched |
|
274 |
+ (push new-bindings |
|
275 |
+ out-bindings))))))))) |
|
276 |
+ |
|
277 |
+(defun index (selector database) |
|
278 |
+ (loop with result = (make-hash-table :test 'equal) |
|
279 |
+ for triple in database |
|
280 |
+ do (push triple |
|
281 |
+ (gethash (funcall selector triple) |
|
282 |
+ result)) |
|
283 |
+ finally (return result))) |
|
284 |
+ |
|
285 |
+(defun match-patterns (patterns database) |
|
286 |
+ (let* ((*attribute-index* (two-level-index database |
|
287 |
+ (ea-keygen))) |
|
288 |
+ (out-matches (filter-by-pattern (car patterns) |
|
289 |
+ () |
|
290 |
+ database))) |
|
291 |
+ (dolist (pattern (cdr patterns) out-matches) |
|
292 |
+ (setf out-matches |
|
293 |
+ (mapcan (lambda (bindings) |
|
294 |
+ (remove-duplicates |
|
295 |
+ (mapcar (lambda (new-bindings) |
|
296 |
+ (append bindings new-bindings)) |
|
297 |
+ (filter-by-pattern pattern bindings database)) |
|
298 |
+ :test 'equal)) |
|
299 |
+ out-matches))))) |
|
300 |
+ |
|
301 |
+(defun do-q (cb out-vars patterns database) |
|
302 |
+ (let ((results (match-patterns patterns database))) |
|
303 |
+ (remove nil |
|
304 |
+ (mapcar (data-lens:∘ (data-lens:applying cb) |
|
305 |
+ (apply #'data-lens:juxt |
|
306 |
+ (mapcar #'data-lens:key |
|
307 |
+ out-vars))) |
|
308 |
+ results)))) |
|
309 |
+ |
|
310 |
+ |
|
311 |
+(defmacro q ((&rest out-vars) patterns &body body) |
|
312 |
+ `(do-q (lambda ,out-vars |
|
313 |
+ ,@body) |
|
314 |
+ ',out-vars |
|
315 |
+ ,patterns |
|
316 |
+ *database*)) |
|
317 |
+ |
|
318 |
+(defun call-with-database (*database* cb) |
|
319 |
+ (funcall cb)) |
|
320 |
+ |
|
321 |
+(defmacro with-database (database &body body) |
|
322 |
+ `(call-with-database ,database |
|
323 |
+ (lambda () |
|
324 |
+ ,@body))) |