Skip to content
Browse files

Add montezuma for full text search

  • Loading branch information...
1 parent eb4e514 commit b1e18edcd514af9651cf72e96646af605748defc @kraison committed
Showing with 554 additions and 445 deletions.
  1. +12 −6 README
  2. +5 −3 certainty-factors.lisp
  3. +5 −5 deserialize.lisp
  4. +43 −10 full-text-index.lisp
  5. +32 −29 index.lisp
  6. +18 −13 lock.lisp
  7. +3 −0 montezuma.lisp
  8. +73 −66 prolog-functors.lisp
  9. +44 −42 prologc.lisp
  10. +23 −16 serialize.lisp
  11. +32 −26 store.lisp
  12. +50 −42 templates.lisp
  13. +59 −52 transaction.lisp
  14. +119 −106 triples.lisp
  15. +11 −11 utilities.lisp
  16. +17 −13 uuid.lisp
  17. +8 −5 vivace-graph-v2.asd
View
18 README
@@ -5,7 +5,7 @@ it to behave consistently from one check-in to another.
The goal is to build a fast, robust, distributed graph database with optional
RDF semantics built-in. The primary query language is Prolog (based on PAIP),
-but I have plans to add Javascript and maybe Sparql at a later date.
+but I have plans to add Javascript and maybe Sparql at a later date.
At the moment, persistence is achieved via a call to (dump-triples); this is going
to change very soon. I am working on a native SBCL memory mapped persistence
library that will give me some variation on btrees and hashes. When this is
@@ -36,15 +36,23 @@ To get you started:
(in-package #:vivace-graph-v2)
(create-triple-store :name "test store" :location "/var/tmp/db")
-;;(index-predicate "likes")
+(index-predicate "likes")
(with-graph-transaction (*store*)
(add-triple "Kevin" "is-a" "human")
(add-triple "Joe" "is-a" "human")
(add-triple "Fido" "is-a" "dog")
(add-triple "Kevin" "likes" "Fido")
- (add-triple "Kevin" "likes" "Joe"))
+ (add-triple "Kevin" "likes" "Joe")
+ (add-triple "Joe" "likes" "programming lisp")
+ (add-triple "Kevin" "likes" "programming lisp")
+ (add-triple "Kevin" "likes" "programming perl")
+ (add-triple "Kevin" "likes" "programming c"))
+
(select (?x ?y) (q- ?x "likes" ?y))
-;; Range query; this stuff may be broken at this stage.
+
+(get-triples-list :search-string "programming")
+
+;; Range query; this stuff may be broken at this stage.
;; i will focus on it again very soon
;;(select-flat (?object) (q- "Kevin" "likes" (?object "a" "z")))
;;
@@ -59,5 +67,3 @@ To get you started:
(get-triples-list :s "Kevin")
(get-triples-list :p "is-a")
(close-triple-store :store *store*)
-
-
View
8 certainty-factors.lisp
@@ -16,7 +16,8 @@
;;; File: certainty-factors.lisp
-;;; Description: An implementation of Certainty Factors as found in Peter Norvig's PAIP.
+;;; Description: An implementation of Certainty Factors as found in Peter
+;;; Norvig's PAIP.
;;; Modified for VivaceGraph by Keivn Raison, 2010
@@ -108,12 +109,13 @@
((> cf 0.5) "suggestive evidence")
((> cf 0.0) "weakly suggestive evidence")
((= cf 0.0) "no evidence either way")
- ((< cf 0.0) (concatenate 'string (cf->english (- cf))
+ ((< cf 0.0) (concatenate 'string (cf->english (- cf))
" against the conclusion"))))
;;; interface into the generic belief system.
-(defmethod adjust-belief (objects (rule-belief number) &optional (old-belief nil))
+(defmethod adjust-belief (objects (rule-belief number) &optional
+ (old-belief nil))
(recalculate-cf objects rule-belief old-belief))
(defmethod adjust-belief (objects (rule-belief t) &optional old-belief)
View
10 deserialize.lisp
@@ -1,7 +1,7 @@
(in-package #:vivace-graph-v2)
-;; The foundation of the serialization code comes from Sonja Keene's "Object-Oriented
-;; Programming in Common Lisp." Thanks Sonja!
+;; The foundation of the serialization code comes from Sonja Keene's
+;; "Object-Oriented Programming in Common Lisp." Thanks Sonja!
(defgeneric deserialize (code stream))
(defgeneric deserialize-action (code stream))
@@ -68,17 +68,17 @@
(defmethod deserialize ((code (eql +symbol+)) stream)
(let ((code (read-byte stream)))
(when (and (/= +string+ code) (/= +compressed-string+ code))
- (error 'deserialization-error :instance code :reason
+ (error 'deserialization-error :instance code :reason
"Symbol-name is not a string!"))
(let ((symbol-name (deserialize code stream)))
(setq code (read-byte stream))
(when (and (/= +string+ code) (/= +compressed-string+ code))
- (error 'deserialization-error :instance code :reason
+ (error 'deserialization-error :instance code :reason
"Symbol-package is not a string!"))
(let* ((pkg-name (deserialize code stream))
(pkg (find-package pkg-name)))
(when (null pkg)
- (error 'deserialization-error :instance code :reason
+ (error 'deserialization-error :instance code :reason
(format nil "Symbol-package ~A does not exist!" pkg-name)))
(intern symbol-name pkg)))))
View
53 full-text-index.lisp
@@ -1,16 +1,49 @@
(in-package #:vivace-graph-v2)
-(defun add-to-text-index (idx key value)
- (skip-list-add idx key value))
+(defun add-to-text-index (idx triple)
+ ;; FIXME: we need our own tokenizer that does some stemming and such
+ (format t "Adding ~A to full text idx~%" triple)
+ (let ((doc (make-instance 'montezuma:document)))
+ (montezuma:add-field doc
+ (montezuma:make-field
+ "triple-id" (format nil "~A" (id triple))
+ :stored t :index :untokenized))
+ (montezuma:add-field doc
+ (montezuma:make-field
+ "subject" (format nil "~A" (subject triple))
+ :stored nil :index :tokenized))
+ (montezuma:add-field doc
+ (montezuma:make-field
+ "object" (format nil "~A" (object triple))
+ :stored nil :index :tokenized))
+ (montezuma:add-field doc
+ (montezuma:make-field
+ "graph" (format nil "~A" (graph triple))
+ :stored nil :index :untokenized))
+ (montezuma:add-field doc
+ (montezuma:make-field
+ "predicate" (format nil "~A" (predicate triple))
+ :stored nil :index :untokenized))
+ (montezuma:add-document-to-index idx doc)
+ doc))
-(defun remove-from-text-index (idx key)
- (skip-list-delete idx key))
+(defun remove-from-text-index (idx triple)
+ (montezuma:delete-document
+ idx (montezuma:make-term "triple-id" (format nil "~A" (id triple)))))
-(defun get-index-range (index start end)
- "This is wildly inefficient; we need to eventually coalesce the two cursor types."
+(defun full-text-search (index search-string &key g s p)
(let ((result (make-array 0 :fill-pointer t :adjustable t)))
- (let ((cursor (skip-list-range-cursor index start end)))
- (do ((kv (sl-cursor-next cursor) (sl-cursor-next cursor)))
- ((null kv))
- (vector-push-extend (second kv) result)))
+ (montezuma:search-each
+ index
+ (with-output-to-string (stream)
+ (format stream "object:\"~A\"" search-string)
+ (when g (format stream " graph:\"~A\"" g))
+ (when g (format stream " subject:\"~A\"" s))
+ (when g (format stream " predicate:\"~A\"" p)))
+ #'(lambda (doc-id score)
+ (let ((doc (montezuma:get-document index doc-id)))
+ (vector-push-extend
+ (uuid:make-uuid-from-string
+ (montezuma:document-value doc "triple-id"))
+ result))))
(make-index-cursor :index index :vector result :pointer 0)))
View
61 index.lisp
@@ -21,7 +21,8 @@
(defun cursor-value (cursor &key (transform-fn #'identity))
(handler-case
(funcall transform-fn
- (aref (index-cursor-vector cursor) (index-cursor-pointer cursor)))
+ (aref (index-cursor-vector cursor)
+ (index-cursor-pointer cursor)))
(sb-int:invalid-array-index-error (condition)
(declare (ignore condition))
nil)))
@@ -29,7 +30,7 @@
(defun cursor-next (cursor &key (transform-fn #'identity))
(handler-case
(funcall transform-fn
- (aref (index-cursor-vector cursor)
+ (aref (index-cursor-vector cursor)
(incf (index-cursor-pointer cursor))))
(sb-int:invalid-array-index-error (condition)
(declare (ignore condition))
@@ -38,8 +39,8 @@
(defun cursor-prev (cursor &key (transform-fn #'identity))
(handler-case
- (funcall transform-fn
- (aref (index-cursor-vector cursor)
+ (funcall transform-fn
+ (aref (index-cursor-vector cursor)
(decf (index-cursor-pointer cursor))))
(sb-int:invalid-array-index-error (condition)
(declare (ignore condition))
@@ -59,7 +60,7 @@
(push (funcall fn (aref (index-cursor-vector cursor) i)) result)
(funcall fn (aref (index-cursor-vector cursor) i))))
(nreverse result)))
-
+
(defstruct index name table test locks)
;;(defun make-hierarchical-index (&key name (test 'idx-equal))
@@ -83,8 +84,8 @@
(declare (ignore k))
(typecase v
(hash-table (fetch-all v))
- (list
- (dolist (leaf v)
+ (list
+ (dolist (leaf v)
(vector-push-extend leaf leaves)))
(t (vector-push-extend v leaves))))
ht1))))
@@ -98,19 +99,20 @@
(labels ((descend (ht keys)
(if (eq (first keys) '*)
(sb-ext:with-locked-hash-table (ht)
- (maphash #'(lambda (k v)
- (declare (ignore k))
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
(descend v (rest keys))) ht))
- (multiple-value-bind (value found?) (gethash (first keys) ht)
+ (multiple-value-bind (value found?)
+ (gethash (first keys) ht)
(when found?
(if (hash-table-p value)
(if (null (rest keys))
(progn
(when return-values?
(sb-ext:with-locked-hash-table (value)
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (push v vals))
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (push v vals))
value)))
(remhash (first keys) ht))
(descend value (rest keys)))
@@ -122,8 +124,8 @@
(assert (not (null keys)) nil "keys must be non-null.")
(if (eq (first keys) '*)
(sb-ext:with-locked-hash-table (ht)
- (maphash #'(lambda (k v)
- (declare (ignore k))
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
(if (hash-table-p v)
(descend-ht v (rest keys))
()))
@@ -140,9 +142,9 @@
(defun get-from-index (index &rest keys)
(let ((result (descend-ht (index-table index) keys)))
- (cond ((null result)
+ (cond ((null result)
(make-index-cursor :index index :vector #() :pointer 0))
- ((vectorp result)
+ ((vectorp result)
(make-index-cursor :index index :vector result :pointer 0))
(t result))))
@@ -157,15 +159,16 @@
((= 1 (length (rest keys)))
(values (gethash (first keys) ht) (first (rest keys))))
(t
- (find-or-create-ht (gethash (first keys) ht)
+ (find-or-create-ht (gethash (first keys) ht)
(rest keys) create-fn (1+ d)))))
(defun add-to-index (index value &rest keys)
- (let ((ht (find-or-create-ht (index-table index)
- keys
- #'(lambda ()
- (make-hash-table :synchronized t
- :test (index-test index))))))
+ (let ((ht (find-or-create-ht (index-table index)
+ keys
+ #'(lambda ()
+ (make-hash-table
+ :synchronized t
+ :test (index-test index))))))
(setf (gethash (car (last keys)) ht) value)))
(defun delete-from-index (index value &rest keys)
@@ -173,22 +176,22 @@
(declare (ignore index value keys)))
(defun check-index ()
- (maphash #'(lambda (k v) (format t "~A: ~A~%" k (type-of k)))
- (gethash :posgi-idx
- (vivace-graph-v2::index-table
+ (maphash #'(lambda (k v) (format t "~A: ~A~%" k (type-of k)))
+ (gethash :posgi-idx
+ (vivace-graph-v2::index-table
(main-idx *store*)))))
(defun get-table-to-lock (idx &rest keys)
(find-or-create-ht (index-table idx)
- keys
+ keys
#'(lambda ()
- (make-hash-table :synchronized t
+ (make-hash-table :synchronized t
:test (index-test idx)))))
(defmacro with-locked-index ((idx &rest keys) &body body)
(if keys
(with-gensyms (sub-idx last-key)
- `(multiple-value-bind (,sub-idx ,last-key)
+ `(multiple-value-bind (,sub-idx ,last-key)
(get-table-to-lock ,idx ,@keys)
(sb-ext:with-locked-hash-table (,sub-idx)
;;(format t "Locked ht ~A / ~A~%" ,last-key ,sub-idx)
View
31 lock.lisp
@@ -1,7 +1,8 @@
(in-package #:vivace-graph-v2)
(defun print-rw-lock (lock stream depth)
- (format stream "#<RW-LOCK, W: ~A, R: ~A>" (lock-writer lock) (lock-readers lock)))
+ (format stream "#<RW-LOCK, W: ~A, R: ~A>"
+ (lock-writer lock) (lock-readers lock)))
(defstruct (rw-lock
(:conc-name lock-)
@@ -68,7 +69,8 @@
(if (and (next-in-queue? rw-lock sb-thread:*current-thread*)
(eq (lock-writer rw-lock) sb-thread:*current-thread*))
(progn
- (enqueue-front (lock-writer-queue rw-lock) sb-thread:*current-thread*)
+ (enqueue-front (lock-writer-queue rw-lock)
+ sb-thread:*current-thread*)
(return-from acquire-write-lock rw-lock))
(enqueue (lock-writer-queue rw-lock) sb-thread:*current-thread*)))
(loop for tries from 0 to max-tries do
@@ -78,17 +80,20 @@
(handler-case
(sb-thread:with-recursive-lock ((lock-lock rw-lock))
(if (and (null (lock-writer rw-lock))
- (next-in-queue? rw-lock sb-thread:*current-thread*))
+ (next-in-queue? rw-lock
+ sb-thread:*current-thread*))
(progn
- (setf (lock-writer rw-lock) sb-thread:*current-thread*)
+ (setf (lock-writer rw-lock)
+ sb-thread:*current-thread*)
(when reading-p
(decf (lock-readers rw-lock)))
(unless (eql 0 (lock-readers rw-lock))
(setf wait-p t)))
- (sb-thread:condition-wait
+ (sb-thread:condition-wait
(lock-waitqueue rw-lock) (lock-lock rw-lock))))
(error (c)
- (format t "Got error ~A while acquiring write lock ~A" c rw-lock)))
+ (format t "Got error ~A while acquiring write lock ~A"
+ c rw-lock)))
(when wait-p
(sb-thread:wait-on-semaphore (lock-semaphore rw-lock)))))))
@@ -146,7 +151,7 @@
(defun test-rw-locks ()
(let ((lock (make-rw-lock)))
(make-thread
- #'(lambda () (with-write-lock (lock)
+ #'(lambda () (with-write-lock (lock)
(format t "1 got write lock. Sleeping.~%")
(sleep 5)
(with-write-lock (lock)
@@ -158,12 +163,12 @@
(format t "1 releasing recursive write lock.~%"))
(format t "1 releasing recursive write lock.~%"))
(format t "1 releasing write lock.~%"))))
- (make-thread
+ (make-thread
#'(lambda () (with-read-lock (lock) (format t "2 got read lock~%") (sleep 5))))
- (make-thread
+ (make-thread
#'(lambda () (with-read-lock (lock) (format t "3 got read lock~%") (sleep 5))))
(make-thread
- #'(lambda () (with-write-lock (lock)
+ #'(lambda () (with-write-lock (lock)
(format t "4 got write lock. Sleeping.~%")
(sleep 5)
(with-write-lock (lock)
@@ -176,12 +181,12 @@
(format t "4 releasing recursive write lock.~%"))
(format t "4 releasing write lock.~%"))))
(make-thread
- #'(lambda () (with-write-lock (lock)
+ #'(lambda () (with-write-lock (lock)
(format t "5 got write lock. Sleeping.~%")
(sleep 5)
(format t "5 releasing write lock.~%"))))
- (make-thread
+ (make-thread
#'(lambda () (with-read-lock (lock) (format t "6 got read lock~%") (sleep 5))))
- (make-thread
+ (make-thread
#'(lambda () (with-read-lock (lock) (format t "7 got read lock~%") (sleep 5))))))
|#
View
3 montezuma.lisp
@@ -0,0 +1,3 @@
+(in-package :montezuma)
+
+;; FIXME: add a tokenizer that uses porter-stemmer
View
139 prolog-functors.lisp
@@ -1,6 +1,7 @@
(in-package #:vivace-graph-v2)
-(defvar *prolog-global-functors* (make-hash-table :synchronized t :test 'equalp))
+(defvar *prolog-global-functors*
+ (make-hash-table :synchronized t :test 'equalp))
(defmacro def-global-prolog-functor (name lambda-list &body body)
`(prog1
@@ -17,7 +18,7 @@
(def-global-prolog-functor write/1 (exp cont)
(format t "~A" (deref-exp exp)) (funcall cont))
-(def-global-prolog-functor nl/0 (cont)
+(def-global-prolog-functor nl/0 (cont)
(terpri) (funcall cont))
(def-global-prolog-functor repeat/0 (cont)
@@ -31,7 +32,7 @@
"Unifies two prolog variables."
(if (unify ?arg1 ?arg2) (funcall cont)))
-(def-global-prolog-functor ==/2 (?arg1 ?arg2 cont)
+(def-global-prolog-functor ==/2 (?arg1 ?arg2 cont)
"Checks equality of the values of two prolog variables."
(if (deref-equal ?arg1 ?arg2) (funcall cont)))
@@ -41,34 +42,34 @@
(def-global-prolog-functor >/2 (?arg1 ?arg2 cont)
"Prolog greater than functor."
- (if (or (and (numberp (var-deref ?arg1)) (numberp (var-deref ?arg2))
- (> ?arg1 ?arg2))
+ (if (or (and (numberp (var-deref ?arg1)) (numberp (var-deref ?arg2))
+ (> ?arg1 ?arg2))
(and (timestamp? (var-deref ?arg1)) (timestamp? (var-deref ?arg2))
(timestamp> ?arg1 ?arg2)))
(funcall cont)))
(def-global-prolog-functor </2 (?arg1 ?arg2 cont)
"Prolog less than functor."
- (if (or (and (numberp (var-deref ?arg1)) (numberp (var-deref ?arg2))
+ (if (or (and (numberp (var-deref ?arg1)) (numberp (var-deref ?arg2))
(< ?arg1 ?arg2))
(and (timestamp? (var-deref ?arg1)) (timestamp? (var-deref ?arg2))
(timestamp< ?arg1 ?arg2)))
(funcall cont)))
-(def-global-prolog-functor >=/2 (?arg1 ?arg2 cont)
+(def-global-prolog-functor >=/2 (?arg1 ?arg2 cont)
"Prolog greater than or equal to functor."
- (if (or (and (numberp (var-deref ?arg1))
- (numberp (var-deref ?arg2))
- (>= ?arg1 ?arg2))
+ (if (or (and (numberp (var-deref ?arg1))
+ (numberp (var-deref ?arg2))
+ (>= ?arg1 ?arg2))
(and (timestamp? (var-deref ?arg1)) (timestamp? (var-deref ?arg2))
(timestamp>= ?arg1 ?arg2)))
(funcall cont)))
(def-global-prolog-functor <=/2 (?arg1 ?arg2 cont)
"Prolog less than or equal to functor."
- (if (or (and (numberp (var-deref ?arg1))
- (numberp (var-deref ?arg2))
- (<= ?arg1 ?arg2))
+ (if (or (and (numberp (var-deref ?arg1))
+ (numberp (var-deref ?arg2))
+ (<= ?arg1 ?arg2))
(and (timestamp? (var-deref ?arg1)) (timestamp? (var-deref ?arg2))
(timestamp<= ?arg1 ?arg2)))
(funcall cont)))
@@ -81,30 +82,31 @@
; (funcall cont)))
(def-global-prolog-functor lisp/2 (?result exp cont)
- "Call out to lisp from within a Prolog query. Assigns result to the supplied
-Prolog var. (lisp ?result (+ 1 2)). Any lisp variables that you wish to access
-within a prolog query using the lisp functor should be declared special."
+ "Call out to lisp from within a Prolog query. Assigns result to the
+ supplied Prolog var. (lisp ?result (+ 1 2)). Any lisp variables that you
+ wish to access within a prolog query using the lisp functor should be
+ declared special."
(let ((exp (var-deref exp)))
(when *prolog-trace* (format t "TRACE: LISP/2 ?result <- ~A~%" exp))
(cond ((consp exp)
(if (unify ?result (eval exp))
- ;;(if (unify ?result (apply (first exp) (rest exp)))
+ ;;(if (unify ?result (apply (first exp) (rest exp)))
(funcall cont)))
((and (symbolp exp) (boundp exp))
;;(if (unify ?result (eval exp))
- (if (unify ?result (funcall #'symbol-value exp))
+ (if (unify ?result (funcall #'symbol-value exp))
(funcall cont)))
(t
(if (unify ?result exp)
(funcall cont))))))
(def-global-prolog-functor lispp/1 (exp cont)
- "Call out to lisp from within a Prolog query and throws away the result. Any
-lisp variables that you wish to access within a prolog query using the lisp
-functor should be declared special."
+ "Call out to lisp from within a Prolog query and throws away the result.
+ Any lisp variables that you wish to access within a prolog query using the
+ lisp functor should be declared special."
(let ((exp (var-deref exp)))
(when *prolog-trace* (format t "TRACE: LISPP/1 ~A~%" exp))
- (cond ((consp exp)
+ (cond ((consp exp)
;;(format t "applying ~A to ~A~%" (first exp) (rest exp))
(eval exp))
;;(apply (first exp) (rest exp)))
@@ -113,9 +115,9 @@ functor should be declared special."
(funcall cont)))
(def-global-prolog-functor regex-match/2 (?arg1 ?arg2 cont)
- "Functor that treats first arg as a regex and uses cl-ppcre:scan to check for
-the pattern in the second arg."
- (if (and (stringp (var-deref ?arg1))
+ "Functor that treats first arg as a regex and uses cl-ppcre:scan to check
+ for the pattern in the second arg."
+ (if (and (stringp (var-deref ?arg1))
(stringp (var-deref ?arg2))
(cl-ppcre:scan ?arg1 ?arg2))
(funcall cont)))
@@ -133,13 +135,14 @@ the pattern in the second arg."
"Call a prolog form."
(var-deref goal)
(let* ((functor (make-functor-symbol (first goal) (length (args goal)))))
- (let ((fn (or (gethash functor *user-functors*)
+ (let ((fn (or (gethash functor *user-functors*)
(gethash functor *prolog-global-functors*))))
(if (functionp fn)
(apply fn (append (args goal) (list cont)))
- (error 'prolog-error
- :reason
- (format nil "Unknown Prolog functor in call/1 ~A" functor))))))
+ (error 'prolog-error
+ :reason
+ (format nil "Unknown Prolog functor in call/1 ~A"
+ functor))))))
(def-global-prolog-functor if/2 (?test ?then cont)
(when *prolog-trace* (format t "TRACE: IF/2(~A ~A)~%" ?test ?then))
@@ -147,18 +150,18 @@ the pattern in the second arg."
(def-global-prolog-functor if/3 (?test ?then ?else cont)
(when *prolog-trace* (format t "TRACE: IF/3(~A ~A ~A)~%" ?test ?then ?else))
- (call/1 ?test #'(lambda ()
- (call/1 ?then
+ (call/1 ?test #'(lambda ()
+ (call/1 ?then
#'(lambda () (funcall cont) (return-from if/3)))))
(call/1 ?else cont))
(let ((date-regex
"^(19|20)\\d\\d[\-\ \/\.](0[1-9]|1[012])[\-\ \/\.](0[1-9]|[12][0-9]|3[01])$"))
(def-global-prolog-functor valid-date?/1 (date cont)
- "Date validation functor. FIXME: This needs to be fleshed out with a more
-comprehensive regex."
+ "Date validation functor. FIXME: This needs to be fleshed out with a
+ more comprehensive regex."
(var-deref date)
- (if (timestamp? date)
+ (if (timestamp? date)
(funcall cont)
(if (and (stringp date)
(cl-ppcre:scan date-regex date))
@@ -174,7 +177,7 @@ comprehensive regex."
(funcall cont))
(def-global-prolog-functor not/1 (relation cont)
- "Prolog negation. Does not retract, simply negates in the context of the
+ "Prolog negation. Does not retract, simply negates in the context of the
query."
(with-undo-bindings
(call/1 relation #'(lambda () (return-from not/1 nil)))
@@ -214,10 +217,10 @@ query."
(cond ((and (symbolp var)
(eq graph-pkg (symbol-package var)))
(symbol-name var))
- ((and (consp var)
+ ((and (consp var)
(eq (first var) name)
(symbolp (second var))
- (eq graph-pkg
+ (eq graph-pkg
(symbol-package (second var))))
(list name (symbol-name (second var))))
(t var))))
@@ -226,15 +229,15 @@ query."
(def-global-prolog-functor map-query/3 (fn vars collect? cont)
(when *prolog-trace*
- (format t "TRACE: MAP-QUERY/3 FN (~A) IS ~A~%COLLECT? is ~A~%"
+ (format t "TRACE: MAP-QUERY/3 FN (~A) IS ~A~%COLLECT? is ~A~%"
(type-of fn) fn collect?))
(if (null vars)
nil
(let ((new-vars
- (loop
+ (loop
for var in vars
collect (let ((v (deref-exp var)))
- (if (and (symbolp v)
+ (if (and (symbolp v)
(eq graph-pkg (symbol-package v)))
(symbol-name v)
v)))))
@@ -244,15 +247,17 @@ query."
(def-global-prolog-functor q-/4 (s p o g cont)
(when *prolog-trace* (format t "TRACE: Q-/4(~A ~A ~A ~A)~%" s p o g))
- (let ((triples
- (get-triples
- :p (and (or (not (var-p p)) (and (var-p p) (bound-p p))) (var-deref p))
- :s (and (or (not (var-p s)) (and (var-p s) (bound-p s))) (var-deref s))
- :o (or (and (not (consp o)) (or (not (var-p o))
- (and (var-p o) (bound-p o)))
+ (let ((triples
+ (get-triples
+ :p (and (or (not (var-p p))
+ (and (var-p p) (bound-p p))) (var-deref p))
+ :s (and (or (not (var-p s))
+ (and (var-p s) (bound-p s))) (var-deref s))
+ :o (or (and (not (consp o))
+ (or (not (var-p o)) (and (var-p o) (bound-p o)))
(var-deref o))
(and (consp o) (cdr o)))
- :g (and (or (not (var-p g)) (and (var-p g) (bound-p g)))
+ :g (and (or (not (var-p g)) (and (var-p g) (bound-p g)))
(var-deref g)))))
(multiple-value-bind (s p o g) (intern-spog s p o g)
(map-cursor #'(lambda (id)
@@ -263,7 +268,7 @@ query."
(when (unify p (triple-predicate triple))
(when (unify s (triple-subject triple))
(if (consp o)
- (when (unify (car o)
+ (when (unify (car o)
(triple-object triple))
(funcall cont))
(when (unify o (triple-object triple))
@@ -280,17 +285,19 @@ query."
(when (consp clause)
(setq clause (mapcar #'(lambda (c) (var-deref c)) clause))
(when *prolog-trace* (format t "TRACE: Asserting ~A~%" clause))
- (if (and (or (= 3 (length clause))
- (= 4 (length clause)))
+ (if (and (or (= 3 (length clause))
+ (= 4 (length clause)))
(not (some #'var-p clause)))
- (let ((triple (add-triple (first clause) (second clause) (third clause)
+ (let ((triple (add-triple (first clause)
+ (second clause)
+ (third clause)
(or (fourth clause) *graph*))))
- (when *prolog-trace*
+ (when *prolog-trace*
(format t "TRACE: Asserted new triple ~A~%" triple))
(when (triple? triple)
(funcall cont)))
- (error 'prolog-error
- :reason
+ (error 'prolog-error
+ :reason
(format nil "assert is only for triples, not ~A" clause)))))
(def-global-prolog-functor subject/2 (?arg1 ?arg2 cont)
@@ -342,33 +349,33 @@ query."
"Retract a fact from the datastore."
(when (consp clause)
(setq clause (mapcar #'(lambda (c) (var-deref c)) clause))
- (if (and (or (= (length clause) 3)
- (= (length clause) 4))
+ (if (and (or (= (length clause) 3)
+ (= (length clause) 4))
(not (some #'var-p clause)))
(handler-case
(with-graph-transaction (*store*)
- (when *prolog-trace*
+ (when *prolog-trace*
(format t "TRACE: Retracting fact ~A~%" clause))
- (let ((triple (lookup-triple (first clause) (second clause)
+ (let ((triple (lookup-triple (first clause) (second clause)
(third clause)
- (or (fourth clause) *graph*)
+ (or (fourth clause) *graph*)
:retrieve-deleted? t)))
(if (triple? triple)
(delete-triple triple)
- (error 'prolog-error
- :reason
- (format nil "clause ~A does not represent a fact"
+ (error 'prolog-error
+ :reason
+ (format nil "clause ~A does not represent a fact"
clause)))))
(prolog-error (condition)
- (error 'prolog-error
+ (error 'prolog-error
:reason
(format nil "Cannot retract ~A: ~A~%" clause condition)))
(:no-error (result)
(declare (ignore result))
(funcall cont)))
- (error 'prolog-error
- :reason
- (format nil "Cannot retract a clause with variables: ~A"
+ (error 'prolog-error
+ :reason
+ (format nil "Cannot retract a clause with variables: ~A"
clause)))))
(def-global-prolog-functor is-valid/1 (item cont)
View
86 prologc.lisp
@@ -1,4 +1,4 @@
-;;;; This is Kevin Raison's customization of Mr. Norvig's PAIP Prolog.
+;;;; This is Kevin Raison's customization of Mr. Norvig's PAIP Prolog.
;;;; Thanks Mr. Norvig!
;;;; Copyright (c) 1991 Peter Norvig, (c) 2010 Kevin Raison
(in-package #:vivace-graph-v2)
@@ -27,8 +27,8 @@
(defun bound-p (var) (not (eq (var-binding var) +unbound+)))
(defgeneric prolog-equal (x y)
- (:documentation "Generic equality operator for prolog unification. Specialize
-this for new types that will be stored in the db.")
+ (:documentation "Generic equality operator for prolog unification.
+ Specialize this for new types that will be stored in the db.")
(:method ((x number) (y number)) (= x y))
(:method ((x string) (y string)) (string= x y))
(:method ((x character) (y character)) (char= x y))
@@ -104,7 +104,7 @@ this for new types that will be stored in the db.")
(defun compile-call (predicate arity args cont)
"Compile a call to a prolog predicate."
(let ((functor (make-functor-symbol predicate arity)))
- `(let ((func (or (get-functor-fn ',functor)
+ `(let ((func (or (get-functor-fn ',functor)
(gethash ',functor *prolog-global-functors*))))
(when *prolog-trace*
(format t "TRACE: ~A/~A~A~%" ',predicate ',arity ',args))
@@ -208,7 +208,7 @@ this for new types that will be stored in the db.")
(defun anonymous-variables-in (tree)
"Return a list of all variables that occur only once in tree."
(values (anon-vars-in tree nil nil)))
-
+
(defun anon-vars-in (tree seen-once seen-more)
"Walk the data structure TREE, returning a list of variabless
seen once, and a list of variables seen more than once."
@@ -344,7 +344,7 @@ this for new types that will be stored in the db.")
(defun compile-clause (parms clause cont)
"Transform away the head, and compile the resulting body."
(let ((body
- (bind-unbound-vars
+ (bind-unbound-vars
parms
(compile-body
(nconc
@@ -352,7 +352,7 @@ this for new types that will be stored in the db.")
(clause-body clause))
cont
(mapcar #'self-cons parms)))))
- (when *prolog-trace*
+ (when *prolog-trace*
(format t "TRACE: ~A BODY:~% ~A~%" (clause-head clause) body))
body))
@@ -364,8 +364,8 @@ this for new types that will be stored in the db.")
(let* ((arity (relation-arity (clause-head clause)))
(functor (make-functor-symbol functor-name arity)))
(if (gethash functor *prolog-global-functors*)
- (error 'prolog-error
- :reason
+ (error 'prolog-error
+ :reason
(format nil "Cannot override default functor ~A." functor))
(let ((f (lookup-functor functor)))
(if (functor? f)
@@ -417,16 +417,19 @@ this for new types that will be stored in the db.")
#'(lambda (&rest args) (declare (ignore args)) nil))))
(defun compile-functor (functor arity clauses)
- "Compile all the clauses for a given symbol/arity into a single LISP function."
- (let ((*functor* (functor-name functor))
+ "Compile all the clauses for a given symbol/arity into a single LISP
+ function."
+ (let ((*functor* (functor-name functor))
(parameters (make-parameters arity)))
(let ((func `#'(lambda (,@parameters cont)
(block ,*functor*
.,(maybe-add-undo-bindings
- (mapcar #'(lambda (clause)
- (compile-clause parameters clause 'cont))
- clauses))))))
- (when *prolog-trace* (format t "TRACE: Adding ~A to ~A~%" func *functor*))
+ (mapcar
+ #'(lambda (clause)
+ (compile-clause parameters clause 'cont))
+ clauses))))))
+ (when *prolog-trace*
+ (format t "TRACE: Adding ~A to ~A~%" func *functor*))
(set-functor-fn *functor* (eval func)))))
(defun compile-body (body cont bindings)
@@ -434,25 +437,27 @@ this for new types that will be stored in the db.")
(cond
((null body)
`(funcall ,cont))
- ((or (eq (first body) '!) (eq (first body) 'cut) (equalp (first body) "cut"))
+ ((or (eq (first body) '!) (eq (first body) 'cut)
+ (equalp (first body) "cut"))
`(progn ,(compile-body (rest body) cont bindings)
(return-from ,*functor* nil)))
(t (let* ((goal (first body))
(macro (prolog-compiler-macro (predicate goal)))
- (macro-val (if macro
+ (macro-val (if macro
(funcall macro goal (rest body) cont bindings))))
(if (and macro (not (eq macro-val :pass)))
macro-val
- (compile-call (predicate goal) (relation-arity goal)
- (mapcar #'(lambda (arg)
- (compile-arg arg bindings))
- (args goal))
- (if (null (rest body))
- cont
- `#'(lambda ()
- ,(compile-body
- (rest body) cont
- (bind-new-variables bindings goal))))))))))
+ (compile-call
+ (predicate goal) (relation-arity goal)
+ (mapcar #'(lambda (arg)
+ (compile-arg arg bindings))
+ (args goal))
+ (if (null (rest body))
+ cont
+ `#'(lambda ()
+ ,(compile-body
+ (rest body) cont
+ (bind-new-variables bindings goal))))))))))
(defun replace-?-vars (exp)
"Replace any ? within exp with a var of the form ?123."
@@ -471,7 +476,7 @@ this for new types that will be stored in the db.")
`(let ((count 0))
(with-graph-transaction (*store*)
(dolist (triple ',triples)
- (add-triple (first triple) (second triple) (third triple)
+ (add-triple (first triple) (second triple) (third triple)
:graph (or (fourth triple) *graph*))
(incf count))
(do-indexing))
@@ -493,34 +498,31 @@ this for new types that will be stored in the db.")
(functor (make-functor :name *functor* :clauses nil)))
(unwind-protect
(catch 'top-level-prove
- (let ((func #'(lambda (cont)
+ (let ((func #'(lambda (cont)
(handler-case
(block ,*functor*
.,(maybe-add-undo-bindings
- (mapcar
+ (mapcar
#'(lambda (clause)
(compile-clause nil clause 'cont))
`(((,top-level-query)
,@goals
- (show-prolog-vars
+ (show-prolog-vars
,(mapcar #'symbol-name vars)
,vars))))))
(undefined-function (condition)
(error 'prolog-error :reason condition))))))
(set-functor-fn *functor* func)
(funcall func #'prolog-ignore)
- ;;(setf (gethash ',*functor* *user-functors*) func)
- ;;(funcall (gethash ',*functor* *user-functors*) #'prolog-ignore)
(format t "~&No.~%")))
- ;;(remhash ',*functor* *user-functors*))
(delete-functor functor))
(values))))
(defmacro select (vars &rest goals)
"Select specific variables as a list of lists using the following form:
(select (?x ?y) (is-a ?x ?y)) could return ((Joe Human) (Spot Dog)) and
- (select ((:entity ?x) (:species ?y)) could return
- (((:entity Joe) (:species Human))
+ (select ((:entity ?x) (:species ?y)) could return
+ (((:entity Joe) (:species Human))
((:entity Spot)(:species Dog)))"
(let* ((top-level-query (gensym "PROVE"))
(goals (replace-?-vars goals))
@@ -531,8 +533,8 @@ this for new types that will be stored in the db.")
(*select-list* nil)
(functor (make-functor :name *functor* :clauses nil)))
(unwind-protect
- (let ((func
- #'(lambda (cont)
+ (let ((func
+ #'(lambda (cont)
(handler-case
(block ,*functor*
.,(maybe-add-undo-bindings
@@ -540,8 +542,8 @@ this for new types that will be stored in the db.")
(compile-clause nil clause 'cont))
`(((,top-level-query)
,@goals
- (select
- ,(mapcar
+ (select
+ ,(mapcar
#'(lambda (var)
(typecase var
(symbol (symbol-name var))
@@ -567,8 +569,8 @@ this for new types that will be stored in the db.")
`(select () ,@goals))
(defmacro map-query (fn query &key collect?)
- "Maps fn over the results of query. collect? will return a list of the results
-of each application of fn."
+ "Maps fn over the results of query. collect? will return a list of the
+ results of each application of fn."
(with-gensyms (result)
(if collect?
`(mapcar #'(lambda (,result)
View
39 serialize.lisp
@@ -1,7 +1,7 @@
(in-package #:vivace-graph-v2)
-;; The foundation of the serialization code comes from Sonja Keene's "Object-Oriented
-;; Programming in Common Lisp." Thanks Sonja!
+;; The foundation of the serialization code comes from Sonja Keene's
+;; "Object-Oriented Programming in Common Lisp." Thanks Sonja!
(defgeneric serialize (thing stream))
(defgeneric serialize-action (action stream &rest args))
@@ -20,7 +20,10 @@
(setq int (ash int -8)))))
(defmethod serialize ((int integer) (stream stream))
- "Encodes integers between (- (1- (expt 2 (* 8 255)))) and (1- (expt 2 (* 8 255)))"
+ "Encodes integers between
+(- (1- (expt 2 (* 8 255))))
+ and
+(1- (expt 2 (* 8 255)))"
(if (minusp int)
(progn
(write-byte +negative-integer+ stream)
@@ -49,7 +52,7 @@
(defmethod serialize ((string string) (stream stream))
;; FIXME: what is the right length to enable compression?
(if (and *compression-enabled?* (> (length string) 20))
- (let* ((comp (salza2:compress-data
+ (let* ((comp (salza2:compress-data
(babel:string-to-octets string) 'salza2:zlib-compressor))
(length (length comp)))
(write-byte +compressed-string+ stream)
@@ -92,19 +95,19 @@
(defun serialize-triple-help (triple stream)
(let ((graph-pkg (find-package 'graph-words)))
- (if (and (symbolp (subject triple))
+ (if (and (symbolp (subject triple))
(eq (symbol-package (subject triple)) graph-pkg))
(serialize (symbol-name (subject triple)) stream)
(serialize (subject triple) stream))
- (if (and (symbolp (predicate triple))
+ (if (and (symbolp (predicate triple))
(eq (symbol-package (predicate triple)) graph-pkg))
(serialize (symbol-name (predicate triple)) stream)
(serialize (predicate triple) stream))
- (if (and (symbolp (object triple))
+ (if (and (symbolp (object triple))
(eq (symbol-package (object triple)) graph-pkg))
(serialize (symbol-name (object triple)) stream)
(serialize (object triple) stream))
- (if (and (symbolp (graph triple))
+ (if (and (symbolp (graph triple))
(eq (symbol-package (graph triple)) graph-pkg))
(serialize (symbol-name (graph triple)) stream)
(serialize (graph triple) stream))
@@ -119,16 +122,19 @@
(defmethod serialize-action ((action (eql :add-triple)) stream &rest args)
(logger :debug "Serialize-action ~A: ~A~%" action args)
(write-byte +add-triple+ stream)
- (if (triple? (first args))
- ;; We generally want to avoid this, as the triple could change between requested
- ;; serialization and actual serialization.
+ (if (triple? (first args))
+ ;; We generally want to avoid this, as the triple could change between
+ ;; requested serialization and actual serialization.
(serialize-triple-help (first args) stream)
- (let ((subject (nth 0 args)) (predicate (nth 1 args)) (object (nth 2 args))
+ (let ((subject (nth 0 args))
+ (predicate (nth 1 args))
+ (object (nth 2 args))
(graph (nth 3 args)) (graph-pkg (find-package 'graph-words)))
(if (and (symbolp subject) (eq (symbol-package subject) graph-pkg))
(serialize (symbol-name subject) stream)
(serialize subject stream))
- (if (and (symbolp predicate) (eq (symbol-package predicate) graph-pkg))
+ (if (and (symbolp predicate)
+ (eq (symbol-package predicate) graph-pkg))
(serialize (symbol-name predicate) stream)
(serialize predicate stream))
(if (and (symbolp object) (eq (symbol-package object) graph-pkg))
@@ -146,7 +152,8 @@
(serialize (nth 0 args) stream) ;; id
(serialize (nth 1 args) stream)) ;; timestamp
-(defmethod serialize-action ((action (eql :undelete-triple)) stream &rest args)
+(defmethod serialize-action ((action (eql :undelete-triple)) stream &rest
+ args)
(write-byte +undelete-triple+ stream)
(serialize (nth 0 args) stream)) ;; id
@@ -158,10 +165,10 @@
(defmethod serialize-action ((action (eql :transaction)) stream &rest args)
(write-byte +transaction+ stream)
(let ((tx (nth 0 args)))
- ;;(serialize (length (tx-queue tx)) stream)
+ ;;(serialize (length (tx-queue tx)) stream)
(dolist (a (reverse (tx-queue tx)))
(logger :info "TX: serializing ~A / ~A~%" (first a) (rest a))
- (apply #'serialize-action
+ (apply #'serialize-action
(nconc (list (first a) stream) (rest a))))))
(defun test-serializer (file)
View
58 store.lisp
@@ -9,7 +9,8 @@
(log-mailbox :initarg :log-mailbox :accessor log-mailbox)
(index-queue :initarg :index-queue :accessor index-queue)
(delete-queue :initarg :delete-queue :accessor delete-queue)
- (indexed-predicates :initarg :indexed-predicates :accessor indexed-predicates)
+ (indexed-predicates :initarg :indexed-predicates
+ :accessor indexed-predicates)
(templates :initarg :templates :accessor templates)
(location :initarg :location :accessor location)
(lock-pool :initarg :lock-pool :accessor lock-pool)
@@ -31,8 +32,8 @@
(defun list-indexed-predicates (&optional (store *store*))
(let ((result nil))
- (maphash #'(lambda (k v)
- (when v (push k result)))
+ (maphash #'(lambda (k v)
+ (when v (push k result)))
(indexed-predicates store))
(sort result #'string>)))
@@ -44,15 +45,17 @@
:main-idx (make-hierarchical-index)
:lock-pool (make-lock-pool num-locks)
:locks (make-hash-table :synchronized t :test 'equal)
- :text-idx (make-skip-list :key-equal 'equalp
- :value-equal 'uuid:uuid-eql
- :duplicates-allowed? t)
+ :text-idx (make-instance 'montezuma:index
+ :path
+ (format nil "~A/text-idx"
+ location))
:log-mailbox (sb-concurrency:make-mailbox)
:index-queue (sb-concurrency:make-queue)
:delete-queue (sb-concurrency:make-queue)
- :templates (make-hash-table :synchronized t :test 'eql)
- :indexed-predicates (make-hash-table :synchronized t
- :test 'eql))))
+ :templates (make-hash-table :synchronized t
+ :test 'eql)
+ :indexed-predicates (make-hash-table :synchronized t
+ :test 'equalp))))
(add-to-index (main-idx store) (make-uuid-table :synchronized t) :id-idx)
(setf (logger-thread store) (start-logger store))
store))
@@ -60,7 +63,7 @@
(defun make-local-triple-store (name location)
(make-fresh-store name location))
-(defun create-triple-store (&key name if-exists? location host port
+(defun create-triple-store (&key name if-exists? location host port
user password)
(declare (ignore if-exists?))
(setq *graph* (or name location (format nil "~A:~A" host port)))
@@ -87,6 +90,7 @@
(remhash (store-name store) *store-table*)
(if (eql store *store*) (setq *store* nil))
(stop-logger store)
+ (montezuma:close (text-idx store))
nil)
(defun open-triple-store (&key name location host port user password)
@@ -105,7 +109,7 @@
(sb-concurrency:send-message (log-mailbox store) :shutdown-and-clear)
(join-thread (logger-thread store))
(make-fresh-store *graph* (location store)))
-
+
(defun use-graph (name)
(setq *graph* name))
@@ -116,22 +120,22 @@
(sb-concurrency:enqueue thing (delete-queue store)))
(defun intern-spog (s p o g)
- (values
+ (values
(if (stringp s) (intern s :graph-words) s)
(if (stringp p) (intern p :graph-words) p)
(if (stringp o) (intern o :graph-words) o)
(if (stringp g) (intern g :graph-words) g)))
-(defun lock-pattern (subject predicate object graph &key (kind :write)
+(defun lock-pattern (subject predicate object graph &key (kind :write)
(store *store*))
- (multiple-value-bind (subject predicate object graph)
+ (multiple-value-bind (subject predicate object graph)
(intern-spog subject predicate object graph)
(let ((lock nil) (pattern (list subject predicate object graph)))
(logger :info "~A: Locking pattern ~A~%" *current-transaction* pattern)
(sb-ext:with-locked-hash-table ((locks store))
- (setq lock
+ (setq lock
(or (gethash pattern (locks store))
- (setf (gethash pattern (locks store))
+ (setf (gethash pattern (locks store))
(get-pool-lock (lock-pool store))))))
(if (rw-lock? lock)
(if (eq kind :write)
@@ -140,15 +144,16 @@
(error "Unable to get lock for ~A" pattern)))))
(defun lock-triple (triple &key (kind :write) (store *store*))
- (lock-pattern (triple-subject triple)
- (triple-predicate triple)
- (triple-object triple)
+ (lock-pattern (triple-subject triple)
+ (triple-predicate triple)
+ (triple-object triple)
(triple-graph triple)
:kind kind
:store store))
-(defun unlock-pattern (subject predicate object graph &key kind (store *store*))
- (multiple-value-bind (subject predicate object graph)
+(defun unlock-pattern (subject predicate object graph &key kind
+ (store *store*))
+ (multiple-value-bind (subject predicate object graph)
(intern-spog subject predicate object graph)
(let ((pattern (list subject predicate object graph)))
(sb-ext:with-locked-hash-table ((locks store))
@@ -163,15 +168,16 @@
(release-pool-lock (lock-pool store) lock)))))))))
(defun unlock-triple (triple &key kind (store *store*))
- (funcall #'unlock-pattern
- (triple-subject triple)
- (triple-predicate triple)
- (triple-object triple)
+ (funcall #'unlock-pattern
+ (triple-subject triple)
+ (triple-predicate triple)
+ (triple-object triple)
(triple-graph triple)
:kind kind
:store store))
-(defmacro with-locked-pattern ((subject predicate object graph kind) &body body)
+(defmacro with-locked-pattern ((subject predicate object graph kind)
+ &body body)
(with-gensyms (s p o g k)
`(let ((,s ,subject) (,p ,predicate) (,o ,object) (,g ,graph) (,k ,kind))
(unwind-protect
View
92 templates.lisp
@@ -6,56 +6,64 @@
(slot has-name)
(slot has-age)
(slot has-eye-color)
- (slot has-hair-color))
-A function is added to the template table of *store* with name NAME. This function
-will be used to create groups of triples conforming to this template. See FACT and
-DEFFACTS."
- (unless (triple-store? *store*)
- (error "deftemplate ~A: *store* is not bound to a triple store!" name))
+ (slot has-hair-color))
+A function is added to the template table of *store* with name NAME. This
+function will be used to create groups of triples conforming to this template.
+See FACT and DEFFACTS."
(let ((node (gensym)))
- (setf (gethash name (templates *store*))
- (eval
- `#'(lambda (&key ,@(mapcar #'second slots))
- (with-graph-transaction (*store*)
- (let ((,node (make-anonymous-node)))
- (add-triple ,node "is-a" ,(string-downcase (symbol-name name)))
- ,@(mapcar
- #'(lambda (slot)
- `(add-triple ,node
- ,(string-downcase (symbol-name (second slot)))
- ,(second slot)))
- slots)
- ,node)))))))
+ `(progn
+ (unless (triple-store? *store*)
+ (error "deftemplate ~A: *store* is not bound to a triple store!"
+ ',name))
+ (setf (gethash ',name (templates *store*))
+ #'(lambda (&key ,@(mapcar #'second slots))
+ (with-graph-transaction (*store*)
+ (let ((,node (make-anonymous-node)))
+ (add-triple ,node "is-a"
+ ,(string-downcase (symbol-name name)))
+ ,@(mapcar
+ #'(lambda (slot)
+ `(add-triple
+ ,node
+ ,(string-downcase (symbol-name (second slot)))
+ ,(second slot)))
+ slots)
+ ,node)))))))
(defmacro fact (template)
- "Create a group of triples using the named template as defined in DEFTEMPLATE:
+ "Create a group of triples using the named template as defined in
+DEFTEMPLATE:
(fact (person (has-name \"John Q. Public\")
(has-age 23)
(has-eye-color blue)
- (has-hair-color black)))"
- (let ((tmpl-name (first template)))
- `(funcall (gethash ',tmpl-name (templates *store*))
- ,@(flatten (mapcar #'(lambda (slot)
- `(,(intern (symbol-name (first slot)) 'keyword)
- ,(second slot)))
- (rest template))))))
+ (has-hair-color black)))"
+ (let ((tmpl-name (gensym)))
+ `(let ((,tmpl-name ',(first template)))
+ (funcall
+ (gethash ,tmpl-name (templates *store*))
+ ,@(mapcan #'(lambda (slot)
+ `(,(intern (symbol-name (first slot)) 'keyword)
+ ,(second slot)))
+ (rest template))))))
(defmacro deffacts (&rest templates)
- "Create a set of triple groups conforming to the named template as defined by
-DEFTEMPLATE:
+ "Create a set of triple groups conforming to the named template as defined
+by DEFTEMPLATE:
(deffacts
- (person (has-name \"John Q. Public\") (has-age 23)
- (has-eye-color blue) (has-hair-color black))
+ (person (has-name \"John Q. Public\") (has-age 23)
+ (has-eye-color blue) (has-hair-color black))
(person (has-name \"Jane S. Public\") (has-age 24)
- (has-eye-color blue) (has-hair-color blond)))"
+ (has-eye-color blue) (has-hair-color blond)))"
(let ((template (gensym)))
- `(mapcar #'(lambda (,template)
- (let ((tmpl-name (first ,template)))
- (format t "tmpl-name is ~A~%" tmpl-name)
- (apply (gethash tmpl-name (templates *store*))
- (flatten
- (mapcar #'(lambda (slot)
- (list (intern (symbol-name (first slot)) 'keyword)
- (second slot)))
- (rest ,template))))))
- ',templates)))
+ `(mapcar
+ #'(lambda (,template)
+ (let ((tmpl-name (first ,template)))
+ (format t "tmpl-name is ~A~%" tmpl-name)
+ (apply (gethash tmpl-name (templates *store*))
+ (flatten
+ (mapcar
+ #'(lambda (slot)
+ (list (intern (symbol-name (first slot)) 'keyword)
+ (second slot)))
+ (rest ,template))))))
+ ',templates)))
View
111 transaction.lisp
@@ -21,30 +21,31 @@
(locks nil))
(defun find-newest-snapshot (store)
- (let ((snap nil)
- (location (if (pathnamep (location store)) (namestring (location store))
+ (let ((snap nil)
+ (location (if (pathnamep (location store))
+ (namestring (location store))
(location store))))
(dolist (file (directory (make-pathname :directory location
:name :wild :type :wild)))
- (when (and (pathname-match-p file "snap-*")
+ (when (and (pathname-match-p file "snap-*")
(or (null snap)
(> (file-write-date file) (file-write-date snap))))
(setq snap file)))
(if snap
(values snap (file-write-date snap))
(values nil nil))))
-
+
(defun find-transactions (store timestamp)
- (let ((transaction-logs nil)
- (location (if (pathnamep (location store))
+ (let ((transaction-logs nil)
+ (location (if (pathnamep (location store))
(namestring (location store))
(location store))))
(format t "Looking for transactions to restore...~%")
(dolist (file (directory (make-pathname :directory location
:name :wild :type :wild)))
- (when (and (pathname-match-p file "tx-*")
+ (when (and (pathname-match-p file "tx-*")
(or (null timestamp)
- (and (numberp timestamp)
+ (and (numberp timestamp)
(> (file-write-date file) timestamp))))
(format t "Found transaction file ~A~%" file)
(push file transaction-logs)))
@@ -66,20 +67,22 @@
(with-open-file (stream file :element-type '(unsigned-byte 8))
(let ((magic-byte (read-byte stream nil :eof)))
(unless (= +transaction+ magic-byte)
- (error 'transaction-error
+ (error 'transaction-error
:reason (format nil "~A is not a tx file!" file)))
(deserialize-action magic-byte stream)))))
(defun restore-triple-store (store)
(let ((*store* store))
(with-locked-index ((main-idx store))
- (multiple-value-bind (snapshot-file timestamp) (find-newest-snapshot store)
+ (multiple-value-bind (snapshot-file timestamp)
+ (find-newest-snapshot store)
(when snapshot-file
(format t "Restoring from snapshot file ~A~%" snapshot-file)
- (with-open-file (stream snapshot-file :element-type '(unsigned-byte 8))
- (do ((code (read-byte stream nil :eof) (read-byte stream nil :eof)))
+ (with-open-file (stream snapshot-file
+ :element-type '(unsigned-byte 8))
+ (do ((code (read-byte stream nil :eof)
+ (read-byte stream nil :eof)))
((or (eql code :eof) (null code) (= code 0)))
- ;;(format t "GOT CODE 0x~X -> ~A~%" code (deserialize code stream))))
(deserialize code stream))))
(dolist (file (find-transactions store timestamp))
(format t "REPLAYING TX ~A~%" file)
@@ -88,10 +91,10 @@
store))))
(defun snapshot (store)
- (with-open-file
- (stream
+ (with-open-file
+ (stream
(format nil "~A/snap-~A" (location store) (get-universal-time))
- :direction :output
+ :direction :output
:element-type '(unsigned-byte 8)
:if-exists :overwrite
:if-does-not-exist :create)
@@ -99,7 +102,7 @@
(maphash #'(lambda (id triple)
(declare (ignore id))
(when (persistent? triple)
- (logger :info "serializing ~A: ~A"
+ (logger :info "serializing ~A: ~A"
(triple-id triple) triple)
(serialize triple stream)))
(gethash :id-idx (index-table (main-idx store)))))
@@ -111,31 +114,31 @@
(when (and (streamp stream) (open-stream-p stream)) (close stream))
(open (format nil "~A/tx-~A" (location store) (get-universal-time))
:element-type '(unsigned-byte 8)
- :direction :output
+ :direction :output
:if-exists :rename
:if-does-not-exist :create))
(defun set-dirty (store)
- (with-open-file (stream (format nil "~A/.dirty" (location store))
- :direction :output :if-exists :overwrite
+ (with-open-file (stream (format nil "~A/.dirty" (location store))
+ :direction :output :if-exists :overwrite
:if-does-not-exist :create)
(format stream "~A" (gettimeofday))))
(defun set-clean (store)
- (let ((file (format nil "~A/.dirty" (location store))))
+ (let ((file (format nil "~A/.dirty" (location store))))
(when (probe-file file)
(delete-file file))))
(defun clear-tx-log (store)
- (dolist (file (directory
- (make-pathname :directory (location store)
+ (dolist (file (directory
+ (make-pathname :directory (location store)
:name :wild :type :wild)))
(when (pathname-match-p file "tx-*")
(delete-file file))))
(defun clear-snapshots (store)
- (dolist (file (directory
- (make-pathname :directory (location store)
+ (dolist (file (directory
+ (make-pathname :directory (location store)
:name :wild :type :wild)))
(when (pathname-match-p file "snap-*")
(delete-file file))))
@@ -150,8 +153,8 @@
(when (and (transaction? tx) (tx-queue tx))
(logger :info "Recording tx ~A~%" (reverse (tx-queue tx)))
(handler-case
- (with-open-file (stream
- (format nil "~A/tx-~A-~A" (location store)
+ (with-open-file (stream
+ (format nil "~A/tx-~A-~A" (location store)
(get-universal-time) (incf *file-counter*))
:element-type '(unsigned-byte 8) :direction :output
:if-exists :rename :if-does-not-exist :create)
@@ -165,7 +168,7 @@
(join-thread (logger-thread store)))
(defun start-logger (store)
- (make-thread
+ (make-thread
#'(lambda ()
(let ((mailbox (sb-concurrency:make-mailbox)) (*file-counter* 0)
(last-snapshot (gettimeofday)))
@@ -176,18 +179,19 @@
(logger :info "tx-log thread received message ~A" msg)
(typecase msg
(transaction (record-tx msg store))
- (keyword
- (case msg
+ (keyword
+ (case msg
(:shutdown-and-clear
(clear-tx-log store)
(clear-snapshots store)
(set-clean store)
(quit))
- (:shutdown
+ (:shutdown
(logger :info "Processing all pending messages.")
- (dolist
- (msg
- (sb-concurrency:receive-pending-messages mailbox))
+ (dolist
+ (msg
+ (sb-concurrency:receive-pending-messages
+ mailbox))
(logger :info "Processing message ~A" msg)
(when (transaction? msg)
(record-tx msg store)))
@@ -200,16 +204,16 @@
(:snapshot
(logger :info "Snapshot commencing")
(snapshot store)
- (logger :info "Snapshot complete. Setting store CLEAN")
+ (logger :info "Snapshot complete. Set store CLEAN")
(set-clean store)
(logger :info "Store set CLEAN")
(setq last-snapshot (gettimeofday))
(logger :info "Snapshot finished"))
- (otherwise
- (logger :info "Unknown msg to tx-log thread: ~A"
+ (otherwise
+ (logger :info "Unknown msg to tx-log thread: ~A"
msg))))))
(error (condition)
- (logger :err "Unhandled error in tx logger for ~A: ~A"
+ (logger :err "Unhandled error in tx logger for ~A: ~A"
store condition))))))
:name (format nil "tx-log thread for ~A" store)))
@@ -220,7 +224,7 @@
(declare (ignore lock))
(if (triple? pattern-or-triple)
(unlock-triple pattern-or-triple :kind kind)
- (funcall #'unlock-pattern
+ (funcall #'unlock-pattern
(nth 0 pattern-or-triple)
(nth 1 pattern-or-triple)
(nth 2 pattern-or-triple)
@@ -237,8 +241,9 @@
(defun execute-tx (store fn timeout max-tries retries)
(if (>= retries max-tries)
(error 'transaction-error
- :reason
- (format nil "Unable to execute transaction. Too may retries (~A)."
+ :reason
+ (format nil
+ "Unable to execute transaction. Too may retries (~A)."
retries))
(let ((*current-transaction* (make-transaction :store store)))
(logger :info "~A execute-tx starting" *current-transaction*)
@@ -246,39 +251,41 @@
(sb-ext:with-timeout timeout
(funcall fn))
(sb-ext:timeout (condition)
- (logger :info "~A execute-tx timeout ~A"
+ (logger :info "~A execute-tx timeout ~A"
*current-transaction* condition)
(rollback-tx *current-transaction*)
(release-all-locks *current-transaction*)
(execute-tx store fn timeout max-tries (1+ retries)))
(error (condition)
- (logger :info "~A execute-tx error ~A"
- *current-transaction* condition)
+ (logger :info "~A execute-tx error ~A"
+ *current-transaction* condition)
(rollback-tx *current-transaction*)
(release-all-locks *current-transaction*)
- (error 'transaction-error
- :reason
- (format nil "Unable to execute transaction: ~A" condition)))
+ (error 'transaction-error
+ :reason
+ (format nil "Unable to execute transaction: ~A"
+ condition)))
(:no-error (result)
- (logger :info "~A execute-tx success (~A)"
+ (logger :info "~A execute-tx success (~A)"
*current-transaction* result)
(when (tx-queue *current-transaction*)
- (sb-concurrency:send-message
+ (sb-concurrency:send-message
(log-mailbox store) *current-transaction*))
(release-all-locks *current-transaction*)
result)))))
-(defmacro with-graph-transaction ((store &key (timeout 10) (max-tries 10))
+(defmacro with-graph-transaction ((store &key (timeout 10) (max-tries 10))
&body body)
+ ;; body must be idempotent!
(with-gensyms (atomic-op)
`(let ((,atomic-op #'(lambda () ,@body)))
(cond ((and (transaction? *current-transaction*)
- (equal (store-name (tx-store *current-transaction*))
+ (equal (store-name (tx-store *current-transaction*))
(store-name ,store)))
(funcall ,atomic-op))
((transaction? *current-transaction*)
(error 'transaction-error
- :reason
+ :reason
"Transactions cannot currently span multiple stores."))
(t
(execute-tx ,store ,atomic-op ,timeout ,max-tries 0))))))
View
225 triples.lisp
@@ -5,7 +5,7 @@
(:method (t1 t2) nil))
(defgeneric triple-equal (t1 t2)
- (:method ((t1 triple) (t2 triple))
+ (:method ((t1 triple) (t2 triple))
(and (uuid:uuid-eql (id t1) (id t2))
(equal (triple-subject t1) (triple-subject t2))
(equal (triple-predicate t1) (triple-predicate t2))
@@ -13,7 +13,7 @@
(:method (t1 t2) nil))
(defgeneric triple-equalp (t1 t2)
- (:method ((t1 triple) (t2 triple))
+ (:method ((t1 triple) (t2 triple))
(and (triple-equal t1 t2)
(equal (triple-graph t1) (triple-graph t2))))
(:method (t1 t2) nil))
@@ -22,13 +22,14 @@
(if (not *read-uncommitted*)
(with-graph-transaction (*store*)
(enqueue-lock triple (lock-triple triple :kind :read) :read)
- (triple-deleted? triple))
+ (triple-deleted? triple))
(triple-deleted? triple)))
(defmethod subject ((triple triple))
(flet ((get-value ()
- (if (and (symbolp (triple-subject triple))
- (eq *graph-words* (symbol-package (triple-subject triple))))
+ (if (and (symbolp (triple-subject triple))
+ (eq *graph-words*
+ (symbol-package (triple-subject triple))))
(symbol-name (triple-subject triple))
(triple-subject triple))))
(if (not *read-uncommitted*)
@@ -42,8 +43,8 @@
(defmethod predicate ((triple triple))
(flet ((get-value ()
- (if (and (symbolp (triple-predicate triple))
- (eq *graph-words*
+ (if (and (symbolp (triple-predicate triple))
+ (eq *graph-words*
(symbol-package (triple-predicate triple))))
(symbol-name (triple-predicate triple))
(triple-predicate triple))))
@@ -58,8 +59,9 @@
(defmethod object ((triple triple))
(flet ((get-value ()
- (if (and (symbolp (triple-object triple))
- (eq *graph-words* (symbol-package (triple-object triple))))
+ (if (and (symbolp (triple-object triple))
+ (eq *graph-words*
+ (symbol-package (triple-object triple))))
(symbol-name (triple-object triple))
(triple-object triple))))
(if (not *read-uncommitted*)
@@ -116,7 +118,7 @@
"Create a unique anonymous node."
(format nil "_anon:~A" (make-uuid)))
-(let ((regex
+(let ((regex
"^_anon\:[0-9a-fA-F]{8}\-[0-9a-fA-F]{4}\-[0-9a-fA-F]{4}\-[0-9a-fA-F]{4}\-[0-9a-fA-F]{12}$"))
(defun anonymous? (node)
(and (stringp node)
@@ -126,10 +128,12 @@
(string-downcase (format nil "~A~A~A~A~A~A~A" g #\Nul s #\Nul p #\Nul o)))
(defun index-predicate (name-string)
- (setf (gethash name-string (indexed-predicates *store*)) t))
-
+ (setf (gethash (format nil "~A" name-string) (indexed-predicates *store*))
+ t))
+
(defun unindex-predicate (name-string)
- (setf (gethash name-string (indexed-predicates *store*)) nil))
+ (setf (gethash (format nil "~A" name-string) (indexed-predicates *store*))
+ nil))
(defmethod make-anonymous-node-name ((uuid uuid:uuid))
(format nil "_anon:~A" uuid))
@@ -175,56 +179,59 @@
(defun %deindex-triple (triple &optional (store *store*))
(delete-from-index (main-idx store) (id triple) :gspoi-idx
- (triple-graph triple) (triple-subject triple)
+ (triple-graph triple) (triple-subject triple)
(triple-predicate triple) (triple-object triple))
(delete-from-index (main-idx store) (id triple) :spogi-idx
- (triple-subject triple) (triple-predicate triple)
+ (triple-subject triple) (triple-predicate triple)
(triple-object triple) (triple-graph triple))
(delete-from-index (main-idx store) (id triple) :posgi-idx
- (triple-predicate triple) (triple-object triple)
+ (triple-predicate triple) (triple-object triple)
(triple-subject triple) (triple-graph triple))
(delete-from-index (main-idx store) (id triple) :ospgi-idx
- (triple-object triple) (triple-subject triple)
+ (triple-object triple) (triple-subject triple)
(triple-predicate triple) (triple-graph triple))
(delete-from-index (main-idx store) (id triple) :gposi-idx
- (triple-graph triple) (triple-predicate triple)
+ (triple-graph triple) (triple-predicate triple)
(triple-object triple) (triple-subject triple))
(delete-from-index (main-idx store) (id triple) :gospi-idx
- (triple-graph triple) (triple-object triple)
+ (triple-graph triple) (triple-object triple)
(triple-subject triple) (triple-predicate triple))
(when (index-predicate? (predicate triple))
- (remove-from-text-index (text-idx *store*)
- (make-text-idx-key (graph triple) (subject triple)
- (predicate triple) (object triple))))
+ (remove-from-text-index (text-idx *store*) triple))
+;; (make-text-idx-key
+;; (graph triple) (subject triple)
+;; (predicate triple) (object triple))))
t)
-
+
(defun index-triple (triple &optional (store *store*))
(with-graph-transaction (store)
(enqueue-lock triple (lock-triple triple :kind :write) :write)
- (push (lambda () (%deindex-triple triple)) (tx-rollback *current-transaction*))
+ (push (lambda () (%deindex-triple triple))
+ (tx-rollback *current-transaction*))
(add-to-index (main-idx store) (id triple) :gspoi-idx
- (triple-graph triple) (triple-subject triple)
+ (triple-graph triple) (triple-subject triple)
(triple-predicate triple) (triple-object triple))
(add-to-index (main-idx store) (id triple) :spogi-idx
- (triple-subject triple) (triple-predicate triple)
+ (triple-subject triple) (triple-predicate triple)
(triple-object triple) (triple-graph triple))
(add-to-index (main-idx store) (id triple) :posgi-idx
- (triple-predicate triple) (triple-object triple)
+ (triple-predicate triple) (triple-object triple)
(triple-subject triple) (triple-graph triple))
(add-to-index (main-idx store) (id triple) :ospgi-idx
- (triple-object triple) (triple-subject triple)
+ (triple-object triple) (triple-subject triple)
(triple-predicate triple) (triple-graph triple))
(add-to-index (main-idx store) (id triple) :gposi-idx
- (triple-graph triple) (triple-predicate triple)
+ (triple-graph triple) (triple-predicate triple)
(triple-object triple) (triple-subject triple))
(add-to-index (main-idx store) (id triple) :gospi-idx
- (triple-graph triple) (triple-object triple)
+ (triple-graph triple) (triple-object triple)
(triple-subject triple) (triple-predicate triple))
(when (index-predicate? (predicate triple))
- (add-to-text-index (text-idx *store*)
- (make-text-idx-key (graph triple) (subject triple)
- (predicate triple) (object triple))
- (id triple)))
+ (add-to-text-index (text-idx *store*) triple))
+;; (make-text-idx-key
+;; (graph triple) (subject triple)
+;; (predicate triple) (object triple))
+;; (id triple)))
triple))
(defun do-indexing (&optional (store *store*))
@@ -238,39 +245,41 @@
(defun enqueue-triple-for-indexing (triple)
(add-to-index-queue triple))
-(defun lookup-triple (subject predicate object graph &key retrieve-deleted?
+(defun lookup-triple (subject predicate object graph &key retrieve-deleted?
already-locked?)
- (multiple-value-bind (subject predicate object graph)
+ (multiple-value-bind (subject predicate object graph)
(intern-spog subject predicate object graph)
(flet ((lookup (s p o g)
- (let ((cursor (get-from-index (main-idx *store*) :gspoi-idx g s p o)))
+ (let ((cursor (get-from-index
+ (main-idx *store*) :gspoi-idx g s p o)))
(if (uuid:uuid? (cursor-value cursor))
(let ((triple (cursor-value
- (get-from-index (main-idx *store*)
- :id-idx
+ (get-from-index (main-idx *store*)
+ :id-idx
(cursor-value cursor)))))
(when (triple? triple)
- (if (deleted? triple)
- (when retrieve-deleted?
+ (if (deleted? triple)
+ (when retrieve-deleted?
triple)
triple)))))))
(if (or *read-uncommitted* already-locked?)
(lookup subject predicate object graph)
(with-graph-transaction (*store*)
(enqueue-lock (list subject predicate object graph)
- (lock-pattern subject predicate object graph :kind :read)
+ (lock-pattern subject predicate object graph
+ :kind :read)
:read)
(lookup subject predicate object graph))))))
-(defun add-triple (subject predicate object &key (graph *graph*) (index-immediate? t)
- cf (persistent? t))
- (multiple-value-bind (subject predicate object graph)
+(defun add-triple (subject predicate object &key (graph *graph*)
+ (index-immediate? t) cf (persistent? t))
+ (multiple-value-bind (subject predicate object graph)
(intern-spog subject predicate object graph)
(with-graph-transaction (*store*)
(let ((lock (lock-pattern subject predicate object graph :kind :write)))
(enqueue-lock (list subject predicate object graph) lock :write)
(or
- (let ((triple (lookup-triple subject predicate object graph
+ (let ((triple (lookup-triple subject predicate object graph
:retrieve-deleted? t
:already-locked? t)))
(when (triple? triple)
@@ -279,19 +288,20 @@
(when (deleted? triple)
(undelete-triple triple :persistent? persistent?))
triple))
- (let ((id (uuid:make-v1-uuid)))
+ (let ((id (uuid:make-v1-uuid)))
(let ((triple (make-triple :subject subject
:predicate predicate
- :object object
+ :object object
:graph graph
:cf (or cf +cf-true+)
:persistent? persistent?
:id id)))
(when persistent?
- (push (list :add-triple subject predicate object graph id nil
+ (push (list :add-triple subject predicate object graph id nil
(cf triple))
(tx-queue *current-transaction*)))
- (push (lambda () (delete-from-index (main-idx *store*) triple :id-idx id))
+ (push (lambda ()
+ (delete-from-index (main-idx *store*) triple :id-idx id))
(tx-rollback *current-transaction*))
(add-to-index (main-idx *store*) triple :id-idx id)
(if index-immediate?
@@ -319,49 +329,51 @@
(gethash :id-idx (index-table (main-idx store)))))
triple-count))
-(defun get-triples (&key s p o (g *graph*) (store *store*))
+(defun get-triples (&key s p o search-string (g *graph*) (store *store*))
"Returns a cursor to the results."
(flet ((get-them ()
(multiple-value-bind (s p o g) (intern-spog s p o g)
- (cond ((and g s p o)
- (if (consp o)
- (get-index-range (text-idx store)
- (make-text-idx-key g s p (nth 0 o))
- (make-text-idx-key g s p (nth 1 o)))
- (get-from-index (main-idx store) :gspoi-idx g s p o)))
- ((and g p s)
- (get-from-index (main-idx store) :gspoi-idx g s p))
- ((and g p o)
- (get-from-index (main-idx store) :gposi-idx g p o))
- ((and g p)
- (get-from-index (main-idx store) :gposi-idx g p))
- ((and g s)
- (get-from-index (main-idx store) :gspoi-idx g s))
- ((and g o)
- (get-from-index (main-idx store) :gospi-idx g o))
- (g
- (get-from-index (main-idx store) :gospi-idx g))
- (s
- (get-from-index (main-idx store) :spogi-idx s))
- (o
- (get-from-index (main-idx store) :ospgi-idx o))
- (p
- (get-from-index (main-idx store) :posgi-idx p))
- ((and (null s) (null p) (null o) (null g))
- (get-from-index (main-idx store) :gspoi-idx))
- (t
- (error "Other combinations of spogi to be implemented later."))))))
+ (cond
+ (search-string
+ (full-text-search (text-idx store) search-string
+ :g g :s s :p p))
+ ((and g s p o)
+ (get-from-index (main-idx store) :gspoi-idx g s p o))
+ ((and g p s)
+ (get-from-index (main-idx store) :gspoi-idx g s p))
+ ((and g p o)
+ (get-from-index (main-idx store) :gposi-idx g p o))
+ ((and g p)
+ (get-from-index (main-idx store) :gposi-idx g p))
+ ((and g s)
+ (get-from-index (main-idx store) :gspoi-idx g s))
+ ((and g o)
+ (get-from-index (main-idx store) :gospi-idx g o))
+ (g
+ (get-from-index (main-idx store) :gospi-idx g))
+ (s
+ (get-from-index (main-idx store) :spogi-idx s))
+ (o
+ (get-from-index (main-idx store) :ospgi-idx o))
+ (p
+ (get-from-index (main-idx store) :posgi-idx p))
+ ((and (null s) (null p) (null o) (null g))
+ (get-from-index (main-idx store) :gspoi-idx))
+ (t
+ (error
+ "Other combinations of spogi to be implemented later."))))))
(if *read-uncommitted*
(get-them)
(with-locked-pattern (s p o g :read)
(get-them)))))
-(defun get-triples-list (&key s p o (g *graph*) (store *store*) retrieve-deleted?
- limit)
- (let ((triples (map 'list
- #'get-triple-by-id
- (index-cursor-vector
- (get-triples :s s :p p :o o :g g :store store)))))
+(defun get-triples-list (&key s p o search-string (g *graph*) (store *store*)
+ retrieve-deleted? limit)
+ (let ((triples (map 'list
+ #'get-triple-by-id
+ (index-cursor-vector
+ (get-triples :s s :p p :o o :g g :store store
+ :search-string search-string)))))
(if retrieve-deleted?
(if limit
(subseq triples 0 (if (> (length triples) limit) limit))
@@ -378,22 +390,22 @@
(get-from-index (main-idx *store*) :gspoi-idx name))))
(defun %set-triple-cf (id cf)
- (let ((triple (get-triple-by-id (if (uuid:uuid? id)
- id
+ (let ((triple (get-triple-by-id (if (uuid:uuid? id)
+ id
(uuid:make-uuid-from-string id)))))
(when (triple? triple)
(cas (triple-cf triple) (triple-cf triple) cf))))
(defun %undelete-triple (id)
- (let ((triple (get-triple-by-id (if (uuid:uuid? id)
- id
+ (let ((triple (get-triple-by-id (if (uuid:uuid? id)
+ id
(uuid:make-uuid-from-string id)))))
(when (triple? triple)
(cas (triple-deleted? triple) (triple-deleted? triple) nil))))
(defun %delete-triple (id timestamp)
- (let ((triple (get-triple-by-id (if (uuid:uuid? id)
- id
+ (let ((triple (get-triple-by-id (if (uuid:uuid? id)
+ id
(uuid:make-uuid-from-string id)))))
(when (triple? triple)
(cas (triple-deleted? triple) (triple-deleted? triple) timestamp))))
@@ -401,34 +413,35 @@
(defun %index-triple (triple &optional (store *store*))
(add-to-index (main-idx store) triple :id-idx (id triple))
(add-to-index (main-idx store) (id triple) :gspoi-idx
- (triple-graph triple) (triple-subject triple)
+ (triple-graph triple) (triple-subject triple)
(triple-predicate triple) (triple-object triple))
(add-to-index (main-idx store) (id triple) :spogi-idx
- (triple-subject triple) (triple-predicate triple)
+ (triple-subject triple) (triple-predicate triple)
(triple-object triple) (triple-graph triple))
(add-to-index (main-idx store) (id triple) :posgi-idx
- (triple-predicate triple) (triple-object triple)
+ (triple-predicate triple) (triple-object triple)
(triple-subject triple) (triple-graph triple))
(add-to-index (main-idx store) (id triple) :ospgi-idx
- (triple-object triple) (triple-subject triple)
+ (triple-object triple) (triple-subject triple)
(triple-predicate triple) (triple-graph triple))
(add-to-index (main-idx store) (id triple) :gposi-idx
- (triple-graph triple) (triple-predicate triple)
+ (triple-graph triple) (triple-predicate triple)
(triple-object triple) (triple-subject triple))
(add-to-index (main-idx store) (id triple) :gospi-idx
- (triple-graph triple) (triple-object triple)
+ (triple-graph triple) (triple-object triple)
(triple-subject triple) (triple-predicate triple))
(when (index-predicate? (predicate triple))
- (add-to-text-index (text-idx *store*)
- (make-text-idx-key (graph triple) (subject triple)
- (predicate triple) (object triple))
- (id triple)))
+ (format t "%index-triple: indexing ~A~%" triple)
+ (add-to-text-index (text-idx *store*) triple))
+;; (make-text-idx-key (graph triple) (subject triple)
+;; (predicate triple) (object triple))
+;; (id triple)))
triple)
(defun %add-triple (subject predicate object id graph cf deleted?)
(let ((triple (make-triple :subject subject
:predicate predicate
- :object object
+ :object object
:graph graph
:cf cf
:id id
@@ -436,10 +449,10 @@
:deleted? deleted?)))
(%index-triple triple)
triple))
-
+
(defun dump-triples (file &optional (store *store*))
- (with-open-file (stream file
- :direction :output
+ (with-open-file (stream file
+ :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(with-graph-transaction (store)
@@ -475,6 +488,6 @@
(do-indexing)
(format t "Loaded ~A triples~%" count))
(error (condition)
- (format t "Error loading triples: ~A / ~A~%"
+ (format t "Error loading triples: ~A / ~A~%"
(type-of condition) condition))))))
View
22 utilities.lisp
@@ -15,12 +15,12 @@
(:method ((x symbol) (y symbol)) (string< (symbol-name x) (symbol-name y)))
(:method ((x symbol) (y string)) (string< (symbol-name x) y))
(:method ((x symbol) (y number)) (string< (symbol-name x) (write-to-string y)))
- (:method ((x symbol) (y uuid:uuid)) (string< (symbol-name x)
+ (:method ((x symbol) (y uuid:uuid)) (string< (symbol-name x)
(uuid:print-bytes nil y)))
(:method ((x number) (y number)) (< x y))
(:method ((x number) (y symbol)) (string< (write-to-string x) (symbol-name y)))
(:method ((x number) (y string)) (string< (write-to-string x) y))
- (:method ((x number) (y uuid:uuid)) (string< (write-to-string x)
+ (:method ((x number) (y uuid:uuid)) (string< (write-to-string x)
(uuid:print-bytes nil y)))
(:method ((x string) (y string)) (string< x y))
(:method ((x string) (y symbol)) (string< x (symbol-name y)))
@@ -32,9 +32,9 @@
(:method ((x uuid:uuid) (y uuid:uuid))
(string< (uuid:print-bytes nil x) (uuid:print-bytes nil y)))
(:method ((x uuid:uuid) (y string)) (string< (uuid:print-bytes nil x) y))
- (:method ((x uuid:uuid) (y symbol)) (string< (uuid:print-bytes nil x)
+ (:method ((x uuid:uuid) (y symbol)) (string< (uuid:print-bytes nil x)
(symbol-name y)))
- (:method ((x uuid:uuid) (y number)) (string< (uuid:print-bytes nil x)
+ (:method ((x uuid:uuid) (y number)) (string< (uuid:print-bytes nil x)
(write-to-string y))))
(defgeneric greater-than (x y)
@@ -42,12 +42,12 @@
(:method ((x symbol) (y symbol)) (string> (symbol-name x) (symbol-name y)))
(:method ((x symbol) (y string)) (string> (symbol-name x) y))
(:method ((x symbol) (y number)) (string> (symbol-name x) (write-to-string y)))
- (:method ((x symbol) (y uuid:uuid)) (string> (symbol-name x)
+ (:method ((x symbol) (y uuid:uuid)) (string> (symbol-name x)
(uuid:print-bytes nil y)))
(:method ((x number) (y number)) (> x y))
(:method ((x number) (y symbol)) (string> (write-to-string x) (symbol-name y)))
(:method ((x number) (y string)) (string> (write-to-string x) y))
- (:method ((x number) (y uuid:uuid)) (string> (write-to-string x)
+ (:method ((x number) (y uuid:uuid)) (string> (write-to-string x)
(uuid:print-bytes nil y)))
(:method ((x string) (y string)) (string> x y))
(:method ((x string) (y symbol)) (string> x (symbol-name y)))
@@ -56,12 +56,12 @@
(:method ((x timestamp) (y timestamp)) (timestamp> x y))
(:method ((x number) (y timestamp)) (> (timestamp-to-universal x) y))
(:method ((x timestamp) (y number)) (> x (timestamp-to-universal y)))
- (:method ((x uuid:uuid) (y uuid:uuid))
+ (:method ((x uuid:uuid) (y uuid:uuid))
(string> (uuid:print-bytes nil x) (uuid:print-bytes nil y)))
(:method ((x uuid:uuid) (y string)) (string> (uuid:print-bytes nil x) y))
- (:method ((x uuid:uuid) (y symbol)) (string> (uuid:print-bytes nil x)
+ (:method ((x uuid:uuid) (y symbol)) (string> (uuid:print-bytes nil x)
(symbol-name y)))
- (:method ((x uuid:uuid) (y number)) (string> (uuid:print-bytes nil x)
+ (:method ((x uuid:uuid) (y number)) (string> (uuid:print-bytes nil x)
(write-to-string y))))
(defun uri? (string)
@@ -220,8 +220,8 @@ containing the whole rest of the given STRING, if any."
(let ((it ,val)) ,@(cdr cl1))
(acond2 ,@(cdr clauses)))))))
-;; The following queueing code was borrowed and adapted from Russell & Norvig's
-;; "Introduction to AI"
+;; The following queueing code was borrowed and adapted from Russell &
+;; Norvig's "Introduction to AI"
(defun print-queue (q stream depth)
(declare (ignore depth))
(format stream "<QUEUE: ~a>" (queue-elements q)))