├── montezuma.lisp
├── sb-impl.lisp
├── vivace-graph-v2-test-package.lisp
├── vg-test.lisp
├── hash-table.lisp
├── vivace-graph-v2-test.asd
├── rw.lisp
├── conditions.lisp
├── data-types.lisp
├── LICENSE
├── contrib
    └── kraison
    │   ├── leaps.lisp
    │   ├── rete.lisp
    │   └── rules.lisp
├── sb-thread.lisp
├── functor.lisp
├── globals.lisp
├── vivace-graph-v2-test.lisp
├── namespaces.lisp
├── constants.lisp
├── full-text-index.lisp
├── vivace-graph-v2.asd
├── README
├── templates.lisp
├── uuid.lisp
├── TODO
├── vivace-graph-v2-package.lisp
├── gettimeofday.lisp
├── test-scenarios.lisp
├── certainty-factors.lisp
├── deserialize.lisp
├── index.lisp
├── lock.lisp
├── store.lisp
├── serialize.lisp
├── utilities.lisp
├── transaction.lisp
├── prolog-functors.lisp
├── triples.lisp
└── prologc.lisp


/montezuma.lisp:
--------------------------------------------------------------------------------
1 | (in-package :montezuma)
2 | 
3 | ;; FIXME: add a tokenizer that uses porter-stemmer
4 | 


--------------------------------------------------------------------------------
/sb-impl.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:sb-impl)
2 | 
3 | (export 'hash-table-spinlock (find-package 'sb-impl)) 
4 | 
5 | 


--------------------------------------------------------------------------------
/vivace-graph-v2-test-package.lisp:
--------------------------------------------------------------------------------
1 | (in-package #:cl-user)
2 | 
3 | (defpackage #:vivace-graph-v2-test
4 |   (:use #:cl #:vivace-graph-v2 #:bordeaux-threads)
5 |   (:export #:run-all-tests
6 | 	   #:*test-db-dir*))
7 | 
8 | 


--------------------------------------------------------------------------------
/vg-test.lisp:
--------------------------------------------------------------------------------
 1 | (require 'asdf)
 2 | (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
 3 |                                        (user-homedir-pathname))))
 4 |   (when (probe-file quicklisp-init)
 5 |     (load quicklisp-init)))
 6 | (asdf:oos 'asdf:load-op 'VIVACE-GRAPH-V2-TEST)
 7 | (in-package #:VIVACE-GRAPH-V2-TEST)
 8 | (run-all-tests)
 9 | (when (and *test-db-dir* (probe-file *test-db-dir*))
10 |   (format t "WARNING: ~A was not deleted!~%" *test-db-dir*))
11 | 


--------------------------------------------------------------------------------
/hash-table.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:vivace-graph-v2)
 2 | 
 3 | (defun acquire-hash-table-lock (hash-table)
 4 |   (if (eq sb-thread:*current-thread* 
 5 | 	  (sb-thread:spinlock-value (sb-impl:hash-table-spinlock hash-table)))
 6 |       t
 7 |       (sb-thread:my-get-spinlock (sb-impl:hash-table-spinlock hash-table))))
 8 | 
 9 | (defun release-hash-table-lock (hash-table)
10 |   (if (eq sb-thread:*current-thread* 
11 | 	  (sb-thread:spinlock-value (sb-impl:hash-table-spinlock hash-table)))
12 |       (sb-thread:release-spinlock (sb-impl:hash-table-spinlock hash-table))))
13 | 
14 | 


--------------------------------------------------------------------------------
/vivace-graph-v2-test.asd:
--------------------------------------------------------------------------------
 1 | ;; ASDF package description for vivace-graph-v2-test     -*- Lisp -*-
 2 | 
 3 | (defpackage :vivace-graph-v2-test-system (:use :cl :asdf))
 4 | (in-package :vivace-graph-v2-test-system)
 5 | 
 6 | (defsystem vivace-graph-v2-test
 7 |   :name "Vivace Graph Tests"
 8 |   :maintainer "Kevin Raison"
 9 |   :author "Kevin Raison <last name @ chatsubo dot net>"
10 |   :version "0.2"
11 |   :description "Vivace Graph Version 2 Test Suite"
12 |   :long-description "Vivace Graph Version 2 Test Suite."
13 |   :depends-on (:vivace-graph-v2
14 | 	       :bordeaux-threads
15 | 	       :cl-fad
16 | 	       :fiveam)
17 |   :components ((:file "vivace-graph-v2-test-package")
18 | 	       (:file "test-scenarios" :depends-on ("vivace-graph-v2-test-package"))
19 | 	       (:file "vivace-graph-v2-test" :depends-on ("test-scenarios"))))
20 | 
21 | 
22 | 


--------------------------------------------------------------------------------
/rw.lisp:
--------------------------------------------------------------------------------
 1 | (defun do-write ()
 2 |   (with-open-file (stream "/var/tmp/test" 
 3 | 			  :direction :output :if-exists :overwrite :if-does-not-exist :create)
 4 |     (time
 5 |      (dotimes (i 1000)
 6 |        (dotimes (j 1000)
 7 | 	 (write `(+ ,i ,j) :stream stream)
 8 | 	 (format stream "~%"))))))
 9 | 
10 | (defun do-read ()
11 |   (with-open-file (stream "/var/tmp/test")
12 |     (time
13 |      (handler-case
14 | 	 (loop
15 | 	    (eval (read stream)))
16 |        (error (c)
17 | 	 (format t "Got error ~A~%" c))))))
18 | 
19 | (let ((ht (make-hash-table :test 'equal :synchronized t)))
20 |   (dotimes (i 10000)
21 |     (let ((ht1 (make-hash-table :test 'equal :synchronized t)))
22 |       (setf (gethash (format nil "~A" i) ht) ht1)
23 |       (dotimes (j 100)
24 | 	(setf (gethash (format nil "~A" j) ht1) (random 10000)))))    
25 |   (defun cl-store-write ()
26 |     (time (cl-store:store ht "/var/tmp/ht.dat"))))
27 | 


--------------------------------------------------------------------------------
/conditions.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:vivace-graph-v2)
 2 | 
 3 | (define-condition prolog-error (error)
 4 |   ((reason :initarg :reason))
 5 |   (:report (lambda (error stream)
 6 | 	     (with-slots (reason) error
 7 | 	       (format stream "Prolog error: ~A." reason)))))
 8 | 
 9 | (define-condition serialization-error (error)
10 |   ((instance :initarg :instance)
11 |    (reason :initarg :reason))
12 |   (:report (lambda (error stream)
13 |              (with-slots (instance reason) error
14 |                (format stream "Serialization failed for ~a because of ~a." 
15 | 		       instance reason)))))
16 | 
17 | (define-condition deserialization-error (error)
18 |   ((instance :initarg :instance)
19 |    (reason :initarg :reason))
20 |   (:report (lambda (error stream)
21 |              (with-slots (instance reason) error
22 |                (format stream "Deserialization failed for ~a because of ~a." 
23 | 		       instance reason)))))
24 | 
25 | (define-condition transaction-error (error)
26 |   ((reason :initarg :reason))
27 |   (:report (lambda (error stream)
28 | 	     (with-slots (reason) error
29 | 	       (format stream "Transaction error: ~A." reason)))))
30 | 
31 | 


--------------------------------------------------------------------------------
/data-types.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:vivace-graph-v2)
 2 | 
 3 | ;;; UUIDs
 4 | (defun make-uuid ()
 5 |   "Create a new UUID."
 6 |   (uuid:make-v1-uuid))
 7 | 
 8 | (defun sxhash-uuid (uuid) (sxhash (uuid:print-bytes nil uuid)))
 9 | 
10 | (sb-ext:define-hash-table-test uuid:uuid-eql sxhash-uuid)
11 | 
12 | (defun make-uuid-table (&key synchronized) 
13 |   (make-hash-table :test 'uuid:uuid-eql :synchronized synchronized))
14 | 
15 | ;;; Dates
16 | ;;; timestamps provided by local-time lib
17 | (defgeneric timestamp? (thing)
18 |   (:method ((thing timestamp)) t)
19 |   (:method (thing) nil))
20 | 
21 | ;;; Triple structure
22 | (defparameter *print-triple-details* nil)
23 | 
24 | (defun print-triple (triple stream depth)
25 |   (declare (ignore depth))
26 |   (if *print-triple-details* 
27 |       (format stream "<'~A' '~A' '~A' {~F:~A:~A}>" 
28 | 	      (subject triple) (predicate triple) (object triple) 
29 | 	      (cf triple) (graph triple) (id triple))
30 |       (format stream "<'~A' '~A' '~A'>" 
31 | 	      (subject triple) (predicate triple) (object triple))))
32 | 
33 | (defstruct (triple
34 | 	     (:print-function print-triple)
35 | 	     (:conc-name triple-)
36 | 	     (:predicate triple?))
37 |   subject 
38 |   predicate 
39 |   object 
40 |   graph 
41 |   id 
42 |   (deleted? nil) 
43 |   (cf +cf-true+) 
44 |   (persistent? t))
45 | 
46 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2012 Kevin Thomas Raison
 2 | 
 3 | Permission is hereby granted, free of charge, to any person obtaining a copy
 4 | of this software and associated documentation files (the "Software"), to deal
 5 | in the Software without restriction, including without limitation the rights
 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 7 | copies of the Software, and to permit persons to whom the Software is
 8 | furnished to do so, subject to the following conditions:
 9 | 
10 | The above copyright notice and this permission notice shall be included in
11 | all copies or substantial portions of the Software.
12 | 
13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
19 | THE SOFTWARE.
20 | 
21 | Except as contained in this notice, the name(s) of the above copyright holders
22 | shall not be used in advertising or otherwise to promote the sale, use or other
23 | dealings in this Software without prior written authorization.
24 | 
25 | 


--------------------------------------------------------------------------------
/contrib/kraison/leaps.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:vivace-graph)
 2 | 
 3 | #|
 4 | (defmethod compile-rule ((rule rule))
 5 |   rule)
 6 | 
 7 | (defmethod apply-rule ((rule rule) (triple triple))
 8 |   (dolist (premise (rule-premises rule))
 9 |     (if (prolog-equal (predicate triple) (first premise))
10 | 	(format t "matched predicates of ~A and ~A~%" triple premise))
11 |     (if (prolog-equal (subject triple) (second premise))
12 | 	(format t "matched subjects of ~A and ~A~%" triple premise))
13 |     (if (prolog-equal (object triple) (third premise))
14 | 	(format t "matched objects of ~A and ~A~%" triple premise))))
15 | |#
16 | #|
17 | (defrule t1
18 |   if 
19 |   (or (is-a ?x "dog") (is-a ?x "human"))
20 |   (or (likes ?x "cats") (likes ?x "lizards"))
21 |   then
22 |   (trigger (format t "~A is a strange beast!~%" ?x)))
23 | 
24 | (defrule t2
25 |   if 
26 |   (or
27 |    (and (is-a ?x "dog") (likes ?x "cats"))
28 |    (and (is-a ?x "dog") (likes ?x "lizards"))
29 |    (and (is-a ?x "human") (likes ?x "lizards")))
30 |   then
31 |   (trigger (format t "~A is a strange beast!~%" ?x)))
32 | 
33 | (defrule t3
34 |   if 
35 |   (or
36 |    (and (is-a ?x "dog") (likes ?x "cats")
37 | 	(is-a ?y "dog") (likes ?y "cats"))
38 |    (and (is-a ?x "human") (likes ?x "lizards")
39 | 	(is-a ?y "human") (likes ?y "lizards")))
40 |   then
41 |   (trigger (format t "~A is a strange beast!~%" ?x)))
42 | |#


--------------------------------------------------------------------------------
/sb-thread.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:sb-thread)
 2 | 
 3 | (export 'get-spinlock (find-package 'sb-thread))
 4 | (export 'my-get-spinlock (find-package 'sb-thread))
 5 | (export 'release-spinlock (find-package 'sb-thread))
 6 | (export 'spinlock-value (find-package 'sb-thread))
 7 | 
 8 | (defun my-get-spinlock (spinlock)
 9 |   (declare (optimize (speed 3) (safety 0)))
10 |   (let* ((new *current-thread*)
11 |          (old (sb-ext:compare-and-swap (spinlock-value spinlock) nil new)))
12 |     (when old
13 |       (when (eq old new)
14 |         (error "Recursive lock attempt on ~S." spinlock))
15 |       (flet ((cas ()
16 |                (if (sb-ext:compare-and-swap (spinlock-value spinlock) nil new)
17 | 		   (progn
18 | 		     (sleep 0.000000001)
19 | 		     (thread-yield))
20 |                    (return-from my-get-spinlock t))))
21 |         (if (and (not *interrupts-enabled*) *allow-with-interrupts*)
22 |             ;; If interrupts are disabled, but we are allowed to
23 |             ;; enabled them, check for pending interrupts every once
24 |             ;; in a while. %CHECK-INTERRUPTS is taking shortcuts, make
25 |             ;; sure that deferrables are unblocked by doing an empty
26 |             ;; WITH-INTERRUPTS once.
27 |             (progn
28 |               (with-interrupts)
29 |               (loop
30 | 		 (loop repeat 128 do (cas)) ; 128 is arbitrary here
31 | 		 (sb-unix::%check-interrupts)))
32 |             (loop (cas)))))
33 |     t))
34 | 
35 | 


--------------------------------------------------------------------------------
/functor.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:vivace-graph-v2)
 2 | 
 3 | (defstruct (functor
 4 | 	     (:constructor %make-functor)
 5 | 	     (:predicate functor?))
 6 |   name fn clauses (lock (make-recursive-lock)))
 7 | 
 8 | (defun lookup-functor (name)
 9 |   (gethash name *user-functors*))
10 | 
11 | (defun make-functor (&key name clauses)
12 |   (or (lookup-functor name)
13 |       (let ((functor (%make-functor :name name :clauses clauses)))
14 | 	(with-recursive-lock-held ((functor-lock functor))
15 | 	  (prog1
16 | 	      (setf (gethash name *user-functors*) functor)
17 | 	    (prolog-compile functor))))))
18 | 
19 | (defun add-functor-clause (functor clause)
20 |   (with-recursive-lock-held ((functor-lock functor))
21 |     (cas (cdr (last (functor-clauses functor)))
22 | 	 (cdr (last (functor-clauses functor)))
23 | 	 (list clause))
24 |     (prolog-compile functor))
25 |   (functor-clauses functor))
26 | 
27 | (defun delete-functor (functor)
28 |   (remhash (functor-name functor) *user-functors*))
29 | 
30 | (defun reset-functor (functor)
31 |   (with-recursive-lock-held ((functor-lock functor))
32 |     (cas (functor-clauses functor) (functor-clauses functor) nil)
33 |     (prolog-compile functor))
34 |   nil)
35 | 
36 | (defun get-functor-fn (functor-symbol)
37 |   (let ((f (lookup-functor functor-symbol)))
38 |     (when (functor? f)
39 |       (functor-fn f))))
40 | 
41 | (defun set-functor-fn (functor-symbol fn)
42 |   (let ((f (lookup-functor functor-symbol)))
43 |     (when *prolog-trace* 
44 |       (format t "TRACE: set-functor-fn for ~A got ~A~%" functor-symbol f))
45 |     (if (functor? f)
46 | 	(setf (functor-fn f) fn)
47 | 	(error 'prolog-error 
48 | 	       :reason (format nil "unknown functor ~A" functor-symbol)))))
49 | 


--------------------------------------------------------------------------------
/globals.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:vivace-graph-v2)
 2 | 
 3 | (defpackage #:graph-words)
 4 | (defparameter *graph-words* (find-package :graph-words))
 5 | 
 6 | (defparameter *store* nil)
 7 | (defparameter *store-table* (make-hash-table :synchronized t :test 'eql))
 8 | (defparameter *namespaces* (make-hash-table :synchronized t :test 'equalp))
 9 | 
10 | (defparameter *read-uncommitted* t)
11 | 
12 | (defparameter *compression-enabled?* t)
13 | 
14 | ;; Graphs
15 | (defvar *graph* nil)
16 | (defvar *graph-table* nil)
17 | 
18 | ;; Logging
19 | (defvar *syslog-program* "vivace-graph-v2")
20 | (defvar *syslog-facility* sb-posix:log-local7)
21 | (progn
22 |   (defparameter *syslog-priorities* (make-hash-table))
23 |   (setf (gethash :emerg *syslog-priorities*) sb-posix:log-emerg)
24 |   (setf (gethash :alert *syslog-priorities*) sb-posix:log-alert)
25 |   (setf (gethash :crit *syslog-priorities*) sb-posix:log-crit)
26 |   (setf (gethash :err *syslog-priorities*) sb-posix:log-err)
27 |   (setf (gethash :warning *syslog-priorities*) sb-posix:log-warning)
28 |   (setf (gethash :warn *syslog-priorities*) sb-posix:log-warning)
29 |   (setf (gethash :notice *syslog-priorities*) sb-posix:log-notice)
30 |   (setf (gethash :info *syslog-priorities*) sb-posix:log-info)
31 |   (setf (gethash :debug *syslog-priorities*) sb-posix:log-debug))
32 | 
33 | ;; Prolog specials
34 | (defparameter *occurs-check* t)
35 | (defvar *trail* (make-array 200 :fill-pointer 0 :adjustable t))
36 | (defvar *var-counter* 0 "Counter for generating variable names.")
37 | (defvar *functor* nil "The Prolog functor currently being compiled.")
38 | (defvar *select-list* nil "Accumulator for prolog selects.")
39 | (defvar *cont* nil "Continuation container for step-wise queries.")
40 | (defvar *prolog-global-functors* (make-hash-table :synchronized t))
41 | (defvar *user-functors* (make-hash-table :synchronized t :test 'eql))
42 | (defparameter *prolog-trace* nil)
43 | 
44 | 


--------------------------------------------------------------------------------
/vivace-graph-v2-test.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:vivace-graph-v2-test)
 2 | 
 3 | (defparameter *test-db-dir* #P"/var/tmp/vivace-graph-v2-test-db/")
 4 | 
 5 | (defun test-select (store)
 6 |   (let ((*store* store))
 7 |     (let ((triple (select-first (?s ?p ?o) (q- ?s ?p ?o))))
 8 |       (and (equal "VGT" (first triple))
 9 |            (equal "is-a" (second triple))
10 |            (equal "thing" (third triple))))))
11 | 
12 | (defun run-all-tests ()
13 |   (fiveam:def-suite vg-test-suite :description "VG Test Suite")
14 |   (fiveam:in-suite vg-test-suite)
15 |   (ensure-directories-exist *test-db-dir*)
16 |   (format t "~%~%Preparing to run all VivaceGraph Tests.~%")
17 |   (fiveam:test (vg-tests)
18 |     ;; Basic tests of graph db
19 |     (fiveam:is (triple-store? (create-triple-store 
20 | 			       :name "VGT" 
21 | 			       :location *test-db-dir*)))
22 |     (fiveam:is (triple-store? *store*))
23 |     (fiveam:is (equal "VGT" *graph*))
24 |     (fiveam:is (triple? (add-triple "VGT" "is-a" "thing" :cf 1.0)))
25 |     (fiveam:is (triple? (first (get-triples-list))))
26 |     (fiveam:is (test-select *store*))
27 |     (fiveam:is-false (close-triple-store))
28 |     (fiveam:is (null *store*))
29 |     (format t "~%")
30 |     (fiveam:is (triple-store? (open-triple-store
31 | 			       :name "VGT"
32 | 			       :location *test-db-dir*)))
33 |     (fiveam:is (triple-store? *store*))
34 |     (fiveam:is (equal "VGT" *graph*))
35 |     (fiveam:is (triple? (first (get-triples-list))))
36 |     (fiveam:is (test-select *store*))
37 |     ;; Concurrency tests
38 |     (fiveam:is (triple? (basic-concurrency-1 *store*)))
39 |     (fiveam:is (basic-concurrency-2 *store*))
40 |     (fiveam:is (delete-undelete-test))
41 |     (fiveam:is-false (close-triple-store))
42 |     (fiveam:is (null *store*))
43 |     (fiveam:is-false (progn
44 | 		       (cl-fad:delete-directory-and-files *test-db-dir*)
45 | 		       (probe-file *test-db-dir*))))
46 |   (fiveam:run!))
47 | 
48 | 


--------------------------------------------------------------------------------
/namespaces.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:vivace-graph-v2)
 2 | 
 3 | (defun register-namespace (short-name uri &key errorp)
 4 |   (declare (ignore errorp))
 5 |   (setf (gethash uri *namespaces*) short-name)
 6 |   (setf (gethash short-name *namespaces*) uri))
 7 | 
 8 | (defun display-namespaces ()
 9 |   (maphash #'(lambda (k v)
10 |                (unless (uri? k)
11 |                  (format t "~A~A=> ~A~%" k #\Tab v)))
12 |            *namespaces*))
13 | 
14 | (defun get-namespace (short-name)
15 |   (gethash short-name *namespaces*))
16 | 
17 | (defun read-node (stream)
18 |   (with-output-to-string (out)
19 |     (loop
20 |        for c = (read-char stream nil :eof)
21 |        do
22 |        (if (member c '(#\Space #\Newline #\Tab #\Return #\)))
23 |            (progn
24 |              (unread-char c stream)
25 |              (return))
26 |            (format out "~A" c)))))
27 | 
28 | (defun read-namespace (stream char)
29 |   (declare (ignore char))
30 |   (let ((c (read-char stream nil :eof)))
31 |     (cond ((eql c #\") ;; This is a string, treat it as such
32 |            (funcall (get-macro-character #\") stream #\"))
33 |           ((eql c #\<) ;; This is a URI, treat it as such
34 |            (format nil "<~A>" (funcall (get-macro-character #\") stream #\>)))
35 |           (t
36 |            (let ((uri (get-namespace
37 |                        (with-output-to-string (key-stream)
38 |                          (loop until (or (eq :eof c) (eql c #\:)) do
39 |                               (format key-stream "~A" c)
40 |                               (setq c (read-char stream nil :eof)))))))
41 |              (if uri
42 |                  (format nil "<~A~A>" uri (read-node stream))
43 |                  nil))))))
44 | 
45 | (defun enable-!-reader ()
46 |   (set-macro-character #\! #'read-namespace))
47 | 
48 | (defun disable-namespace-reader ()
49 |   (set-macro-character #\! nil))
50 | 
51 | (defun namespace-reader-enabled? ()
52 |   (get-macro-character #\!))
53 | 
54 | (defun shorten-namespace (thing)
55 |   thing)
56 | 


--------------------------------------------------------------------------------
/constants.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:vivace-graph-v2)
 2 | 
 3 | (cffi:defctype size :unsigned-int)
 4 | 
 5 | ;; Prolog constants and specials
 6 | (defconstant +unbound+ :unbound)
 7 | (ignore-errors (defconstant +no-bindings+ '((t . t))))
 8 | (defconstant +fail+ nil)
 9 | 
10 | ;; Certainty factors
11 | (defconstant +cf-true+ 1.0)
12 | (defconstant +cf-false+ -1.0)
13 | (defconstant +cf-unknown+ 0.0)
14 | 
15 | ;; Shortened slot identifiers for slot keys
16 | (defparameter +predicate-slot+ #x00)
17 | (defparameter +subject-slot+ #x01)
18 | (defparameter +object-slot+ #x02)
19 | (defparameter +timestamp-slot+ #x03)
20 | (defparameter +belief-factor-slot+ #x04)
21 | (defparameter +deleted?-slot+ #x04)
22 | (defparameter +derived?-slot+ #x05)
23 | (defparameter +uuid-slot+ #x06)
24 | (defparameter +name-slot+ #x07)
25 | (defparameter +clauses-slot+ #x08)
26 | (defparameter +premises-slot+ #x09)
27 | (defparameter +conclusions-slot+ #x0a)
28 | (defparameter +cf-slot+ #x0b)
29 | 
30 | ;; Action identifiers for serialization
31 | (defparameter +transaction+ #x00)
32 | (defparameter +add-triple+ #x01)
33 | (defparameter +delete-triple+ #x02)
34 | (defparameter +undelete-triple+ #X03)
35 | (defparameter +set-cf+ #x04)
36 | 
37 | ;; Built-in type identifiers for serializing
38 | (defconstant +needs-lookup+ :needs-lookup)
39 | (defconstant +negative-integer+ 1)
40 | (defconstant +positive-integer+ 2)
41 | (defconstant +character+ 3)
42 | (defconstant +symbol+ 4)
43 | (defconstant +string+ 5)
44 | (defconstant +list+ 6)
45 | (defconstant +vector+ 7)
46 | (defconstant +single-float+ 8)
47 | (defconstant +double-float+ 9)
48 | (defconstant +ratio+ 10)
49 | (defconstant +t+ 11)
50 | (defconstant +null+ 12)
51 | (defconstant +blob+ 13) ;; Uninterpreted octets
52 | (defconstant +dotted-list+ 14)
53 | (defconstant +compressed-string+ 15)
54 | ;; User-defined type identifiers for serializing. Start at 100
55 | (defconstant +uuid+ 100)
56 | (defconstant +triple+ 101)
57 | (defconstant +predicate+ 102)
58 | (defconstant +timestamp+ 103)
59 | (defconstant +rule+ 104)
60 | 


--------------------------------------------------------------------------------
/full-text-index.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:vivace-graph-v2)
 2 | 
 3 | (defun add-to-text-index (idx triple)
 4 |   ;; FIXME: we need our own tokenizer that does some stemming and such
 5 |   (format t "Adding ~A to full text idx~%" triple)
 6 |   (let ((doc (make-instance 'montezuma:document)))
 7 |     (montezuma:add-field doc
 8 |                          (montezuma:make-field
 9 |                           "triple-id" (format nil "~A" (id triple))
10 |                           :stored t :index :untokenized))
11 |      (montezuma:add-field doc
12 |                           (montezuma:make-field
13 |                            "subject" (format nil "~A" (subject triple))
14 |                            :stored nil :index :tokenized))
15 |      (montezuma:add-field doc
16 |                           (montezuma:make-field
17 |                            "object" (format nil "~A" (object triple))
18 |                            :stored nil :index :tokenized))
19 |      (montezuma:add-field doc
20 |                           (montezuma:make-field
21 |                            "graph" (format nil "~A" (graph triple))
22 |                            :stored nil :index :untokenized))
23 |      (montezuma:add-field doc
24 |                           (montezuma:make-field
25 |                            "predicate" (format nil "~A" (predicate triple))
26 |                            :stored nil :index :untokenized))
27 |      (montezuma:add-document-to-index idx doc)
28 |      doc))
29 | 
30 | (defun remove-from-text-index (idx triple)
31 |   (montezuma:delete-document
32 |    idx (montezuma:make-term "triple-id" (format nil "~A" (id triple)))))
33 | 
34 | (defun full-text-search (index search-string &key g s p)
35 |   (let ((result (make-array 0 :fill-pointer t :adjustable t)))
36 |     (montezuma:search-each
37 |      index
38 |      (with-output-to-string (stream)
39 |        (format stream "object:\"~A\"" search-string)
40 |        (when g (format stream " graph:\"~A\"" g))
41 |        (when g (format stream " subject:\"~A\"" s))
42 |        (when g (format stream " predicate:\"~A\"" p)))
43 |      #'(lambda (doc-id score)
44 |          (let ((doc (montezuma:get-document index doc-id)))
45 |            (vector-push-extend
46 |             (uuid:make-uuid-from-string
47 |              (montezuma:document-value doc "triple-id"))
48 |           result))))
49 |     (make-index-cursor :index index :vector result :pointer 0)))
50 | 


--------------------------------------------------------------------------------
/vivace-graph-v2.asd:
--------------------------------------------------------------------------------
 1 | ;; ASDF package description for vivace-graph-v2              -*- Lisp -*-
 2 | 
 3 | (defpackage :vivace-graph-v2-system (:use :cl :asdf))
 4 | (in-package :vivace-graph-v2-system)
 5 | 
 6 | (defsystem vivace-graph-v2
 7 |   :name "Vivace Graph"
 8 |   :maintainer "Kevin Raison"
 9 |   :author "Kevin Raison <last name @ chatsubo dot net>"
10 |   :version "0.2"
11 |   :description "Vivace Graph Version 2"
12 |   :long-description "Vivace Graph Version 2."
13 |   :depends-on (:babel
14 | 	       #+sbcl :sb-concurrency
15 | 	       #+sbcl :sb-posix
16 | 	       :cffi
17 | 	       :bordeaux-threads
18 | 	       :cl-skip-list
19 | 	       :salza2
20 | 	       :chipz
21 | 	       :hunchentoot
22 | 	       :uuid
23 | 	       :ieee-floats
24 | 	       :local-time
25 | 	       :date-calc
26 | 	       :parse-number
27 | 	       :split-sequence
28 | 	       :py-configparser
29 | 	       :cl-js
30 | 	       :cl-json
31 |                :montezuma)
32 |   :components ((:file "uuid")
33 |                (:file "montezuma")
34 | 	       #+sbcl (:file "sb-impl")
35 | 	       #+sbcl (:file "sb-thread")
36 | 	       (:file "vivace-graph-v2-package"
37 |                       :depends-on ("uuid" "montezuma"))
38 | 	       (:file "hash-table"
39 | 		      :depends-on ("vivace-graph-v2-package"
40 | 				   "sb-impl"
41 | 				   "sb-thread"))
42 | 	       (:file "gettimeofday" :depends-on ("vivace-graph-v2-package"))
43 | 	       (:file "conditions" :depends-on ("vivace-graph-v2-package"))
44 | 	       (:file "constants" :depends-on ("conditions"))
45 | 	       (:file "globals" :depends-on ("constants"))
46 | 	       (:file "utilities" :depends-on ("globals"))
47 | 	       (:file "lock" :depends-on ("utilities" "hash-table"))
48 | 	       (:file "data-types" :depends-on ("lock"))
49 | 	       (:file "certainty-factors" :depends-on ("constants"))
50 | 	       (:file "serialize" :depends-on ("data-types"))
51 | 	       (:file "deserialize" :depends-on ("serialize"))
52 | 	       (:file "index" :depends-on ("deserialize"))
53 | 	       (:file "transaction" :depends-on ("index"))
54 | 	       (:file "full-text-index" :depends-on ("transaction"))
55 | 	       (:file "store" :depends-on ("transaction" "full-text-index"))
56 | 	       (:file "namespaces" :depends-on ("store"))
57 | 	       (:file "functor" :depends-on ("namespaces"))
58 | 	       (:file "triples" :depends-on ("functor" "gettimeofday"))
59 | 	       (:file "prologc" :depends-on ("triples"))
60 | 	       (:file "prolog-functors" :depends-on ("prologc"))
61 | 	       (:file "templates" :depends-on ("prolog-functors"))))
62 | 


--------------------------------------------------------------------------------
/README:
--------------------------------------------------------------------------------
 1 | A free competitor to Franz's AllegroGraph by Kevin Raison.
 2 | 
 3 | At the moment, this code is in a state of rapid flux.  Please don't expect
 4 | it to behave consistently from one check-in to another.
 5 | 
 6 | The goal is to build a fast, robust, distributed graph database with optional
 7 | RDF semantics built-in.  The primary query language is Prolog (based on PAIP),
 8 | but I have plans to add Javascript and maybe Sparql at a later date.
 9 | At the moment, persistence is achieved via transaction logging and replay.
10 | I am also working on a native SBCL memory mapped persistence
11 | library that will give me some variation on linear hash tables.
12 | 
13 | The code checked-in as of 2012/05/06 works fairly well, but should be
14 | considered alpha quality.  In order to get it working, you will need the
15 | following:
16 | 
17 | SBCL 1.0.42 or higher: http://www.sbcl.org/platform-table.html
18 | cl-skip-list: http://www.cliki.net/cl-skip-list
19 | bordeaux-threads: http://common-lisp.net/project/bordeaux-threads/
20 | hunchentoot: http://weitz.de/hunchentoot/
21 | cl-json: http://common-lisp.net/project/cl-json/
22 | uuid: http://www.dardoria.net/software/uuid.html
23 | ieee-floats: http://common-lisp.net/project/ieee-floats/
24 | parse-number: http://www.cliki.net/PARSE-NUMBER
25 | cffi: http://common-lisp.net/project/cffi/
26 | local-time: http://common-lisp.net/project/local-time/
27 | date-calc: http://common-lisp.net/project/cl-date-calc/
28 | py-configparser: http://common-lisp.net/project/py-configparser/
29 | js: http://github.com/akapav/js
30 | split-sequence: http://www.cliki.net/SPLIT-SEQUENCE
31 | Montezuma
32 | 
33 | 
34 | To get you started:
35 | (asdf:oos 'asdf:load-op 'vivace-graph-v2)
36 | (in-package #:vivace-graph-v2)
37 | 
38 | (create-triple-store :name "test store" :location "/var/tmp/db")
39 | (index-predicate "likes")
40 | (with-graph-transaction (*store*)
41 |   (add-triple "Kevin" "is-a" "human")
42 |   (add-triple "Joe" "is-a" "human")
43 |   (add-triple "Fido" "is-a" "dog")
44 |   (add-triple "Kevin" "likes" "Fido")
45 |   (add-triple "Kevin" "likes" "Joe")
46 |   (add-triple "Joe" "likes" "programming lisp")
47 |   (add-triple "Kevin" "likes" "programming lisp")
48 |   (add-triple "Kevin" "likes" "programming perl")
49 |   (add-triple "Kevin" "likes" "programming c"))
50 | 
51 | (select (?x ?y) (q- ?x "likes" ?y))
52 | 
53 | (get-triples-list :search-string "programming")
54 | 
55 | (get-triples-list :s "Kevin")
56 | (get-triples-list :p "is-a")
57 | (close-triple-store :store *store*)
58 | 
59 | (open-triple-store :name "test store" :location "/var/tmp/db")
60 | (index-predicate "likes")
61 | (select (?x ?y) (q- ?x "likes" ?y))
62 | (select-flat (?object) (q- "Kevin" "likes" (?object "a" "z")))
63 | (get-triples-list :s "Kevin")
64 | (get-triples-list :p "is-a")
65 | (close-triple-store :store *store*)
66 | 


--------------------------------------------------------------------------------
/templates.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:vivace-graph-v2)
 2 | 
 3 | (defmacro deftemplate (name &rest slots)
 4 |   "Define a template:
 5 |  (deftemplate person
 6 |    (slot has-name)
 7 |    (slot has-age)
 8 |    (slot has-eye-color)
 9 |    (slot has-hair-color))
10 | A function is added to the template table of *store* with name NAME.  This
11 | function will be used to create groups of triples conforming to this template.
12 | See FACT and DEFFACTS."
13 |   (let ((node (gensym)))
14 |     `(progn
15 |        (unless (triple-store? *store*)
16 |          (error "deftemplate ~A: *store* is not bound to a triple store!"
17 |                 ',name))
18 |        (setf (gethash ',name (templates *store*))
19 |              #'(lambda (&key ,@(mapcar #'second slots))
20 |                  (with-graph-transaction (*store*)
21 |                    (let ((,node (make-anonymous-node)))
22 |                      (add-triple ,node "is-a"
23 |                                  ,(string-downcase (symbol-name name)))
24 |                      ,@(mapcar
25 |                         #'(lambda (slot)
26 |                             `(add-triple
27 |                               ,node
28 |                               ,(string-downcase (symbol-name (second slot)))
29 |                               ,(second slot)))
30 |                         slots)
31 |                      ,node)))))))
32 | 
33 | (defmacro fact (template)
34 |   "Create a group of triples using the named template as defined in
35 | DEFTEMPLATE:
36 |  (fact (person (has-name \"John Q. Public\")
37 |   	       (has-age 23)
38 |   	       (has-eye-color blue)
39 |  	       (has-hair-color black)))"
40 |   (let ((tmpl-name (gensym)))
41 |     `(let ((,tmpl-name ',(first template)))
42 |        (funcall
43 |         (gethash ,tmpl-name (templates *store*))
44 |         ,@(mapcan #'(lambda (slot)
45 |                       `(,(intern (symbol-name (first slot)) 'keyword)
46 |                          ,(second slot)))
47 |                   (rest template))))))
48 | 
49 | (defmacro deffacts (&rest templates)
50 |   "Create a set of triple groups conforming to the named template as defined
51 | by DEFTEMPLATE:
52 |  (deffacts
53 |      (person (has-name \"John Q. Public\") (has-age 23)
54 |  	     (has-eye-color blue) (has-hair-color black))
55 |      (person (has-name \"Jane S. Public\") (has-age 24)
56 |     	     (has-eye-color blue) (has-hair-color blond)))"
57 |   (let ((template (gensym)))
58 |     `(mapcar
59 |       #'(lambda (,template)
60 |           (let ((tmpl-name (first ,template)))
61 |             (format t "tmpl-name is ~A~%" tmpl-name)
62 |             (apply (gethash tmpl-name (templates *store*))
63 |                    (flatten
64 |                     (mapcar
65 |                      #'(lambda (slot)
66 |                          (list (intern (symbol-name (first slot)) 'keyword)
67 |                                (second slot)))
68 |                      (rest ,template))))))
69 |       ',templates)))
70 | 


--------------------------------------------------------------------------------
/contrib/kraison/rete.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:vivace-graph)
 2 | 
 3 | (defconstant +rete-wildcard+ :*)
 4 | (defconstant +beta-memory+ :beta)
 5 | (defconstant +join-node+ :join)
 6 | (defconstant +p-node+ :p-node)
 7 | 
 8 | (defstruct (rete-net
 9 | 	     (:predicate rete-net?)
10 | 	     (:conc-name rn-))
11 |   (alpha-memory (make-hash-table :synchronized t :test 'equal))
12 |   (beta-memory nil)
13 |   (beta-memory-index (make-hash-table :synchronized t :test 'equal)))
14 | 
15 | (defstruct (alpha-memory
16 | 	     (:predicate alpha-memory?)
17 | 	     (:conc-name alpha-))
18 |   triples children)
19 | 
20 | (defstruct (token
21 | 	     (:predicate token?)
22 | 	     (:conc-name token-))
23 |   parent triple)
24 | 
25 | (defstruct (rete-node
26 | 	     (:predicate rete-node?)
27 | 	     (:conc-name rete-node-))
28 |   type children parent tokens alpha-memory tests)
29 | 
30 | (defstruct (join-node-test 
31 | 	     (:conc-name nil))
32 |   arg1-field arg2-field levels-up)
33 | 
34 | (defgeneric add-rule (rule))
35 | 
36 | (defun join-test (tests token wme)
37 |   )
38 | ;  (dolist (test tests)
39 | ;    (let ((arg1 (funcall (arg1-field test) wme)))
40 | ;      (dolist
41 | 	  
42 | (defmethod left-activate ((node rete-node) (token token) &optional wme)
43 |   (case (rete-node-type node)
44 |     (+beta-memory+
45 |      (let ((token (make-token :parent token :triple wme)))
46 |        (push token (rete-node-tokens node))
47 |        (dolist (child (rete-node-children node))
48 | 	 (left-activate child token))))
49 |     (+join-node+
50 |      (dolist (wme (alpha-triples (rete-node-alpha-memory node)))
51 |        (when (join-test (rete-node-tests node) token wme)
52 | 	 (dolist (child (rete-node-children node))
53 | 	   (left-activate child token wme)))))
54 |     (+p-node+ nil)))
55 | 
56 | (defmethod right-activate ((node rete-node) (wme triple))
57 |   (case (rete-node-type node)
58 |     (+beta-memory+ nil)
59 |     (+join-node+
60 |      (dolist (token (rete-node-tokens (rete-node-parent node)))
61 |        (when (join-test (rete-node-tests node) token wme)
62 | 	 (dolist (child (rete-node-children node))
63 | 	   (left-activate child token wme)))))
64 |     (+p-node+ nil)))
65 | 
66 | (defmethod activate-alpha-memory ((am alpha-memory) (triple triple))
67 |   (push triple (alpha-triples am))
68 |   (dolist (child (alpha-children am))
69 |     (right-activate child triple)))
70 | 
71 | (defmethod add-wme ((triple triple))
72 |   (flet ((add-wme1 (wme)
73 | 	   (let ((am (gethash wme (rete-net *graph*))))
74 | 	     (when (alpha-memory? am)
75 | 	       (activate-alpha-memory am triple)))))
76 |     (let ((wme (as-list triple)))
77 |       (add-wme1 wme)
78 |       (add-wme1 (list (predicate wme) (subject wme) +rete-wildcard+))
79 |       (add-wme1 (list (predicate wme) +rete-wildcard+ (object wme)))
80 |       (add-wme1 (list (predicate wme) +rete-wildcard+ +rete-wildcard+))
81 |       (add-wme1 (list +rete-wildcard+ (subject wme) (object wme)))
82 |       (add-wme1 (list +rete-wildcard+ (subject wme) +rete-wildcard+))
83 |       (add-wme1 (list +rete-wildcard+ +rete-wildcard+ (object wme)))
84 |       (add-wme1 (list +rete-wildcard+ +rete-wildcard+ +rete-wildcard+)))
85 |     ))
86 | 
87 | ;(defmethod add-rule ((rule rule))
88 | ;  (dolist (premise (rule-premises rule))
89 | ;    ))
90 | 


--------------------------------------------------------------------------------
/uuid.lisp:
--------------------------------------------------------------------------------
 1 | (in-package #:uuid)
 2 | 
 3 | (export 'time-low)
 4 | (export 'time-mid)
 5 | (export 'time-high)
 6 | (export 'clock-seq-var)
 7 | (export 'clock-seq-low)
 8 | (export 'node)
 9 | (export 'time-high-and-version)
10 | (export 'clock-seq-and-reserved)
11 | (export 'uuid-eql)
12 | (export 'uuid?)
13 | (export 'serialize-uuid)
14 | 
15 | (defgeneric uuid? (thing)
16 |   (:method ((thing uuid)) t)
17 |   (:method (thing) nil)
18 |   (:documentation "UUID type predicate."))
19 | 
20 | (defgeneric uuid-eql (uuid1 uuid2)
21 |   (:method ((uuid1 uuid) (uuid2 uuid))
22 |     (equalp (uuid-to-byte-array uuid1) (uuid-to-byte-array uuid2)))
23 |   (:method ((uuid1 uuid) uuid2)
24 |     nil)
25 |   (:method (uuid1 (uuid2 uuid))
26 |     nil)
27 |   (:documentation "Equality check for UUIDs."))
28 | 
29 | (defun serialize-uuid (uuid stream)
30 |   (with-slots
31 | 	(time-low time-mid time-high-and-version clock-seq-and-reserved
32 |                   clock-seq-low node)
33 |       uuid
34 |     (loop for i from 3 downto 0
35 |        do (write-byte (ldb (byte 8 (* 8 i)) time-low) stream))
36 |     (loop for i from 5 downto 4
37 |        do (write-byte (ldb (byte 8 (* 8 (- 5 i))) time-mid) stream))
38 |     (loop for i from 7 downto 6
39 |        do (write-byte (ldb (byte 8 (* 8 (- 7 i))) time-high-and-version)
40 |                       stream))
41 |     (write-byte (ldb (byte 8 0) clock-seq-and-reserved) stream)
42 |     (write-byte (ldb (byte 8 0) clock-seq-low) stream)
43 |     (loop for i from 15 downto 10
44 |        do (write-byte (ldb (byte 8 (* 8 (- 15 i))) node) stream))))
45 | 
46 | (defun uuid-to-byte-array (uuid &optional (type-specifier nil))
47 |   "Converts an uuid to byte-array"
48 |   (if type-specifier
49 |       (let ((array (make-array 18 :element-type '(unsigned-byte 8))))
50 | 	(setf (aref array 0) type-specifier)
51 | 	(setf (aref array 1) 16)
52 | 	(with-slots
53 | 	      (time-low time-mid time-high-and-version clock-seq-and-reserved
54 | 			clock-seq-low node)
55 | 	    uuid
56 | 	  (loop for i from 3 downto 0
57 | 	     do (setf (aref array (+ 2 (- 3 i)))
58 |                       (ldb (byte 8 (* 8 i)) time-low)))
59 | 	  (loop for i from 5 downto 4
60 | 	     do (setf (aref array (+ 2 i))
61 |                       (ldb (byte 8 (* 8 (- 5 i))) time-mid)))
62 | 	  (loop for i from 7 downto 6
63 | 	     do (setf (aref array (+ 2 i)) (ldb (byte 8 (* 8 (- 7 i)))
64 | 						time-high-and-version)))
65 | 	  (setf (aref array (+ 2 8)) (ldb (byte 8 0) clock-seq-and-reserved))
66 | 	  (setf (aref array (+ 2 9)) (ldb (byte 8 0) clock-seq-low))
67 | 	  (loop for i from 15 downto 10
68 | 	     do (setf (aref array (+ 2 i))
69 |                       (ldb (byte 8 (* 8 (- 15 i))) node)))
70 | 	  array))
71 |       (let ((array (make-array 16 :element-type '(unsigned-byte 8))))
72 | 	(with-slots
73 | 	      (time-low time-mid time-high-and-version clock-seq-and-reserved
74 | 			clock-seq-low node)
75 | 	    uuid
76 | 	  (loop for i from 3 downto 0
77 | 	     do (setf (aref array (- 3 i)) (ldb (byte 8 (* 8 i)) time-low)))
78 | 	  (loop for i from 5 downto 4
79 | 	     do (setf (aref array i) (ldb (byte 8 (* 8 (- 5 i))) time-mid)))
80 | 	  (loop for i from 7 downto 6
81 | 	     do (setf (aref array i) (ldb (byte 8 (* 8 (- 7 i)))
82 | 					  time-high-and-version)))
83 | 	  (setf (aref array 8) (ldb (byte 8 0) clock-seq-and-reserved))
84 | 	  (setf (aref array 9) (ldb (byte 8 0) clock-seq-low))
85 | 	  (loop for i from 15 downto 10
86 | 	     do (setf (aref array i) (ldb (byte 8 (* 8 (- 15 i))) node)))
87 | 	  array))))
88 | 


--------------------------------------------------------------------------------
/TODO:
--------------------------------------------------------------------------------
 1 | ;;; :FILE-CREATED <Timestamp: #{2011-09-04T13:05:03-04:00Z}#{11357} - by MON>
 2 | ;;; :FILE vivace-graph-v2-FORK/TODO
 3 | ;;; ==============================
 4 | 
 5 | Following TODO adapted from the following two threads posted to
 6 | vivace-graph-devel mailing list:
 7 | 
 8 |  [vivace-graph-devel] vivace-graph todo list
 9 |  Kevin Raison raison at chatsubo.net
10 |  Tue Feb 1 00:15:23 EST 2011
11 |  (URL `http://lists.common-lisp.net/pipermail/vivace-graph-devel/2011-February/000000.html')
12 | 
13 |  [vivace-graph-devel] vivace-graph moving again
14 |  Kevin Raison raison at chatsubo.net
15 |  Sat Jul 2 17:00:43 PDT 2011
16 |  (URL `http://lists.common-lisp.net/pipermail/vivace-graph-devel/2011-July/000002.html')
17 | 
18 | I (mon-key) have replaced the original per item numeric annotations with
19 | asterisks and changed the read order to accomodate re-grouping of related
20 | tasks. This re-grouping occured under the assumption that the original numeric
21 | ordering of KR's requirements did necessarily imply that some requierment-A was
22 | implicitly more important / required than some other requirement-Z.
23 | 
24 | ;;; ==============================
25 | The major things that need to be done to satisfy my personal requirements:
26 | 
27 | *   Fix lexical env issues between Prolog and Lisp.
28 |     Currently, importing a Lisp variable into Prolog requires that it be
29 |     declared SPECIAL.  This is because the Prolog implementation is based on
30 |     Norvig's PAIP, which uses CL:EVAL.  A better solution should be found.
31 | 
32 | *   While triples are thread safe, Prolog may or may not be.
33 |     This should be investigated and fixed where necessary.
34 | 
35 | *   Remove the SBCL-specific code that litters the project.
36 | 
37 | *   Make a choice on what sort of on-disk storage mechanism to use.  
38 |     Currently, all data must fit in RAM and is persisted via snapshotting and
39 |     transaction logging.
40 | 
41 |     I would like to add a second option where, as in a standard database, data
42 |     can be stored in a disk-based structure. 
43 | 
44 |      - memory mapped linear hash tables. KTR: *** This is my preferred option ***
45 | 
46 |      - B+Trees  
47 | 
48 |      - Fractal Prefetching B+Trees 
49 |        (http://reports-archive.adm.cs.cmu.edu/anon/2002/CMU-CS-02-115.pdf)?
50 | 
51 |      - B-Tries
52 |        I expressed concern to Red and Ilya about using B-trees, given the
53 |        extremely high fanout of the indices.
54 | 
55 |        I was considering something like B-tries, as described in this paper:
56 |         (URL `http://www.naskitis.com/naskitis-vldbj09.pdf').
57 | 
58 | *   Add reciprocal reasoning. 
59 |      (has-child implies has-parent)
60 | 
61 | *   Factor out the certainty factors code.
62 |      - Make CFs first class triples
63 |        Currently these are a mutable fields of the structure TRIPLE. 
64 | 
65 | *   Incorporate Geospatial / Temporal reasoning
66 | 
67 | *   Incorporate forward chaining rules engine.
68 |      (Rete or LEAPS-derived)
69 | 
70 | *   Incorporate more RDF-related stuff. 
71 |     (Sparql, N-Triples parser / loader, etc.)
72 | 
73 | *   Implement a protocol for submitting queries over the network.
74 | 
75 | 
76 | 
77 | COMPLETED ITEMS:
78 | 
79 | *   Spend some time on the text indexing piece.
80 |     It currently uses my cl-skip-list, but should be moved into a B-tree.
81 |     KTR: *** I recently integrated Montezuma for this purpose.  It may need some cleaning up. ***
82 | 
83 | *   Stabilize transaction logging. 
84 |     KTR: *** This is done.  Transaction logging has been working quite well for a long while. ***
85 | 
86 | 
87 | ;;; ==============================
88 | ;;; EOF
89 | 


--------------------------------------------------------------------------------
/vivace-graph-v2-package.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:cl-user)
  2 | 
  3 | (defpackage #:vivace-graph-v2
  4 |   (:use #:cl
  5 | 	#:cffi
  6 | 	#:bordeaux-threads
  7 | 	#:cl-skip-list
  8 | 	#:local-time)
  9 |   (:export #:*store*
 10 | 	   #:create-triple-store
 11 | 	   #:open-triple-store
 12 | 	   #:close-triple-store
 13 | 	   #:clear-triple-store
 14 |            #:snapshot
 15 | 	   #:*store*
 16 | 	   #:*graph*
 17 | 	   #:use-graph
 18 | 	   #:clear-graph
 19 | 	   #:triple-store?
 20 | 	   #:needs-indexing?
 21 | 	   #:do-indexing
 22 | 	   #:with-graph-transaction
 23 | 	   #:with-locked-index
 24 | 	   #:get-table-to-lock
 25 | 	   #:*current-transaction*
 26 | 	   #:*in-transaction-p
 27 | 	   #:main-idx
 28 | 	   #:log-mailbox
 29 | 	   #:tx-store
 30 | 	   #:transaction?
 31 | 	   #:dbm-rollback
 32 | 	   #:dbm-commit
 33 | 	   #:dbm-begin
 34 | 	   #:triple-db
 35 | 	   #:functors
 36 | 	   #:enable-!-reader
 37 | 	   #:disable-namespace-reader
 38 | 	   #:register-namespace
 39 | 	   #:display-namespaces
 40 | 
 41 | 	   #:triple?
 42 | 	   #:triple-subject
 43 | 	   #:triple-predicate
 44 | 	   #:triple-object
 45 | 	   #:triple-id
 46 | 	   #:triple-cf
 47 | 	   #:subject
 48 | 	   #:predicate
 49 | 	   #:object
 50 | 	   #:id
 51 | 	   #:cf
 52 | 	   #:triple-eql
 53 | 	   #:triple-equal
 54 | 	   #:make-anonymous-node
 55 | 	   #:add-triple
 56 | 	   #:get-triples
 57 | 	   #:get-triples-list
 58 | 	   #:list-triples
 59 | 	   #:triple-count
 60 | 	   #:-o
 61 | 	   #:lookup-triple
 62 | 	   #:bulk-add-triples
 63 | 	   #:index-predicate?
 64 | 	   #:list-indexed-predicates
 65 | 	   #:index-predicate
 66 | 	   #:unindex-predicate
 67 | 	   #:map-text-search
 68 | 	   #:delete-triple
 69 | 	   #:undelete-triple
 70 | 	   #:triple-deleted?
 71 | 	   #:erase-triple
 72 | 	   #:dump-triples
 73 | 	   #:load-triples
 74 | 	   #:reify
 75 | 	   #:reify-recursive
 76 | 	   #:anonymous?
 77 | 
 78 | 	   #:rule?
 79 | 	   #:defrule
 80 | 	   #:get-rule
 81 | 	   #:retract-rule
 82 | 	   #:deftemplate
 83 | 	   #:fact
 84 | 	   #:deffacts
 85 | 
 86 | 	   #:certainty-factor-p
 87 | 	   #:belief-factor
 88 | 	   #:true-p
 89 | 	   #:false-p
 90 | 	   #:unknown-p
 91 | 	   #:cf-or
 92 | 	   #:cf-and
 93 | 	   #:cf-combine
 94 | 	   #:conjunct-cf
 95 | 	   #:recalculate-cf
 96 | 	   #:adjust-belief
 97 | 	   #:set-triple-cf
 98 | 
 99 | 	   #:!
100 | 	   #:<-
101 | 	   #:?-
102 | 	   #:q-
103 | 	   #:cut
104 | 	   #:prolog
105 | 	   #:def-global-prolog-functor
106 | 	   #:*prolog-global-functors*
107 | 	   #:unify
108 | 	   #:var-deref
109 | 	   #:insert
110 | 	   #:select
111 | 	   #:select-flat
112 | 	   #:select-first
113 | 	   #:select-one
114 | 	   #:do-query
115 | 	   #:map-query
116 | 	   #:read/1
117 | 	   #:wrte/1
118 | 	   #:nl/0
119 | 	   #:repeat/0
120 | 	   #:fail/0
121 | 	   #:=/2
122 | 	   #:==/2
123 | 	   #:/=/2
124 | 	   #:>/2
125 | 	   #:</2
126 | 	   #:>=/2
127 | 	   #:<=/2
128 | 	   #:??
129 | 	   #:lisp/2
130 | 	   #:regex-match/2
131 | 	   #:var/1
132 | 	   #:is/2
133 | 	   #:call/1
134 | 	   #:not/1
135 | 	   #:bagof/3
136 | 	   #:setof/3
137 | 	   #:if/2
138 | 	   #:if/3
139 | 	   #:is-valid/1
140 | 	   #:is-valid?/1
141 | 	   #:is-invalid/1
142 | 	   #:is-invalid?/1
143 | 	   #:valid-date?/1
144 | 	   #:trigger/1
145 | 	   #:assert/1
146 | 	   #:retract/1
147 | 	   #:show-prolog-vars/2
148 | 	   #:select/2
149 | 	   #:select-as-bind-alist/2
150 | 	   #:triple-search/3
151 | 	   #:valid-date?
152 | 	   #:*trail*
153 | 	   #:*var-counter*
154 | 	   #:*predicate*
155 | 	   #:*select-list*
156 | 	   #:*prolog-global-functors*
157 | 	   #:*prolog-trace*
158 | 	   #:trace-prolog
159 | 	   #:untrace-prolog
160 | 	   #:prolog-error
161 | 
162 | 	   #:timestamp?
163 | 	   #:universal-to-timestamp
164 | 	   #:timestamp-to-universal
165 | 	   #:decode-timestamp
166 | 
167 | 	   #:flatten
168 | 	   ))
169 | 


--------------------------------------------------------------------------------
/gettimeofday.lisp:
--------------------------------------------------------------------------------
 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
 2 | ;;;
 3 | ;;; gettimeofday.lisp --- Example CFFI binding to gettimeofday(2)
 4 | ;;;
 5 | ;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
 6 | ;;;
 7 | ;;; Permission is hereby granted, free of charge, to any person
 8 | ;;; obtaining a copy of this software and associated documentation
 9 | ;;; files (the "Software"), to deal in the Software without
10 | ;;; restriction, including without limitation the rights to use, copy,
11 | ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
12 | ;;; of the Software, and to permit persons to whom the Software is
13 | ;;; furnished to do so, subject to the following conditions:
14 | ;;;
15 | ;;; The above copyright notice and this permission notice shall be
16 | ;;; included in all copies or substantial portions of the Software.
17 | ;;;
18 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
19 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
20 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
21 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
22 | ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
23 | ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
24 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
25 | ;;; DEALINGS IN THE SOFTWARE.
26 | ;;;
27 | 
28 | ;;;# CFFI Example: gettimeofday binding
29 | ;;;
30 | ;;; This example illustrates the use of foreign structures, typedefs,
31 | ;;; and using type translators to do checking of input and output
32 | ;;; arguments to a foreign function.
33 | 
34 | ;;; Define the TIMEVAL structure used by 'gettimeofday'. This assumes
35 | ;;; that 'time_t' is a 'long' --- it would be nice if CFFI could
36 | ;;; provide a proper :TIME-T type to help make this portable.
37 | (in-package #:vivace-graph-v2)
38 | 
39 | (defcstruct timeval
40 |   (tv-sec :long)
41 |   (tv-usec :long))
42 | 
43 | ;;; A NULL-POINTER is a foreign :POINTER that must always be NULL.
44 | ;;; Both a NULL pointer and NIL are legal values---any others will
45 | ;;; result in a runtime error.
46 | (define-foreign-type null-pointer-type ()
47 |   ()
48 |   (:actual-type :pointer)
49 |   (:simple-parser null-pointer))
50 | 
51 | ;;; This type translator is used to ensure that a NULL-POINTER has a
52 | ;;; null value. It also converts NIL to a null pointer.
53 | (defmethod translate-to-foreign (value (type null-pointer-type))
54 |   (cond
55 |     ((null value) (null-pointer))
56 |     ((null-pointer-p value) value)
57 |     (t (error "~A is not a null pointer." value))))
58 | 
59 | ;;; The SYSCALL-RESULT type is an integer type used for the return
60 | ;;; value of C functions that return -1 and set errno on errors.
61 | ;;; Someday when CFFI has a portable interface for dealing with
62 | ;;; 'errno', this error reporting can be more useful.
63 | (define-foreign-type syscall-result-type ()
64 |   ()
65 |   (:actual-type :int)
66 |   (:simple-parser syscall-result))
67 | 
68 | ;;; Type translator to check a SYSCALL-RESULT and signal a Lisp error
69 | ;;; if the value is negative.
70 | (defmethod translate-from-foreign (value (type syscall-result-type))
71 |   (if (minusp value)
72 |       (error "System call failed with return value ~D." value)
73 |       value))
74 | 
75 | ;;; Define the Lisp function %GETTIMEOFDAY to call the C function
76 | ;;; 'gettimeofday', passing a pointer to the TIMEVAL structure to fill
77 | ;;; in. The TZP parameter is deprecated and should be NULL --- we can
78 | ;;; enforce this by using our NULL-POINTER type defined above.
79 | (defcfun ("gettimeofday" %gettimeofday) syscall-result
80 |   (tp :pointer)
81 |   (tzp null-pointer))
82 | 
83 | (defun gettimeofday ()
84 |   (with-foreign-object (tv 'timeval)
85 |     (%gettimeofday tv nil)
86 |     (with-foreign-slots ((tv-sec tv-usec) tv timeval)
87 |       (+ tv-sec (/ tv-usec 1000000)))))
88 | 
89 | 


--------------------------------------------------------------------------------
/test-scenarios.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:vivace-graph-v2-test)
  2 | 
  3 | (defparameter *basic-concurrency-1* nil)
  4 | (defparameter *basic-concurrency-2* nil)
  5 | (defparameter *triple-2* nil)
  6 | 
  7 | (defun basic-concurrency-1 (&optional (store *store*))
  8 |   (let ((*store* store))
  9 |     (let ((thr1 (make-thread 
 10 | 		 #'(lambda ()
 11 | 		     (with-graph-transaction (*store* :timeout 10)
 12 | 		       (let ((triple (add-triple "This" "is-a" "test" :graph "VGT")))
 13 | 			 (format t "~%basic-concurrency-1 thr1: ~A: ~A~%" 
 14 | 				 (triple-id triple) triple)
 15 | 			 (setq *basic-concurrency-1* triple)
 16 | 			 (sleep 3))))))
 17 | 	  (thr2 (make-thread 
 18 | 		 #'(lambda ()
 19 | 		     (sleep 1)
 20 | 		     (let ((triple (add-triple
 21 | 				    "This" "is-a" "test" :graph "VGT")))
 22 | 		       (if (triple? triple)
 23 | 			   (format t "basic-concurrency-1 thr2: ~A: ~A~%" 
 24 | 				   (triple-id triple) triple)
 25 | 			   (format t "basic-concurrency-1 thr2: ~A~%" triple))
 26 | 			   (if (triple-equal triple *basic-concurrency-1*)
 27 | 			       (setq *basic-concurrency-1* triple)
 28 | 			       (setq *basic-concurrency-1* nil)))))))
 29 |       (join-thread thr1)
 30 |       (join-thread thr2)
 31 |       (format t "basic-concurrency-1: ~A~%" *basic-concurrency-1*)
 32 |       *basic-concurrency-1*)))
 33 |     
 34 | (defun basic-concurrency-2 (&optional (store *store*))
 35 |   (let* ((*store* store)
 36 | 	 (read-fn #'(lambda ()
 37 | 		      (let ((*read-uncommitted* t))
 38 | 			(sleep (random 2.0))
 39 | 			(let ((triple (lookup-triple "This" "is-a" "test-2" "VGT")))
 40 | 			  (if (triple? triple)
 41 | 			      (format t "basic-concurrency-2 read-thr: ~A: ~A~%" 
 42 | 				      (triple-id triple) triple)
 43 | 			      (format t "basic-concurrency-2 read-thr: ~A~%" triple))
 44 | 			  (push (list (current-thread) triple) 
 45 | 				*basic-concurrency-2*))))))
 46 |     (let ((thr1 (make-thread 
 47 | 		 #'(lambda ()
 48 | 		     (with-graph-transaction (*store* :timeout 10)
 49 | 		       (let ((triple (add-triple "This" "is-a" "test-2" :graph "VGT")))
 50 | 			 (format t "~%basic-concurrency-2 thr1: ~A: ~A~%" 
 51 | 				 (triple-id triple) triple)
 52 | 			 (setq *triple-2* triple)
 53 | 			 (sleep 3))))))
 54 | 	  (thr2 (make-thread 
 55 | 		 #'(lambda ()
 56 | 		     (sleep 1)
 57 | 		     (let ((triple (add-triple
 58 | 				    "This" "is-a" "test-2" :graph "VGT")))
 59 | 		       (if (triple? triple)
 60 | 			   (format t "basic-concurrency-2 thr2: ~A: ~A~%" 
 61 | 				   (triple-id triple) triple)
 62 | 			   (format t "basic-concurrency-2 thr2: ~A~%" triple))
 63 | 		       (push (list (current-thread) triple) *basic-concurrency-2*)))))
 64 | 	  (thr3 (make-thread read-fn))
 65 | 	  (thr4 (make-thread read-fn))
 66 | 	  (thr5 (make-thread read-fn)))
 67 |       (join-thread thr1)
 68 |       (join-thread thr2)
 69 |       (join-thread thr3)
 70 |       (join-thread thr4)
 71 |       (join-thread thr5)
 72 |       (every #'(lambda (triple)
 73 | 		 (triple-equal (second triple) *triple-2*))
 74 | 	     *basic-concurrency-2*))))
 75 | 
 76 | (defun delete-undelete-test ()
 77 |   (let ((triple (add-triple "This" "is-a" "delete-undelete-test")))
 78 |     (let ((triple2 (lookup-triple "This" "is-a" "delete-undelete-test" "VGT")))
 79 |       (unless (triple-equal triple triple2)
 80 | 	(error "~A not triple-equal to ~A" triple triple2))
 81 |       (delete-triple triple)
 82 |       (if (triple-deleted? triple)
 83 | 	  (format t "~%Deleted ~A: ~A~%" triple (triple-deleted? triple))
 84 | 	  (error "~A not deleted." triple))
 85 |       (let ((triple3 (lookup-triple "This" "is-a" "delete-undelete-test" "VGT")))
 86 | 	(unless (null triple3)
 87 | 	  (error "lookup-triple was not null: ~A!" triple3))
 88 | 	(format t "lookup-triple: ~A~%" triple3))
 89 |       (let ((triple3 (lookup-triple "This" "is-a" "delete-undelete-test" "VGT"
 90 | 				    :retrieve-deleted? t)))
 91 | 	(unless (triple? triple3)
 92 | 	  (error "lookup-triple :retrieve-deleted? t was null: ~A!" triple3))
 93 | 	(format t "lookup-triple :retrieve-deleted? t: ~A~%" triple3))
 94 |       (add-triple "This" "is-a" "delete-undelete-test" :graph "VGT")
 95 |       (let ((triple3 (lookup-triple "This" "is-a" "delete-undelete-test" "VGT")))
 96 | 	(when (triple? triple3)
 97 | 	  (format t "undeleted ~A~%" triple3))
 98 | 	(triple? triple3)))))
 99 | 
100 | 
101 | 
102 | 
103 | 


--------------------------------------------------------------------------------
/certainty-factors.lisp:
--------------------------------------------------------------------------------
  1 | ;;; Copyright (C) 2000 David E. Young
  2 | 
  3 | ;;; This library is free software; you can redistribute it and/or
  4 | ;;; modify it under the terms of the GNU Lesser General Public License
  5 | ;;; as published by the Free Software Foundation; either version 2.1
  6 | ;;; of the License, or (at your option) any later version.
  7 | 
  8 | ;;; This library is distributed in the hope that it will be useful,
  9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 11 | ;;; GNU Lesser General Public License for more details.
 12 | 
 13 | ;;; You should have received a copy of the GNU Lesser General Public License
 14 | ;;; along with this library; if not, write to the Free Software
 15 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 16 | 
 17 | ;;; File: certainty-factors.lisp
 18 | 
 19 | ;;; Description: An implementation of Certainty Factors as found in Peter
 20 | ;;; Norvig's PAIP.
 21 | 
 22 | ;;; Modified for VivaceGraph by Keivn Raison, 2010
 23 | 
 24 | (in-package #:vivace-graph-v2)
 25 | 
 26 | (defgeneric belief-factor (tuple))
 27 | 
 28 | (defmethod belief-factor ((tuple list))
 29 |   (fifth tuple))
 30 | 
 31 | (defun certainty-factor-p (number)
 32 |   (<= +cf-false+ number +cf-true+))
 33 | 
 34 | (deftype certainty-factor ()
 35 |   `(and (real)
 36 | 	(satisfies certainty-factor-p)))
 37 | 
 38 | (defun true-p (cf)
 39 |   (check-type cf certainty-factor)
 40 |   (> cf +cf-unknown+))
 41 | 
 42 | (defun false-p (cf)
 43 |   (check-type cf certainty-factor)
 44 |   (< cf +cf-unknown+))
 45 | 
 46 | (defun unknown-p (cf)
 47 |   (check-type cf certainty-factor)
 48 |   (= cf +cf-unknown+))
 49 | 
 50 | (defun cf-or (a b)
 51 |   "Combine the certainty factors for the formula (A or B).
 52 |   This is used when two rules support the same conclusion."
 53 |   (check-type a certainty-factor)
 54 |   (check-type b certainty-factor)
 55 |   (cond ((and (> a 0) (> b 0))
 56 |          (+ a b (* -1 a b)))
 57 |         ((and (< a 0) (< b 0))
 58 |          (+ a b (* a b)))
 59 |         (t (/ (+ a b)
 60 |               (- 1 (min (abs a) (abs b)))))))
 61 | 
 62 | (defun cf-and (a b)
 63 |   "Combine the certainty factors for the formula (A and B)."
 64 |   (check-type a certainty-factor)
 65 |   (check-type b certainty-factor)
 66 |   (min a b))
 67 | 
 68 | (defun cf-combine (a b)
 69 |   (check-type a certainty-factor)
 70 |   (check-type b certainty-factor)
 71 |   (cond ((and (plusp a)
 72 |               (plusp b))
 73 |          (+ a b (* -1 a b)))
 74 |         ((and (minusp a)
 75 |               (minusp b))
 76 |          (+ a b (* a b)))
 77 |         (t (/ (+ a b)
 78 |               (- 1 (min (abs a) (abs b)))))))
 79 | 
 80 | (defun conjunct-cf (objects)
 81 |   "Combines the certainty factors of objects matched within a single rule."
 82 |   (let ((conjuncts
 83 |          (loop for obj in objects
 84 | 	    for cf = (belief-factor obj)
 85 | 	    if cf collect cf)))
 86 |     (if conjuncts
 87 |         (apply #'min conjuncts)
 88 | 	nil)))
 89 | 
 90 | (defgeneric recalculate-cf (objects rule-cf old-cf)
 91 |   (:method (objects (rule-cf number) (old-cf number))
 92 |     (let* ((combined-cf (conjunct-cf objects))
 93 | 	   (new-cf (if combined-cf (* rule-cf combined-cf) rule-cf)))
 94 |       (cf-combine old-cf new-cf)))
 95 |   (:method (objects (rule-cf number) (old-cf t))
 96 |     (let* ((combined-cf (conjunct-cf objects))
 97 | 	   (new-cf (if combined-cf combined-cf rule-cf))
 98 | 	   (factor (if combined-cf rule-cf +cf-true+)))
 99 |       (* new-cf factor)))
100 |   (:method (objects (rule-cf t) (old-cf t))
101 |     (let* ((combined-cf (conjunct-cf objects)))
102 |       (if combined-cf
103 | 	  (* combined-cf 1.0)
104 | 	  nil))))
105 | 
106 | (defun cf->english (cf)
107 |   (cond ((= cf 1.0) "certain evidence")
108 |         ((> cf 0.8) "strongly suggestive evidence")
109 |         ((> cf 0.5) "suggestive evidence")
110 |         ((> cf 0.0) "weakly suggestive evidence")
111 |         ((= cf 0.0) "no evidence either way")
112 |         ((< cf 0.0) (concatenate 'string (cf->english (- cf))
113 | 				 " against the conclusion"))))
114 | 
115 | ;;; interface into the generic belief system.
116 | 
117 | (defmethod adjust-belief (objects (rule-belief number) &optional
118 |                           (old-belief nil))
119 |   (recalculate-cf objects rule-belief old-belief))
120 | 
121 | (defmethod adjust-belief (objects (rule-belief t) &optional old-belief)
122 |   (declare (ignore objects old-belief))
123 |   nil)
124 | 
125 | (defmethod belief->english ((cf number))
126 |   (cf->english cf))
127 | 
128 | 


--------------------------------------------------------------------------------
/deserialize.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:vivace-graph-v2)
  2 | 
  3 | ;; The foundation of the serialization code comes from Sonja Keene's
  4 | ;; "Object-Oriented  Programming in Common Lisp."  Thanks Sonja!
  5 | 
  6 | (defgeneric deserialize (code stream))
  7 | (defgeneric deserialize-action (code stream))
  8 | 
  9 | (defun deserialize-file (file)
 10 |   (with-open-file (stream file :element-type '(unsigned-byte 8))
 11 |     (do ((code (read-byte stream nil :eof) (read-byte stream nil :eof)))
 12 | 	((eql code :eof))
 13 |       (format t "CODE ~A: ~A~%" code (deserialize code stream)))))
 14 | 
 15 | (defmethod deserialize :around (code stream)
 16 |   (handler-case
 17 |       (call-next-method)
 18 |     (error (condition)
 19 |       (error 'deserialization-error :instance stream :reason condition))))
 20 | 
 21 | (defun deserialize-integer (stream)
 22 |   (let ((int 0) (n-bytes (read-byte stream)))
 23 |     (dotimes (i n-bytes)
 24 |       (setq int (dpb (read-byte stream) (byte 8 (* i 8)) int)))
 25 |     int))
 26 | 
 27 | (defmethod deserialize ((code (eql +negative-integer+)) stream)
 28 |   (- (deserialize-integer stream)))
 29 | 
 30 | (defmethod deserialize ((code (eql +positive-integer+)) stream)
 31 |   (deserialize-integer stream))
 32 | 
 33 | (defmethod deserialize ((code (eql +ratio+)) stream)
 34 |   (let ((numerator (deserialize (read-byte stream) stream))
 35 | 	(denominator (deserialize (read-byte stream) stream)))
 36 |     (/ numerator denominator)))
 37 | 
 38 | (defmethod deserialize ((code (eql +single-float+)) stream)
 39 |   (ieee-floats:decode-float32 (deserialize-integer stream)))
 40 | 
 41 | (defmethod deserialize ((code (eql +double-float+)) stream)
 42 |   (ieee-floats:decode-float64 (deserialize-integer stream)))
 43 | 
 44 | (defmethod deserialize ((code (eql +character+)) stream)
 45 |   (let ((char-code (deserialize-integer stream)))
 46 |     (code-char char-code)))
 47 | 
 48 | (defmethod deserialize ((code (eql +string+)) stream)
 49 |   (let* ((length (deserialize (read-byte stream) stream))
 50 | 	 (array (make-array length :element-type '(unsigned-byte 8))))
 51 |     (dotimes (i length)
 52 |       (setf (aref array i) (read-byte stream)))
 53 |     (babel:octets-to-string array)))
 54 | 
 55 | (defmethod deserialize ((code (eql +compressed-string+)) stream)
 56 |   (let* ((length (deserialize (read-byte stream) stream))
 57 | 	 (array (make-array length :element-type '(unsigned-byte 8))))
 58 |     (dotimes (i length)
 59 |       (setf (aref array i) (read-byte stream)))
 60 |     (babel:octets-to-string (chipz:decompress nil 'chipz:zlib array))))
 61 | 
 62 | (defmethod deserialize ((code (eql +t+)) stream)
 63 |   t)
 64 | 
 65 | (defmethod deserialize ((code (eql +null+)) stream)
 66 |   nil)
 67 | 
 68 | (defmethod deserialize ((code (eql +symbol+)) stream)
 69 |   (let ((code (read-byte stream)))
 70 |     (when (and (/= +string+ code) (/= +compressed-string+ code))
 71 |       (error 'deserialization-error :instance code :reason
 72 | 	     "Symbol-name is not a string!"))
 73 |     (let ((symbol-name (deserialize code stream)))
 74 |       (setq code (read-byte stream))
 75 |       (when (and (/= +string+ code) (/= +compressed-string+ code))
 76 | 	(error 'deserialization-error :instance code :reason
 77 | 	       "Symbol-package is not a string!"))
 78 |       (let* ((pkg-name (deserialize code stream))
 79 | 	     (pkg (find-package pkg-name)))
 80 | 	(when (null pkg)
 81 | 	  (error 'deserialization-error :instance code :reason
 82 | 		 (format nil "Symbol-package ~A does not exist!" pkg-name)))
 83 | 	(intern symbol-name pkg)))))
 84 | 
 85 | (defun deserialize-sequence (stream type)
 86 |   (let* ((length (deserialize (read-byte stream) stream))
 87 | 	 (seq (make-sequence type length)))
 88 |     (dotimes (i length)
 89 |       (setf (elt seq i) (deserialize (read-byte stream) stream)))
 90 |     seq))
 91 | 
 92 | (defmethod deserialize ((code (eql +list+)) stream)
 93 |   (deserialize-sequence stream 'list))
 94 | 
 95 | (defmethod deserialize ((code (eql +vector+)) stream)
 96 |   (deserialize-sequence stream 'vector))
 97 | 
 98 | (defmethod deserialize ((code (eql +uuid+)) stream)
 99 |   (let ((array (make-array 16 :element-type '(unsigned-byte 8))))
100 |     (dotimes (i 16)
101 |       (let ((byte (read-byte stream)))
102 | 	(cond ((= i 4)  (setf (aref array 5) byte))
103 | 	      ((= i 5)  (setf (aref array 4) byte))
104 | 	      ((= i 6)  (setf (aref array 7) byte))
105 | 	      ((= i 7)  (setf (aref array 6) byte))
106 | 	      ((= i 10) (setf (aref array 15) byte))
107 | 	      ((= i 11) (setf (aref array 14) byte))
108 | 	      ((= i 12) (setf (aref array 13) byte))
109 | 	      ((= i 13) (setf (aref array 12) byte))
110 | 	      ((= i 14) (setf (aref array 11) byte))
111 | 	      ((= i 15) (setf (aref array 10) byte))
112 | 	      (t        (setf (aref array i) byte)))))
113 |     (uuid:byte-array-to-uuid array)))
114 | 
115 | (defun deserialize-triple-slot (stream)
116 |   (let* ((type-byte (read-byte stream))
117 | 	 (value (deserialize type-byte stream)))
118 |     (if (or (eq type-byte +string+) (eq type-byte +compressed-string+))
119 | 	(intern value :graph-words)
120 | 	value)))
121 | 
122 | (defmethod deserialize ((code (eql +triple+)) (stream stream))
123 |   (let ((subject (deserialize-triple-slot stream))
124 | 	(predicate (deserialize-triple-slot stream))
125 | 	(object (deserialize-triple-slot stream))
126 | 	(graph (deserialize-triple-slot stream))
127 | 	(id (deserialize (read-byte stream) stream))
128 | 	(deleted? (deserialize (read-byte stream) stream))
129 | 	(cf (deserialize (read-byte stream) stream)))
130 |     (%add-triple subject predicate object id graph cf deleted?)))
131 | 
132 | (defmethod deserialize-action ((code (eql +transaction+)) (stream stream))
133 |   (do ((code (read-byte stream nil :eof) (read-byte stream nil :eof)))
134 |       ((or (eql code :eof) (null code)))
135 |     (deserialize-action code stream)))
136 | 
137 | (defmethod deserialize-action ((code (eql +add-triple+)) stream)
138 |   (let ((subject (deserialize-triple-slot stream))
139 | 	(predicate (deserialize-triple-slot stream))
140 | 	(object (deserialize-triple-slot stream))
141 | 	(graph (deserialize-triple-slot stream))
142 | 	(id (deserialize (read-byte stream) stream))
143 | 	(deleted? (deserialize (read-byte stream) stream))
144 | 	(cf (deserialize (read-byte stream) stream)))
145 |     (%add-triple subject predicate object id graph cf deleted?)))
146 | 
147 | (defmethod deserialize-action ((code (eql +delete-triple+)) stream)
148 |   (let ((id (deserialize (read-byte stream) stream))
149 | 	(timestamp (deserialize (read-byte stream) stream)))
150 |     (%delete-triple id timestamp)))
151 | 
152 | (defmethod deserialize-action ((code (eql +undelete-triple+)) stream)
153 |   (let ((id (deserialize (read-byte stream) stream)))
154 |     (%undelete-triple id)))
155 | 
156 | (defmethod deserialize-action ((code (eql +set-cf+)) stream)
157 |   (let ((id (deserialize (read-byte stream) stream))
158 | 	(cf (deserialize (read-byte stream) stream)))
159 |     (%set-triple-cf id cf)))
160 | 


--------------------------------------------------------------------------------
/index.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:vivace-graph-v2)
  2 | 
  3 | (defstruct index-cursor index vector pointer)
  4 | 
  5 | (defgeneric idx-equal (a b)
  6 |   (:method ((a string) (b string)) (string= a b))
  7 |   (:method ((a number) (b number)) (= a b))
  8 |   (:method ((a symbol) (b symbol)) (eq a b))
  9 |   (:method ((a vector) (b vector))
 10 |     (when (= (length a) (length b))
 11 |       (every #'idx-equal a b)))
 12 |   (:method (a b) (equal a b)))
 13 | 
 14 | (defun sxhash-idx (item) (sxhash item))
 15 | 
 16 | (sb-ext:define-hash-table-test idx-equal sxhash-idx)
 17 | 
 18 | ;(defun make-idx-table (&key synchronized)
 19 | ;  (make-hash-table :test 'idx-equal :synchronized synchronized))
 20 | 
 21 | (defun cursor-value (cursor &key (transform-fn #'identity))
 22 |   (handler-case
 23 |       (funcall transform-fn
 24 | 	       (aref (index-cursor-vector cursor)
 25 |                      (index-cursor-pointer cursor)))
 26 |     (sb-int:invalid-array-index-error (condition)
 27 |       (declare (ignore condition))
 28 |       nil)))
 29 | 
 30 | (defun cursor-next (cursor &key (transform-fn #'identity))
 31 |   (handler-case
 32 |       (funcall transform-fn
 33 | 	       (aref (index-cursor-vector cursor)
 34 | 		     (incf (index-cursor-pointer cursor))))
 35 |     (sb-int:invalid-array-index-error (condition)
 36 |       (declare (ignore condition))
 37 |       (decf (index-cursor-pointer cursor))
 38 |       nil)))
 39 | 
 40 | (defun cursor-prev (cursor &key (transform-fn #'identity))
 41 |   (handler-case
 42 |       (funcall transform-fn
 43 | 	       (aref (index-cursor-vector cursor)
 44 | 		     (decf (index-cursor-pointer cursor))))
 45 |     (sb-int:invalid-array-index-error (condition)
 46 |       (declare (ignore condition))
 47 |       (incf (index-cursor-pointer cursor))
 48 |       nil)))
 49 | 
 50 | (defun cursor-close (cursor)
 51 |   (setf (index-cursor-index cursor) nil
 52 | 	(index-cursor-vector cursor) nil
 53 | 	(index-cursor-pointer cursor) nil))
 54 | 
 55 | (defun map-cursor (fn cursor &key collect?)
 56 |   (setf (index-cursor-pointer cursor) 0)
 57 |   (let ((result ()))
 58 |     (loop for i from 0 to (1- (length (index-cursor-vector cursor))) do
 59 | 	 (if collect?
 60 | 	     (push (funcall fn (aref (index-cursor-vector cursor) i)) result)
 61 | 	     (funcall fn (aref (index-cursor-vector cursor) i))))
 62 |     (nreverse result)))
 63 | 
 64 | (defstruct index name table test locks)
 65 | 
 66 | ;;(defun make-hierarchical-index (&key name (test 'idx-equal))
 67 | (defun make-hierarchical-index (&key name (test 'eql))
 68 |   (make-index :name name
 69 | 	      :test test
 70 | 	      :table (make-hash-table :test test :synchronized t)
 71 | 	      :locks (make-hash-table :synchronized t :test 'equal)))
 72 | 
 73 | (defun hash-table-keys (ht)
 74 |   (let ((keys nil))
 75 |     (sb-ext:with-locked-hash-table (ht)
 76 |       (maphash #'(lambda (k v) (declare (ignore v)) (push k keys)) ht))
 77 |     keys))
 78 | 
 79 | (defun fetch-all-leaves (ht)
 80 |   (let ((leaves (make-array 0 :adjustable t :fill-pointer t)))
 81 |     (labels ((fetch-all (ht1)
 82 | 	       (sb-ext:with-locked-hash-table (ht)
 83 | 		 (maphash #'(lambda (k v)
 84 | 			      (declare (ignore k))
 85 | 			      (typecase v
 86 | 				(hash-table (fetch-all v))
 87 | 				(list
 88 | 				 (dolist (leaf v)
 89 | 				   (vector-push-extend leaf leaves)))
 90 | 				(t (vector-push-extend v leaves))))
 91 | 			  ht1))))
 92 |       (fetch-all ht))
 93 |     (if (> (length leaves) 0)
 94 | 	leaves
 95 | 	nil)))
 96 | 
 97 | (defun delete-index-path (index path &key return-values?)
 98 |   (let ((vals nil))
 99 |     (labels ((descend (ht keys)
100 | 	       (if (eq (first keys) '*)
101 | 		   (sb-ext:with-locked-hash-table (ht)
102 | 		     (maphash #'(lambda (k v)
103 | 				  (declare (ignore k))
104 | 				  (descend v (rest keys))) ht))
105 | 		   (multiple-value-bind (value found?)
106 |                        (gethash (first keys) ht)
107 | 		     (when found?
108 | 		       (if (hash-table-p value)
109 | 			   (if (null (rest keys))
110 | 			       (progn
111 | 				 (when return-values?
112 | 				   (sb-ext:with-locked-hash-table (value)
113 | 				     (maphash #'(lambda (k v)
114 | 						  (declare (ignore k))
115 | 						  (push v vals))
116 | 					      value)))
117 | 				 (remhash (first keys) ht))
118 | 			       (descend value (rest keys)))
119 | 			   (remhash (first keys) ht)))))))
120 |       (descend index path))
121 |     vals))
122 | 
123 | (defun descend-ht (ht keys)
124 |   (assert (not (null keys)) nil "keys must be non-null.")
125 |   (if (eq (first keys) '*)
126 |       (sb-ext:with-locked-hash-table (ht)
127 | 	(maphash #'(lambda (k v)
128 | 		     (declare (ignore k))
129 | 		     (if (hash-table-p v)
130 | 			 (descend-ht v (rest keys))
131 | 			 ()))
132 | 		 ht))
133 |       (multiple-value-bind (value found?) (gethash (first keys) ht)
134 | 	(if found?
135 | 	    (if (hash-table-p value)
136 | 		(if (null (rest keys))
137 | 		    (fetch-all-leaves value)
138 | 		    (descend-ht value (rest keys)))
139 | 		(if (null (rest keys))
140 | 		    (values (make-array 1 :initial-element value) t)))
141 | 	    (values nil nil)))))
142 | 
143 | (defun get-from-index (index &rest keys)
144 |   (let ((result (descend-ht (index-table index) keys)))
145 |     (cond ((null result)
146 | 	   (make-index-cursor :index index :vector #() :pointer 0))
147 | 	  ((vectorp result)
148 | 	   (make-index-cursor :index index :vector result :pointer 0))
149 | 	  (t result))))
150 | 
151 | (defun find-or-create-ht (ht keys create-fn &optional (d 0))
152 |   (assert (not (null keys)) nil "keys must be non-null.")
153 |   (sb-ext:with-locked-hash-table (ht)
154 |     (multiple-value-bind (value found?) (gethash (first keys) ht)
155 |       (unless (and found? (typep value 'hash-table))
156 | 	(setf (gethash (first keys) ht) (funcall create-fn)))))
157 |   (cond ((null (rest keys))
158 | 	 (values ht (first keys)))
159 | 	((= 1 (length (rest keys)))
160 | 	 (values (gethash (first keys) ht) (first (rest keys))))
161 | 	(t
162 | 	 (find-or-create-ht (gethash (first keys) ht)
163 | 			    (rest keys) create-fn (1+ d)))))
164 | 
165 | (defun add-to-index (index value &rest keys)
166 |   (let ((ht (find-or-create-ht (index-table index)
167 | 			       keys
168 | 			       #'(lambda ()
169 | 				   (make-hash-table
170 |                                     :synchronized t
171 |                                     :test (index-test index))))))
172 |     (setf (gethash (car (last keys)) ht) value)))
173 | 
174 | (defun delete-from-index (index value &rest keys)
175 |   ;; FIXME: implement
176 |   (declare (ignore index value keys)))
177 | 
178 | (defun check-index ()
179 |   (maphash #'(lambda (k v) (format t "~A: ~A~%" k (type-of k)))
180 | 	   (gethash :posgi-idx
181 | 		    (vivace-graph-v2::index-table
182 | 		     (main-idx *store*)))))
183 | 
184 | (defun get-table-to-lock (idx &rest keys)
185 |   (find-or-create-ht (index-table idx)
186 | 		     keys
187 | 		     #'(lambda ()
188 | 			 (make-hash-table :synchronized t
189 | 					  :test (index-test idx)))))
190 | 
191 | (defmacro with-locked-index ((idx &rest keys) &body body)
192 |   (if keys
193 |       (with-gensyms (sub-idx last-key)
194 | 	`(multiple-value-bind (,sub-idx ,last-key)
195 | 	     (get-table-to-lock ,idx ,@keys)
196 | 	   (sb-ext:with-locked-hash-table (,sub-idx)
197 | 	     ;;(format t "Locked ht ~A / ~A~%" ,last-key ,sub-idx)
198 | 	     ,@body)))
199 |       `(sb-ext:with-locked-hash-table ((index-table ,idx))
200 | 	 ,@body)))
201 | 
202 | 
203 | (defun test-index ()
204 |   (let ((index (make-hierarchical-index :test 'equal)))
205 |     (add-to-index index "abc" "a" "b" "c")
206 |     (add-to-index index "abd" "a" "b" "d")
207 |     (add-to-index index "abe" "a" "b" "e")
208 |     (add-to-index index "abz" "a" "b" "z")
209 |     (add-to-index index "abx" "a" "b" "x")
210 |     (add-to-index index "aby" "a" "b" "y")
211 |     (add-to-index index "acy" "a" "c" "y")
212 |     (add-to-index index "bcy" "b" "c" "y")
213 |     (get-from-index index "a" "b")))
214 | 


--------------------------------------------------------------------------------
/lock.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:vivace-graph-v2)
  2 | 
  3 | (defun print-rw-lock (lock stream depth)
  4 |   (format stream "#<RW-LOCK, W: ~A, R: ~A>"
  5 |           (lock-writer lock) (lock-readers lock)))
  6 | 
  7 | (defstruct (rw-lock
  8 | 	     (:conc-name lock-)
  9 | 	     (:print-function print-rw-lock)
 10 | 	     (:predicate rw-lock?))
 11 |   (lock (sb-thread:make-mutex) :type sb-thread:mutex)
 12 |   (readers 0 :type integer)
 13 |   (semaphore (sb-thread:make-semaphore) :type sb-thread:semaphore)
 14 |   (writer-queue (make-empty-queue) :type queue)
 15 |   (writer nil)
 16 |   (waitqueue (sb-thread:make-waitqueue) :type sb-thread:waitqueue))
 17 | 
 18 | (defun next-in-queue? (rw-lock thread)
 19 |   (sb-thread:with-recursive-lock ((lock-lock rw-lock))
 20 |     (and (not (empty-queue? (lock-writer-queue rw-lock)))
 21 | 	 (eq thread (queue-front (lock-writer-queue rw-lock))))))
 22 | 
 23 | (defun lock-unused? (rw-lock)
 24 |   (sb-thread:with-recursive-lock ((lock-lock rw-lock))
 25 |     (and (= 0 (lock-readers rw-lock))
 26 | 	 (= 0 (sb-thread:semaphore-count (lock-semaphore rw-lock)))
 27 | 	 (null (lock-writer rw-lock))
 28 | 	 (empty-queue? (lock-writer-queue rw-lock)))))
 29 | 
 30 | (defun release-read-lock (rw-lock)
 31 |   (sb-thread:with-recursive-lock ((lock-lock rw-lock))
 32 |     (assert (not (eql 0 (lock-readers rw-lock))))
 33 |     (when (eql 0 (decf (lock-readers rw-lock)))
 34 |       (when (lock-writer rw-lock)
 35 | 	(sb-thread:signal-semaphore (lock-semaphore rw-lock))))))
 36 | 
 37 | (defun acquire-read-lock (rw-lock &key (max-tries 1000))
 38 |   (loop for tries from 0 to max-tries do
 39 |        (sb-thread:with-recursive-lock ((lock-lock rw-lock))
 40 | 	 (if (lock-writer rw-lock)
 41 | 	     (condition-wait (lock-waitqueue rw-lock) (lock-lock rw-lock))
 42 | 	     (progn
 43 | 	       (incf (lock-readers rw-lock))
 44 | 	       (return-from acquire-read-lock rw-lock))))))
 45 | 
 46 | (defmacro with-read-lock ((rw-lock) &body body)
 47 |   `(unwind-protect
 48 | 	(if (rw-lock? (acquire-read-lock ,rw-lock))
 49 | 	    (progn ,@body)
 50 | 	    (error "Unable to get rw-lock: ~A" ,rw-lock))
 51 |      (release-read-lock ,rw-lock)))
 52 | 
 53 | (defun release-write-lock (rw-lock &key reading-p)
 54 |   (sb-thread:with-recursive-lock ((lock-lock rw-lock))
 55 |     (if (next-in-queue? rw-lock sb-thread:*current-thread*)
 56 | 	(dequeue (lock-writer-queue rw-lock))
 57 | 	(error "Cannot release lock I don't own!"))
 58 |     (if (next-in-queue? rw-lock sb-thread:*current-thread*)
 59 | 	;;(format t "Not releasing lock;  recursive ownership detected!~%")
 60 | 	nil
 61 | 	(progn
 62 | 	  (setf (lock-writer rw-lock) nil)
 63 | 	  (when reading-p
 64 | 	    (incf (lock-readers rw-lock)))
 65 | 	  (sb-thread:condition-broadcast (lock-waitqueue rw-lock))))))
 66 | 
 67 | (defun acquire-write-lock (rw-lock &key (max-tries 1000) reading-p)
 68 |   (sb-thread:with-recursive-lock ((lock-lock rw-lock))
 69 |     (if (and (next-in-queue? rw-lock sb-thread:*current-thread*)
 70 | 	     (eq (lock-writer rw-lock) sb-thread:*current-thread*))
 71 | 	(progn
 72 | 	  (enqueue-front (lock-writer-queue rw-lock)
 73 |                          sb-thread:*current-thread*)
 74 | 	  (return-from acquire-write-lock rw-lock))
 75 | 	(enqueue (lock-writer-queue rw-lock) sb-thread:*current-thread*)))
 76 |   (loop for tries from 0 to max-tries do
 77 |        (if (eq (lock-writer rw-lock) sb-thread:*current-thread*)
 78 | 	   (return-from acquire-write-lock rw-lock)
 79 | 	   (let ((wait-p nil))
 80 | 	     (handler-case
 81 | 		 (sb-thread:with-recursive-lock ((lock-lock rw-lock))
 82 | 		   (if (and (null (lock-writer rw-lock))
 83 | 			    (next-in-queue? rw-lock
 84 |                                             sb-thread:*current-thread*))
 85 | 		       (progn
 86 | 			 (setf (lock-writer rw-lock)
 87 |                                sb-thread:*current-thread*)
 88 | 			 (when reading-p
 89 | 			   (decf (lock-readers rw-lock)))
 90 | 			 (unless (eql 0 (lock-readers rw-lock))
 91 | 			   (setf wait-p t)))
 92 | 		       (sb-thread:condition-wait
 93 | 			(lock-waitqueue rw-lock) (lock-lock rw-lock))))
 94 | 	       (error (c)
 95 | 		 (format t "Got error ~A while acquiring write lock ~A"
 96 |                          c rw-lock)))
 97 | 	     (when wait-p
 98 | 	       (sb-thread:wait-on-semaphore (lock-semaphore rw-lock)))))))
 99 | 
100 | (defmacro with-write-lock ((rw-lock) &body body)
101 |   `(unwind-protect
102 | 	(if (rw-lock? (acquire-write-lock ,rw-lock))
103 | 	    (progn ,@body)
104 | 	    (error "Unable to get rw-lock: ~A" ,rw-lock))
105 |      (release-write-lock ,rw-lock)))
106 | 
107 | (defstruct (lock-pool
108 | 	     (:constructor %make-lock-pool)
109 | 	     (:predicate lock-pool?))
110 |   (lock (make-recursive-lock))
111 |   (queue (sb-concurrency:make-queue))
112 |   (acquired-locks (make-hash-table :synchronized t))
113 |   (size 20))
114 | 
115 | (defun make-lock-pool (size)
116 |   (let ((pool (%make-lock-pool :size size)))
117 |     (dotimes (i size)
118 |       (sb-concurrency:enqueue (make-rw-lock) (lock-pool-queue pool)))
119 |     pool))
120 | 
121 | (defun change-lock-pool-size (pool new-size)
122 |   (cond ((> new-size (lock-pool-size pool))
123 | 	 (sb-thread:with-recursive-lock ((lock-pool-lock pool))
124 | 	   (cas (lock-pool-size pool) (lock-pool-size pool) new-size)
125 | 	   (dotimes (i (- new-size (lock-pool-size pool)))
126 | 	     (sb-concurrency:enqueue (make-rw-lock) (lock-pool-queue pool)))))
127 | 	((< new-size (lock-pool-size pool))
128 | 	 (error "Cannot shrink lock pool size")))
129 |   new-size)
130 | 
131 | (defun release-pool-lock (pool lock)
132 |   (if (remhash lock (lock-pool-acquired-locks pool))
133 |       (sb-concurrency:enqueue lock (lock-pool-queue pool))
134 |       (error "Lock ~A not in acquired-locks list" lock)))
135 | 
136 | (defun get-pool-lock (pool &key (wait-p t) timeout)
137 |   (let ((start-time (gettimeofday)))
138 |     (loop
139 |        (let ((lock (sb-concurrency:dequeue (lock-pool-queue pool))))
140 | 	 (if (rw-lock? lock)
141 | 	     (progn
142 | 	       (setf (gethash lock (lock-pool-acquired-locks pool)) t)
143 | 	       (return-from get-pool-lock lock))
144 | 	     (if wait-p
145 | 		 (if (and timeout (> (gettimeofday) (+ start-time timeout)))
146 | 		     (return-from get-pool-lock nil)
147 | 		     (sleep 0.000000001))
148 | 		 (return-from get-pool-lock nil)))))))
149 | 
150 | #|
151 | (defun test-rw-locks ()
152 |   (let ((lock (make-rw-lock)))
153 |     (make-thread
154 |      #'(lambda () (with-write-lock (lock)
155 | 		    (format t "1 got write lock.  Sleeping.~%")
156 | 		    (sleep 5)
157 | 		    (with-write-lock (lock)
158 | 		      (format t "1 acquired recursive lock.~%")
159 | 		      (sleep 5)
160 | 		      (with-write-lock (lock)
161 | 			(format t "1 acquired recursive lock.~%")
162 | 			(sleep 5)
163 | 			(format t "1 releasing recursive write lock.~%"))
164 | 		      (format t "1 releasing recursive write lock.~%"))
165 | 		    (format t "1 releasing write lock.~%"))))
166 |     (make-thread
167 |      #'(lambda () (with-read-lock (lock) (format t "2 got read lock~%") (sleep 5))))
168 |     (make-thread
169 |      #'(lambda () (with-read-lock (lock) (format t "3 got read lock~%") (sleep 5))))
170 |     (make-thread
171 |      #'(lambda () (with-write-lock (lock)
172 | 		    (format t "4 got write lock.  Sleeping.~%")
173 | 		    (sleep 5)
174 | 		    (with-write-lock (lock)
175 | 		      (format t "4 acquired recursive lock.~%")
176 | 		      (sleep 5)
177 | 		      (with-write-lock (lock)
178 | 			(format t "4 acquired recursive lock.~%")
179 | 			(sleep 5)
180 | 			(format t "4 releasing recursive write lock.~%"))
181 | 		      (format t "4 releasing recursive write lock.~%"))
182 | 		    (format t "4 releasing write lock.~%"))))
183 |     (make-thread
184 |      #'(lambda () (with-write-lock (lock)
185 | 		    (format t "5 got write lock.  Sleeping.~%")
186 | 		    (sleep 5)
187 | 		    (format t "5 releasing write lock.~%"))))
188 |     (make-thread
189 |      #'(lambda () (with-read-lock (lock) (format t "6 got read lock~%") (sleep 5))))
190 |     (make-thread
191 |      #'(lambda () (with-read-lock (lock) (format t "7 got read lock~%") (sleep 5))))))
192 | |#
193 | 


--------------------------------------------------------------------------------
/store.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:vivace-graph-v2)
  2 | 
  3 | (defclass triple-store ()
  4 |   ((name :initarg :name :accessor store-name)))
  5 | 
  6 | (defclass local-triple-store (triple-store)
  7 |   ((main-idx :initarg :main-idx :accessor main-idx)
  8 |    (text-idx :initarg :text-idx :accessor text-idx)
  9 |    (log-mailbox :initarg :log-mailbox :accessor log-mailbox)
 10 |    (index-queue :initarg :index-queue :accessor index-queue)
 11 |    (delete-queue :initarg :delete-queue :accessor delete-queue)
 12 |    (indexed-predicates :initarg :indexed-predicates
 13 |                        :accessor indexed-predicates)
 14 |    (templates :initarg :templates :accessor templates)
 15 |    (location :initarg :location :accessor location)
 16 |    (lock-pool :initarg :lock-pool :accessor lock-pool)
 17 |    (locks :initarg :locks :accessor locks)
 18 |    (logger-thread :initarg :logger-thread :accessor logger-thread)))
 19 | 
 20 | (defclass remote-triple-store (triple-store)
 21 |   ((host :initarg :host :accessor remote-host)
 22 |    (port :initarg :port :accessor remote-port)
 23 |    (user :initarg :user :accessor user)
 24 |    (pass :initarg :pass :accessor pass)))
 25 | 
 26 | (defgeneric triple-store? (thing)
 27 |   (:method ((store triple-store)) t)
 28 |   (:method (thing) nil))
 29 | 
 30 | (defun index-predicate? (name)
 31 |   (gethash name (indexed-predicates *store*)))
 32 | 
 33 | (defun list-indexed-predicates (&optional (store *store*))
 34 |   (let ((result nil))
 35 |     (maphash #'(lambda (k v)
 36 | 		 (when v (push k result)))
 37 | 	     (indexed-predicates store))
 38 |     (sort result #'string>)))
 39 | 
 40 | (defun make-fresh-store (name location &key (num-locks 10000))
 41 |   (let* ((text-dir (merge-pathnames (format nil "~A/text-idx/" location)))
 42 |          (store
 43 |           (make-instance 'local-triple-store
 44 |                          :name name
 45 |                          :location location
 46 |                          :main-idx (make-hierarchical-index)
 47 |                          :lock-pool (make-lock-pool num-locks)
 48 |                          :locks (make-hash-table :synchronized t :test 'equal)
 49 |                          :text-idx (make-instance 'montezuma:index
 50 |                                                   :path text-dir)
 51 |                          :log-mailbox (sb-concurrency:make-mailbox)
 52 |                          :index-queue (sb-concurrency:make-queue)
 53 |                          :delete-queue (sb-concurrency:make-queue)
 54 |                          :templates (make-hash-table :synchronized t
 55 |                                                      :test 'eql)
 56 |                          :indexed-predicates (make-hash-table
 57 |                                               :synchronized t
 58 |                                               :test 'equalp))))
 59 |     (add-to-index (main-idx store) (make-uuid-table :synchronized t) :id-idx)
 60 |     (setf (logger-thread store) (start-logger store))
 61 |     store))
 62 | 
 63 | (defun make-local-triple-store (name location &key (num-locks 10000))
 64 |   (make-fresh-store name location :num-locks num-locks))
 65 | 
 66 | (defun create-triple-store (&key name if-exists? location host port
 67 | 			    user password num-locks)
 68 |   (declare (ignore if-exists?))
 69 |   (setq *graph* (or name location (format nil "~A:~A" host port)))
 70 |   (if location
 71 |       (let ((store (make-local-triple-store
 72 |                     *graph* location :num-locks num-locks)))
 73 | 	(if (triple-store? store)
 74 | 	    (setf (gethash (store-name store) *store-table*) store
 75 | 		  *store* store)
 76 | 	      (error "Unknown error opening triple-store at ~A." location)))
 77 |       (setq *store* (make-instance 'remote-triple-store
 78 | 				   :name *graph*
 79 | 				   :host host
 80 | 				   :port port
 81 | 				   :user user
 82 | 				   :password password))))
 83 | 
 84 | (defun change-store (name)
 85 |   (let ((store (gethash name *store-table*)))
 86 |     (if (triple-store? store)
 87 | 	(setq *store* store)
 88 | 	(error "Unknown triple-store requested: ~A" name))))
 89 | 
 90 | (defun close-triple-store (&key (store *store*))
 91 |   (remhash (store-name store) *store-table*)
 92 |   (if (eql store *store*) (setq *store* nil))
 93 |   (stop-logger store)
 94 |   (montezuma:close (text-idx store))
 95 |   nil)
 96 | 
 97 | (defun open-triple-store (&key name location host port user password num-locks)
 98 |   (let ((store (create-triple-store :name name
 99 | 				    :location location
100 | 				    :if-exists? :open
101 | 				    :host host
102 | 				    :port port
103 | 				    :user user
104 | 				    :port port
105 | 				    :password password
106 |                                     :num-locks num-locks)))
107 |     (restore-triple-store store)
108 |     (setq *store* store)))
109 | 
110 | (defun clear-triple-store (&optional (store *store*))
111 |   (sb-concurrency:send-message (log-mailbox store) :shutdown-and-clear)
112 |   (join-thread (logger-thread store))
113 |   (make-fresh-store *graph* (location store)))
114 | 
115 | (defun use-graph (name)
116 |   (setq *graph* name))
117 | 
118 | (defun add-to-index-queue (thing &optional (store *store*))
119 |   (sb-concurrency:enqueue thing (index-queue store)))
120 | 
121 | (defun add-to-delete-queue (thing &optional (store *store*))
122 |   (sb-concurrency:enqueue thing (delete-queue store)))
123 | 
124 | (defun intern-spog (s p o g)
125 |   (values
126 |    (if (stringp s) (intern s :graph-words) s)
127 |    (if (stringp p) (intern p :graph-words) p)
128 |    (if (stringp o) (intern o :graph-words) o)
129 |    (if (stringp g) (intern g :graph-words) g)))
130 | 
131 | (defun lock-pattern (subject predicate object graph &key (kind :write)
132 | 		     (store *store*))
133 |   (multiple-value-bind (subject predicate object graph)
134 |       (intern-spog subject predicate object graph)
135 |     (let ((lock nil) (pattern (list subject predicate object graph)))
136 |       (logger :debug "~A: Locking pattern ~A~%" *current-transaction* pattern)
137 |       (sb-ext:with-locked-hash-table ((locks store))
138 | 	(setq lock
139 | 	      (or (gethash pattern (locks store))
140 | 		  (setf (gethash pattern (locks store))
141 | 			(get-pool-lock (lock-pool store))))))
142 |       (if (rw-lock? lock)
143 | 	  (if (eq kind :write)
144 | 	      (acquire-write-lock lock)
145 | 	      (acquire-read-lock lock))
146 | 	  (error "Unable to get lock for ~A" pattern)))))
147 | 
148 | (defun lock-triple (triple &key (kind :write) (store *store*))
149 |   (lock-pattern (triple-subject triple)
150 | 		(triple-predicate triple)
151 | 		(triple-object triple)
152 | 		(triple-graph triple)
153 | 		:kind kind
154 | 		:store store))
155 | 
156 | (defun unlock-pattern (subject predicate object graph &key kind
157 |                        (store *store*))
158 |   (multiple-value-bind (subject predicate object graph)
159 |       (intern-spog subject predicate object graph)
160 |     (let ((pattern (list subject predicate object graph)))
161 |       (sb-ext:with-locked-hash-table ((locks store))
162 | 	(let ((lock (gethash pattern (locks store))))
163 | 	  (when (rw-lock? lock)
164 | 	    (sb-thread:with-recursive-lock ((lock-lock lock))
165 | 	      (case kind
166 | 		(:write (release-write-lock lock))
167 | 		(:read  (release-read-lock lock)))
168 | 	      (when (lock-unused? lock)
169 | 		(remhash pattern (locks store))
170 | 		(release-pool-lock (lock-pool store) lock)))))))))
171 | 
172 | (defun unlock-triple (triple &key kind (store *store*))
173 |   (funcall #'unlock-pattern
174 | 	   (triple-subject triple)
175 | 	   (triple-predicate triple)
176 | 	   (triple-object triple)
177 | 	   (triple-graph triple)
178 | 	   :kind kind
179 | 	   :store store))
180 | 
181 | (defmacro with-locked-pattern ((subject predicate object graph kind)
182 |                                &body body)
183 |   (with-gensyms (s p o g k)
184 |     `(let ((,s ,subject) (,p ,predicate) (,o ,object) (,g ,graph) (,k ,kind))
185 |        (unwind-protect
186 | 	    (progn
187 | 	      (lock-pattern ,s ,p ,o ,g :kind ,k :store *store*)
188 | 	      ,@body)
189 |        (unlock-pattern ,s ,p ,o ,g :kind ,k :store *store*)))))
190 | 
191 | 


--------------------------------------------------------------------------------
/serialize.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:vivace-graph-v2)
  2 | 
  3 | ;; The foundation of the serialization code comes from Sonja Keene's
  4 | ;; "Object-Oriented Programming in Common Lisp."  Thanks Sonja!
  5 | 
  6 | (defgeneric serialize (thing stream))
  7 | (defgeneric serialize-action (action stream &rest args))
  8 | 
  9 | (defmethod serialize :around (thing stream)
 10 |   (handler-case
 11 |       (call-next-method)
 12 |     (error (condition)
 13 |       (error 'serialization-error :instance thing :reason condition))))
 14 | 
 15 | (defun serialize-integer (int stream)
 16 |   (let ((n-bytes (ceiling (integer-length int) 8)))
 17 |     (write-byte n-bytes stream)
 18 |     (dotimes (i n-bytes)
 19 |       (write-byte (ldb (byte 8 0) int) stream)
 20 |       (setq int (ash int -8)))))
 21 | 
 22 | (defmethod serialize ((int integer) (stream stream))
 23 |   "Encodes integers between
 24 | (- (1- (expt 2 (* 8 255))))
 25 |  and
 26 | (1- (expt 2 (* 8 255)))"
 27 |   (if (minusp int)
 28 |       (progn
 29 | 	(write-byte +negative-integer+ stream)
 30 | 	(setq int (abs int)))
 31 |       (write-byte +positive-integer+ stream))
 32 |   (serialize-integer int stream))
 33 | 
 34 | (defmethod serialize ((ratio ratio) (stream stream))
 35 |   (let* ((numerator (numerator ratio)) (denominator (denominator ratio)))
 36 |     (write-byte +ratio+ stream)
 37 |     (serialize numerator stream)
 38 |     (serialize denominator stream)))
 39 | 
 40 | (defmethod serialize ((float single-float) (stream stream))
 41 |   (write-byte +single-float+ stream)
 42 |   (serialize-integer (ieee-floats:encode-float32 float) stream))
 43 | 
 44 | (defmethod serialize ((float double-float) (stream stream))
 45 |   (write-byte +single-float+ stream)
 46 |   (serialize-integer (ieee-floats:encode-float64 float) stream))
 47 | 
 48 | (defmethod serialize ((char character) (stream stream))
 49 |   (write-byte +character+ stream)
 50 |   (serialize-integer (char-code char) stream))
 51 | 
 52 | (defmethod serialize ((string string) (stream stream))
 53 |   ;; FIXME: what is the right length to enable compression?
 54 |   (if (and *compression-enabled?* (> (length string) 20))
 55 |       (let* ((comp (salza2:compress-data
 56 | 		    (babel:string-to-octets string) 'salza2:zlib-compressor))
 57 | 	     (length (length comp)))
 58 | 	(write-byte +compressed-string+ stream)
 59 | 	(serialize length stream)
 60 | 	(dotimes (i length)
 61 | 	  (write-byte (aref comp i) stream)))
 62 |       (let* ((unicode (babel:string-to-octets string))
 63 | 	     (length (length unicode)))
 64 | 	(write-byte +string+ stream)
 65 | 	(serialize length stream)
 66 | 	(dotimes (i length)
 67 | 	  (write-byte (aref unicode i) stream)))))
 68 | 
 69 | (defmethod serialize ((symbol symbol) (stream stream))
 70 |   (cond ((null symbol)
 71 | 	 (write-byte +null+ stream))
 72 |         ((eq symbol t)
 73 | 	 (write-byte +t+ stream))
 74 |         (t
 75 | 	 (write-byte +symbol+ stream)
 76 | 	 (serialize (symbol-name symbol) stream)
 77 | 	 (serialize (package-name (symbol-package symbol)) stream))))
 78 | 
 79 | (defmethod serialize ((uuid uuid:uuid) (stream stream))
 80 |   (write-byte +uuid+ stream)
 81 |   (uuid:serialize-uuid uuid stream))
 82 | 
 83 | (defun serialize-sequence (seq stream code)
 84 |   (let ((length (length seq)))
 85 |     (write-byte code stream)
 86 |     (serialize length stream)
 87 |     (dotimes (i length)
 88 |       (serialize (elt seq i) stream))))
 89 | 
 90 | (defmethod serialize ((list list) (stream stream))
 91 |   (serialize-sequence list stream +list+))
 92 | 
 93 | (defmethod serialize ((vector vector) (stream stream))
 94 |   (serialize-sequence vector stream +vector+))
 95 | 
 96 | (defun serialize-triple-help (triple stream)
 97 |   (let ((graph-pkg (find-package 'graph-words)))
 98 |     (if (and (symbolp (subject triple))
 99 | 	     (eq (symbol-package (subject triple)) graph-pkg))
100 | 	(serialize (symbol-name (subject triple)) stream)
101 | 	(serialize (subject triple) stream))
102 |     (if (and (symbolp (predicate triple))
103 | 	     (eq (symbol-package (predicate triple)) graph-pkg))
104 | 	(serialize (symbol-name (predicate triple)) stream)
105 | 	(serialize (predicate triple) stream))
106 |     (if (and (symbolp (object triple))
107 | 	     (eq (symbol-package (object triple)) graph-pkg))
108 | 	(serialize (symbol-name (object triple)) stream)
109 | 	(serialize (object triple) stream))
110 |     (if (and (symbolp (graph triple))
111 | 	     (eq (symbol-package (graph triple)) graph-pkg))
112 | 	(serialize (symbol-name (graph triple)) stream)
113 | 	(serialize (graph triple) stream))
114 |     (serialize (id triple) stream)
115 |     (serialize (deleted? triple) stream)
116 |     (serialize (cf triple) stream)))
117 | 
118 | (defmethod serialize ((triple triple) (stream stream))
119 |   (write-byte +triple+ stream)
120 |   (serialize-triple-help triple stream))
121 | 
122 | (defmethod serialize-action ((action (eql :add-triple)) stream &rest args)
123 |   (logger :debug "Serialize-action ~A: ~A~%" action args)
124 |   (write-byte +add-triple+ stream)
125 |   (if (triple? (first args))
126 |       ;; We generally want to avoid this, as the triple could change between
127 |       ;; requested serialization and actual serialization.
128 |       (serialize-triple-help (first args) stream)
129 |       (let ((subject (nth 0 args))
130 |             (predicate (nth 1 args))
131 |             (object (nth 2 args))
132 | 	    (graph (nth 3 args)) (graph-pkg (find-package 'graph-words)))
133 | 	(if (and (symbolp subject) (eq (symbol-package subject) graph-pkg))
134 | 	    (serialize (symbol-name subject) stream)
135 | 	    (serialize subject stream))
136 | 	(if (and (symbolp predicate)
137 |                  (eq (symbol-package predicate) graph-pkg))
138 | 	    (serialize (symbol-name predicate) stream)
139 | 	    (serialize predicate stream))
140 | 	(if (and (symbolp object) (eq (symbol-package object) graph-pkg))
141 | 	    (serialize (symbol-name object) stream)
142 | 	    (serialize object stream))
143 | 	(if (and (symbolp graph) (eq (symbol-package graph) graph-pkg))
144 | 	    (serialize (symbol-name graph) stream)
145 | 	    (serialize graph stream))
146 | 	(serialize (nth 4 args) stream)	    ;; id
147 | 	(serialize (nth 5 args) stream)	    ;; deleted?
148 | 	(serialize (nth 6 args) stream)))) ;; cf
149 | 
150 | (defmethod serialize-action ((action (eql :delete-triple)) stream &rest args)
151 |   (write-byte +delete-triple+ stream)
152 |   (serialize (nth 0 args) stream)  ;; id
153 |   (serialize (nth 1 args) stream)) ;; timestamp
154 | 
155 | (defmethod serialize-action ((action (eql :undelete-triple)) stream &rest
156 |                              args)
157 |   (write-byte +undelete-triple+ stream)
158 |   (serialize (nth 0 args) stream)) ;; id
159 | 
160 | (defmethod serialize-action ((action (eql :set-cf)) stream &rest args)
161 |   (write-byte +set-cf+ stream)
162 |   (serialize (nth 0 args) stream)  ;; id
163 |   (serialize (nth 1 args) stream)) ;; cf
164 | 
165 | (defmethod serialize-action ((action (eql :transaction)) stream &rest args)
166 |   (write-byte +transaction+ stream)
167 |   (let ((tx (nth 0 args)))
168 |     ;;(serialize (length (tx-queue tx)) stream)
169 |     (dolist (a (reverse (tx-queue tx)))
170 |       (logger :debug "TX: serializing ~A / ~A~%" (first a) (rest a))
171 |       (apply #'serialize-action
172 | 	     (nconc (list (first a) stream) (rest a))))))
173 | 
174 | (defun test-serializer (file)
175 |   (with-open-file (stream file
176 | 			  :direction :output
177 | 			  :element-type '(unsigned-byte 8)
178 | 			  :if-exists :overwrite
179 | 			  :if-does-not-exist :create)
180 |     (let ((uuid (make-uuid))
181 | 	  (vec (make-array 5)))
182 |       (setf (aref vec 0) 1)
183 |       (setf (aref vec 1) #\a)
184 |       (setf (aref vec 2) "string")
185 |       (setf (aref vec 3) 'symbol)
186 |       (setf (aref vec 4) uuid)
187 |       (format t "UUID IS ~A~%" uuid)
188 |       (serialize 123 stream)
189 |       (serialize 123.123 stream)
190 |       (serialize 123/555 stream)
191 |       (serialize #\a stream)
192 |       (serialize "string" stream)
193 |       (serialize 'symbol stream)
194 |       (serialize uuid stream)
195 |       (serialize (list 1 #\a "string" 'symbol uuid) stream)
196 |       (serialize vec stream)))
197 |   (deserialize-file file))
198 | 


--------------------------------------------------------------------------------
/contrib/kraison/rules.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:vivace-graph)
  2 | 
  3 | (defconstant +wildcard+ '*)
  4 | (defparameter *conclusion-operators* '(assert trigger))
  5 | 
  6 | (defun print-rule (rule stream depth)
  7 |   (declare (ignore depth))
  8 |   (format stream "(rule ~A~%  if~%~{    ~a~^~%~}~%  then ~A~%~{    ~a~^~%~})" 
  9 | 	  (rule-name rule) (rule-premises rule) (rule-cf rule) (rule-conclusions rule)))
 10 | 
 11 | (defstruct (rule (:print-function print-rule)
 12 | 		 (:predicate rule?))
 13 |   name premises conclusions cf (lock (make-recursive-lock)) fn)
 14 | 
 15 | (defstruct (rule-execution (:predicate rule-execution?)
 16 | 			   (:conc-name re-))
 17 |   rule substitution-list triple timestamp)
 18 | 
 19 | (defgeneric compile-rule (rule))
 20 | (defgeneric index-rule (rule))
 21 | (defgeneric deindex-rule (rule))
 22 | (defgeneric match-rules (triple))
 23 | 
 24 | (defun check-conditions (rule-name conditions kind)
 25 |   "Warn if any conditions are invalid."
 26 |   (when (null conditions)
 27 |     (error "Rule ~A: Missing ~A" rule-name kind))
 28 |   (dolist (condition conditions)
 29 |     (when (not (consp condition))
 30 |       (error "Rule ~A: Illegal ~A: ~A" rule-name kind condition))
 31 |     (when (not (symbolp (first condition)))
 32 |       ;; FIXME: this needs to walk the tree and check all cars
 33 |       (error "Rule ~A: Illegal functor ~A in ~A ~A" rule-name (first condition) kind condition))
 34 |     (let ((op (first condition)))
 35 |       (when (and (eq kind 'conclusion) (not (member op *conclusion-operators*)))
 36 | 	(error "Rule ~A: Illegal operator (~A) in conclusion: ~A" rule-name op condition)))))
 37 | 
 38 | (defmethod deserialize-help ((become (eql +rule+)) bytes)
 39 |   "Decode a rule."
 40 |   (declare (optimize (speed 3)))
 41 |   (destructuring-bind (name premises conclusions cf) (extract-all-subseqs bytes)
 42 |     (let ((rule (make-rule :name (deserialize name)
 43 | 			   :premises (deserialize premises)
 44 | 			   :conclusions (deserialize conclusions)
 45 | 			   :cf (deserialize cf))))
 46 |       (cache-rule rule))))
 47 | 
 48 | (defmethod serialize ((rule rule))
 49 |   "Encode a rule for storage."
 50 |   (serialize-multiple +rule+ 
 51 | 		      (rule-name rule)
 52 | 		      (rule-premises rule)
 53 | 		      (rule-conclusions rule)
 54 | 		      (rule-cf rule)))
 55 | 
 56 | (defun make-rule-key-from-name (name)
 57 |   (serialize-multiple +rule-key+ (princ-to-string name)))
 58 | 
 59 | (defmethod make-serialized-key ((rule rule))
 60 |   (make-rule-key-from-name (rule-name rule)))
 61 | 
 62 | (defun make-premise-idx (p)
 63 |   (mapcar #'(lambda (i) (if (variable-p i) +wildcard+ i)) p))
 64 | 
 65 | (defun map-premises (fn p)
 66 |   (cond ((atom p) nil)
 67 | 	((and (consp p) (every #'atom p))
 68 | 	 ;;(format t "Applying ~A to rule premise: ~A~%" fn p)
 69 | 	 (funcall fn p))
 70 | 	((and (consp p) (every #'consp p))
 71 | 	 (dolist (p1 p) (map-premises fn p1)))
 72 | 	((and (atom (first p)) (every #'consp (rest p)))
 73 | 	 (dolist (p1 (rest p)) (map-premises fn p1)))))
 74 | 
 75 | (defun count-premises (p)
 76 |   (let ((count 0))
 77 |     (map-premises #'(lambda (p1) (declare (ignore p1)) (incf count)) p)
 78 |     count))
 79 | 
 80 | (defmethod index-rule ((rule rule))
 81 |   (map-premises #'(lambda (p) 
 82 | 		    (pushnew rule (gethash (make-premise-idx p) (rule-idx *graph*))))
 83 | 		(copy-tree (rule-premises rule))))
 84 | 
 85 | (defmethod deindex-rule ((rule rule))
 86 |   (map-premises #'(lambda (p) 
 87 | 		    (setf (gethash (make-premise-idx p) (rule-idx *graph*))
 88 | 			  (remove rule (gethash (make-premise-idx p) (rule-idx *graph*)))))
 89 | 		(copy-tree (rule-premises rule))))
 90 | 
 91 | (defmethod compile-rule ((rule rule))
 92 |   rule)
 93 | 
 94 | (defmethod do-rule-substitution ((rule rule) (wme triple))
 95 |   (let ((result nil) (count 0))
 96 |     (map-premises #'(lambda (p)
 97 | 		      (when (or (prolog-equal (nth 0 p) (predicate wme))
 98 | 				(prolog-equal (nth 1 p) (subject wme))
 99 | 				(prolog-equal (nth 2 p) (object wme)))
100 | 			(let ((r nil))
101 | 			  (if (variable-p (nth 0 p))
102 | 			      (push `(= ,(nth 0 p) ,(predicate wme)) r))
103 | 			  (if (variable-p (nth 1 p)) 
104 | 			      (push `(= ,(nth 1 p) ,(subject wme)) r))
105 | 			  (if (variable-p (nth 2 p)) 
106 | 			      (push `(= ,(nth 2 p) ,(object wme)) r))
107 | 			  (if r (pushnew r result :test 'equal)))))
108 | 		  (copy-tree (rule-premises rule)))
109 |     (mapcar #'(lambda (r)
110 | 		(incf count)
111 | 		(make-rule-execution 
112 | 		 :rule rule 
113 | 		 :substitution-list r 
114 | 		 :triple wme 
115 | 		 :timestamp (triple-timestamp wme)))
116 | 	    result)))
117 | 
118 | (defmethod match-rules ((wme triple))
119 |   (let ((r nil))
120 |     (setq r (nconc r (gethash (list (predicate wme) (subject wme) (object wme)) (rule-idx *graph*)))
121 | 	  r (nconc r (gethash (list (predicate wme) (subject wme) +wildcard+) (rule-idx *graph*)))
122 | 	  r (nconc r (gethash (list (predicate wme) +wildcard+ (object wme)) (rule-idx *graph*)))
123 | 	  r (nconc r (gethash (list (predicate wme) +wildcard+ +wildcard+) (rule-idx *graph*)))
124 | 	  r (nconc r (gethash (list +wildcard+ (subject wme) (object wme)) (rule-idx *graph*)))
125 | 	  r (nconc r (gethash (list +wildcard+ (subject wme) +wildcard+) (rule-idx *graph*)))
126 | 	  r (nconc r (gethash (list +wildcard+ +wildcard+ (object wme)) (rule-idx *graph*)))
127 | 	  r (nconc r (gethash (list +wildcard+ +wildcard+ +wildcard+) (rule-idx *graph*))))
128 |     (mapcar #'(lambda (rule)
129 | 		(do-rule-substitution rule wme))
130 | 	    (sort (remove-duplicates r) #'> 
131 | 		  :key #'(lambda (r) (count-premises (rule-premises r)))))))
132 | 
133 | (defmethod run-rules ((graph graph))
134 |   (let ((*graph* graph))
135 |     (let ((triggered-rules (make-hash-table)))
136 |       (loop 
137 | 	 for triple = (second (delete-min (production-pq *graph*)))
138 | 	 while (triple? triple) do
139 | 	   (format t "Matching triple ~A~%" triple)
140 | 	   (dolist (l (match-rules triple))
141 | 	     (dolist (e l)
142 | 	       (format t "Got execution plan ~A~%" e)
143 | 	       (if (not (member (re-triple e) 
144 | 				(gethash (rule-name (re-rule e)) triggered-rules)
145 | 				:test 'triple-eql))
146 | 		   (progn
147 | 		     ;; FIXME: execute and add if execution is successful.
148 | 		     ;; FIXME: if bindings for triple are different, allow it to exec again?
149 | 		     (push (re-triple e) (gethash (rule-name (re-rule e)) triggered-rules))
150 | 		     (format t "Got rule execution ~A~%" (rule-name (re-rule e)))))))))))
151 | 
152 | (defmethod save-rule ((rule rule))
153 |   (store-object (rule-db *graph*) (make-serialized-key rule) (serialize rule))
154 |   (index-rule rule)
155 |   (cache-rule rule))
156 | 
157 | (defmethod cache-rule ((rule rule))
158 |   (setf (gethash (rule-name rule) (rule-cache *graph*)) rule))
159 | 
160 | (defun get-rule (name)
161 |   (or (gethash (cond ((or (symbolp name) (numberp name)) name)
162 | 		     ((stringp name)
163 | 		      (if (cl-ppcre:scan "^[0-9]+\.*[0-9]*$" name)
164 | 			  (parse-number:parse-number name)
165 | 			  (intern (string-upcase name))))
166 | 		     (t (error "Unknown type for rule name ~A: ~A" name (type-of name))))
167 | 	       (rule-cache *graph*))
168 |       (let ((raw-rule (lookup-object (rule-db *graph*) (make-rule-key-from-name name))))
169 | 	(if (vectorp raw-rule)
170 | 	    (cache-rule (deserialize raw-rule))
171 | 	    nil))))
172 | 
173 | (defun retract-rule (name)
174 |   (let ((rule (get-rule name)))
175 |     (if (rule? rule)
176 | 	(sb-ext:with-locked-hash-table ((rule-cache *graph*))
177 | 	  ;; FIXME: delete all facts derived by this rule!
178 | 	  (remhash (rule-name rule) (rule-cache *graph*))
179 | 	  (deindex-rule rule)
180 | 	  (delete-object (rule-db *graph*) (make-serialized-key rule)))
181 | 	(warn "Rule ~A is undefined, cannot retract it." name))))
182 | 
183 | (defmacro defrule (name &body body)
184 |   (assert (eq (first body) 'if))
185 |   (let* ((name (or (and (symbolp name) (intern (string-upcase (symbol-name name))))
186 | 		   (and (stringp name) (intern (string-upcase name)))
187 | 		   (and (numberp name) name)
188 | 		   (error "Rule name must be a string, symbol or integer, not ~A" (type-of name))))
189 | 	 (then-part (member 'then body))
190 | 	 (premises (ldiff (rest body) then-part))
191 | 	 (conclusions (rest then-part)))
192 |     (if (rule? (get-rule name)) (error "A rule named ~A already exists." name))
193 |     (check-conditions name premises 'premise)
194 |     (check-conditions name conclusions 'conclusion)
195 |     (let ((rule (make-rule :name name :cf +cf-true+ :premises premises :conclusions conclusions)))
196 |       (with-transaction ((rule-db *graph*))
197 | 	(save-rule rule))
198 |       (compile-rule rule))))
199 | 
200 | (defmacro def-fuzzy-rule (name &body body)
201 |   (assert (eq (first body) 'if))
202 |   (let* ((name (or (and (symbolp name) (intern (string-upcase (symbol-name name))))
203 | 		   (and (stringp name) (intern (string-upcase name)))
204 | 		   (and (numberp name) name)
205 | 		   (error "Rule name must be a string, symbol or integer, not ~A" (type-of name))))
206 | 	 (then-part (member 'then body))
207 | 	 (premises (ldiff (rest body) then-part))
208 | 	 (conclusions (rest2 then-part))
209 | 	 (cf (second then-part)))
210 |     (if (rule? (get-rule name)) (error "A rule named ~A already exists." name))
211 |     (check-conditions name premises 'premise)
212 |     (check-conditions name conclusions 'conclusion)
213 |     (when (not (certainty-factor-p cf))
214 |       (error "Rule ~A: Illegal certainty factor: ~A" name cf))
215 |     (let ((rule (make-rule :name name :cf +cf-true+ :premises premises :conclusions conclusions)))
216 |       (with-transaction ((rule-db *graph*))
217 | 	(save-rule rule))
218 |       (compile-rule rule))))
219 | 
220 | (defmethod load-all-rules ((graph graph))
221 |   (map-hash-objects (rule-db graph)
222 | 		    #'(lambda (key val)
223 | 			(declare (ignore key))
224 | 			(let ((rule (deserialize val)))
225 | 			  (when (rule? rule)
226 | 			    (cache-rule rule))))))
227 | 
228 | 


--------------------------------------------------------------------------------
/utilities.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:vivace-graph-v2)
  2 | 
  3 | #+sbcl
  4 | (defun quit () (sb-ext:quit))
  5 | 
  6 | (defmacro logger (level msg &rest args)
  7 |   "Syslogger"
  8 |   `(funcall #'sb-posix:syslog (gethash ',level *syslog-priorities*) ,msg ,@args))
  9 | 
 10 | (defun ip-to-string (ip)
 11 |   (format nil "~A.~A.~A.~A" (aref ip 0) (aref ip 1) (aref ip 2) (aref ip 3)))
 12 | 
 13 | (defgeneric less-than (x y)
 14 |   (:documentation "Generic less-than operator.  Allows comparison of apples and oranges.")
 15 |   (:method ((x symbol)    (y symbol))    (string< (symbol-name x) (symbol-name y)))
 16 |   (:method ((x symbol)    (y string))    (string< (symbol-name x) y))
 17 |   (:method ((x symbol)    (y number))    (string< (symbol-name x) (write-to-string y)))
 18 |   (:method ((x symbol)    (y uuid:uuid)) (string< (symbol-name x)
 19 | 						  (uuid:print-bytes nil y)))
 20 |   (:method ((x number)    (y number))    (< x y))
 21 |   (:method ((x number)    (y symbol))    (string< (write-to-string x) (symbol-name y)))
 22 |   (:method ((x number)    (y string))    (string< (write-to-string x) y))
 23 |   (:method ((x number)    (y uuid:uuid)) (string< (write-to-string x)
 24 | 						  (uuid:print-bytes nil y)))
 25 |   (:method ((x string)    (y string))    (string< x y))
 26 |   (:method ((x string)    (y symbol))    (string< x (symbol-name y)))
 27 |   (:method ((x string)    (y number))    (string< x (write-to-string y)))
 28 |   (:method ((x string)    (y uuid:uuid)) (string< x (uuid:print-bytes nil y)))
 29 |   (:method ((x timestamp) (y timestamp)) (timestamp< x y))
 30 |   (:method ((x number)    (y timestamp)) (< (timestamp-to-universal x) y))
 31 |   (:method ((x timestamp) (y number))    (< x (timestamp-to-universal y)))
 32 |   (:method ((x uuid:uuid) (y uuid:uuid))
 33 |     (string< (uuid:print-bytes nil x) (uuid:print-bytes nil y)))
 34 |   (:method ((x uuid:uuid) (y string)) (string< (uuid:print-bytes nil x) y))
 35 |   (:method ((x uuid:uuid) (y symbol)) (string< (uuid:print-bytes nil x)
 36 | 					       (symbol-name y)))
 37 |   (:method ((x uuid:uuid) (y number)) (string< (uuid:print-bytes nil x)
 38 | 					       (write-to-string y))))
 39 | 
 40 | (defgeneric greater-than (x y)
 41 |   (:documentation "Generic greater-than operator.  Allows comparison of apples and oranges.")
 42 |   (:method ((x symbol) (y symbol))    (string> (symbol-name x) (symbol-name y)))
 43 |   (:method ((x symbol) (y string))    (string> (symbol-name x) y))
 44 |   (:method ((x symbol) (y number))    (string> (symbol-name x) (write-to-string y)))
 45 |   (:method ((x symbol) (y uuid:uuid)) (string> (symbol-name x)
 46 | 					       (uuid:print-bytes nil y)))
 47 |   (:method ((x number) (y number))    (> x y))
 48 |   (:method ((x number) (y symbol))    (string> (write-to-string x) (symbol-name y)))
 49 |   (:method ((x number) (y string))    (string> (write-to-string x) y))
 50 |   (:method ((x number) (y uuid:uuid)) (string> (write-to-string x)
 51 | 					       (uuid:print-bytes nil y)))
 52 |   (:method ((x string) (y string))    (string> x y))
 53 |   (:method ((x string) (y symbol))    (string> x (symbol-name y)))
 54 |   (:method ((x string) (y number))    (string> x (write-to-string y)))
 55 |   (:method ((x string) (y uuid:uuid)) (string> x (uuid:print-bytes nil y)))
 56 |   (:method ((x timestamp) (y timestamp)) (timestamp> x y))
 57 |   (:method ((x number)    (y timestamp)) (> (timestamp-to-universal x) y))
 58 |   (:method ((x timestamp) (y number))    (> x (timestamp-to-universal y)))
 59 |   (:method ((x uuid:uuid) (y uuid:uuid))
 60 |     (string> (uuid:print-bytes nil x) (uuid:print-bytes nil y)))
 61 |   (:method ((x uuid:uuid) (y string)) (string> (uuid:print-bytes nil x) y))
 62 |   (:method ((x uuid:uuid) (y symbol)) (string> (uuid:print-bytes nil x)
 63 | 					       (symbol-name y)))
 64 |   (:method ((x uuid:uuid) (y number)) (string> (uuid:print-bytes nil x)
 65 | 					       (write-to-string y))))
 66 | 
 67 | (defun uri? (string)
 68 |   (cl-ppcre:scan "^(https?|ftp)\:\/\/[a-zA-Z0-9\-\.]+\.[a-zA-Z]{2,3}(\/.*)?$" string))
 69 | 
 70 | (defun make-slot-key (id slot)
 71 |   (format nil "~A~A~A" id #\Nul slot))
 72 | 
 73 | ;; Make compare-and-swap shorter to call
 74 | (defmacro cas (place old new)
 75 |   `(sb-ext:compare-and-swap ,place ,old ,new))
 76 | 
 77 | ;; String split without regexes.
 78 | (defun split (string &optional (ws '(#\Space #\Tab)) max)
 79 |   "Split STRING along whitespace as defined by the sequence WS.
 80 | Whitespace which causes a split is elided from the result.  The whole
 81 | string will be split, unless MAX is provided, in which case the
 82 | string will be split into MAX tokens at most, the last one
 83 | containing the whole rest of the given STRING, if any."
 84 |   (flet ((is-ws (char) (find char ws)))
 85 |     (nreverse
 86 |      (let ((list nil) (start 0) (words 0) end)
 87 |        (loop
 88 |   (when (and max (>= words (1- max)))
 89 |     (return (cons (subseq string start) list)))
 90 |   (setf end (position-if #'is-ws string :start start))
 91 |   (push (subseq string start end) list)
 92 |   (incf words)
 93 |   (unless end (return list))
 94 |   (setf start (1+ end)))))))
 95 | 
 96 | (defun print-hash (ht)
 97 |   "Dump the k-v pairs of a hash table to stdout."
 98 |   (maphash #'(lambda (k v) (format t "~A: ~A~%" k v)) ht))
 99 | 
100 | ;; Plists
101 | (defun get-prop (plist prop)
102 |   "Return the value of a property in a property list."
103 |   (cond ((null plist) nil)
104 | 	((eql (car plist) prop)
105 | 	 (cadr plist))
106 | 	(t (get-prop (cddr plist) prop))))
107 | 
108 | ;; Norvig utilities
109 | (defun rest2 (x)
110 |   "The rest of a list after the first TWO elements."
111 |   (rest (rest x)))
112 | 
113 | (defun continue-p ()
114 |   "Ask user if we should continue looking for solutions."
115 |   (case (read-char)
116 |     (#\; t)
117 |     (#\. nil)
118 |     (#\newline (continue-p))
119 |     (otherwise
120 |       (format t " Type ; to see more or . to stop")
121 |       (continue-p))))
122 | 
123 | (defun length=1 (list)
124 |   "Is this a list of exactly one element?"
125 |   (and (consp list) (null (cdr list))))
126 | 
127 | (defun proper-listp (x)
128 |   "Is x a proper (non-dotted) list?"
129 |   (or (null x)
130 |       (and (consp x) (proper-listp (rest x)))))
131 | 
132 | (defun new-interned-symbol (&rest args)
133 |   "Concatenate symbols or strings to form an interned symbol"
134 |   (intern (format nil "~{~a~}" args)))
135 | 
136 | (defun new-symbol (&rest args)
137 |   "Concatenate symbols or strings to form an uninterned symbol"
138 |   (make-symbol (format nil "~{~a~}" args)))
139 | 
140 | (defun find-all (item sequence &rest keyword-args
141 |                  &key (test #'eql) test-not &allow-other-keys)
142 |   "Find all those elements of sequence that match item,
143 |   according to the keywords.  Doesn't alter sequence."
144 |   (if test-not
145 |       (apply #'remove item sequence
146 |              :test-not (complement test-not) keyword-args)
147 |       (apply #'remove item sequence
148 |              :test (complement test) keyword-args)))
149 | 
150 | (defun find-anywhere (item tree)
151 |   "Does item occur anywhere in tree?  If so, return it."
152 |   (cond ((eql item tree) tree)
153 |         ((atom tree) nil)
154 |         ((find-anywhere item (first tree)))
155 |         ((find-anywhere item (rest tree)))))
156 | 
157 | (defun find-if-anywhere (predicate tree)
158 |   "Does predicate apply to any atom in the tree?"
159 |   (if (atom tree)
160 |       (funcall predicate tree)
161 |       (or (find-if-anywhere predicate (first tree))
162 |           (find-if-anywhere predicate (rest tree)))))
163 | 
164 | (defun unique-find-anywhere-if (predicate tree &optional found-so-far)
165 |   "return a list of leaves of tree satisfying predicate, with duplicates removed."
166 |   (if (atom tree)
167 |       (if (funcall predicate tree)
168 | 	  (adjoin tree found-so-far)
169 | 	  found-so-far)
170 |       (unique-find-anywhere-if
171 |        predicate
172 |        (first tree)
173 |        (unique-find-anywhere-if predicate (rest tree) found-so-far))))
174 | 
175 | (defun reuse-cons (x y x-y)
176 |   "Return (cons x y), or reuse x-y if it is equal to (cons x y)"
177 |   (if (and (eql x (car x-y)) (eql y (cdr x-y)))
178 |       x-y
179 |       (cons x y)))
180 | 
181 | ;; Borrowed from On Lisp by Graham
182 | (defmacro while (test &rest body)
183 |   `(loop until (not ,test) do
184 | 	,@body))
185 | 
186 | (defmacro aif (test-form then-form &optional else-form)
187 |   `(let ((it ,test-form))
188 |      (if it ,then-form ,else-form)))
189 | 
190 | (defmacro aif2 (test &optional then else)
191 |   (let ((win (gensym)))
192 |     `(multiple-value-bind (it ,win) ,test
193 |        (if (or it ,win) ,then ,else))))
194 | 
195 | (define-modify-macro conc1f (obj)
196 |   (lambda (place obj)
197 |     (nconc place (list obj))))
198 | 
199 | (defmacro with-gensyms (syms &body body)
200 |   `(let ,(mapcar #'(lambda (s)
201 |                      `(,s (gensym)))
202 |                  syms)
203 |      ,@body))
204 | 
205 | (defun flatten (x)
206 |   (labels ((rec (x acc)
207 |              (cond ((null x) acc)
208 |                    ((atom x) (cons x acc))
209 |                    (t (rec (car x) (rec (cdr x) acc))))))
210 |     (rec x nil)))
211 | 
212 | (defmacro acond2 (&rest clauses)
213 |   (if (null clauses)
214 |       nil
215 |       (let ((cl1 (car clauses))
216 |             (val (gensym))
217 |             (win (gensym)))
218 |         `(multiple-value-bind (,val ,win) ,(car cl1)
219 |            (if (or ,val ,win)
220 |                (let ((it ,val)) ,@(cdr cl1))
221 |                (acond2 ,@(cdr clauses)))))))
222 | 
223 | ;; The following queueing code was borrowed and adapted from Russell &
224 | ;; Norvig's "Introduction to AI"
225 | (defun print-queue (q stream depth)
226 |   (declare (ignore depth))
227 |   (format stream "<QUEUE: ~a>" (queue-elements q)))
228 | 
229 | (defstruct (queue
230 |              (:print-function print-queue))
231 |   (key #'identity)
232 |   (last nil)
233 |   (elements nil))
234 | 
235 | (defun make-empty-queue () (make-queue))
236 | 
237 | (defun empty-queue? (q)
238 |   (= (length (queue-elements q)) 0))
239 | 
240 | (defun queue-front (q)
241 |   (elt (queue-elements q) 0))
242 | 
243 | (defun dequeue (q)
244 |   (when (listp (queue-elements q))
245 |     (pop (queue-elements q))))
246 | 
247 | (defun enqueue-front (q &rest items)
248 |   (cond ((null items) nil)
249 |         ((or (null (queue-last q)) (null (queue-elements q)))
250 |          (setf (queue-elements q) (nconc items (queue-elements q))
251 | 	       (queue-last q) (last (queue-elements q))))
252 |         (t (setf (queue-elements q) (nconc items (queue-elements q))))))
253 | 
254 | (defun enqueue (q &rest items)
255 |   (cond ((null items) nil)
256 |         ((or (null (queue-last q)) (null (queue-elements q)))
257 |          (setf (queue-last q) (last items)
258 |                (queue-elements q) (nconc (queue-elements q) items)))
259 |         (t (setf (cdr (queue-last q)) items
260 |                  (queue-last q) (last items)))))
261 | 
262 | (defun queue-length (q)
263 |   (length (queue-elements q)))
264 | ;; End of adapted code
265 | 


--------------------------------------------------------------------------------
/transaction.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:vivace-graph-v2)
  2 | 
  3 | (defparameter *current-transaction* nil)
  4 | (defparameter *max-log-file-length* 10000000)
  5 | (defparameter *file-counter* 0)
  6 | 
  7 | (defun print-transaction (tx stream depth)
  8 |   (declare (ignore depth))
  9 |   (format stream "#<TX-~A>" (tx-id tx)))
 10 | 
 11 | (defstruct (transaction
 12 | 	     (:print-function print-transaction)
 13 | 	     (:conc-name tx-)
 14 | 	     (:predicate transaction?))
 15 |   (id (make-uuid))
 16 |   (queue nil)
 17 |   (rollback nil)
 18 |   (mailbox (sb-concurrency:make-mailbox))
 19 |   (thread (current-thread))
 20 |   (store nil)
 21 |   (locks nil))
 22 | 
 23 | (defun find-newest-snapshot (store)
 24 |   (let ((snap nil)
 25 | 	(location (if (pathnamep (location store))
 26 |                       (namestring (location store))
 27 | 		      (location store))))
 28 |     (dolist (file (directory (make-pathname :directory location
 29 | 					    :name :wild :type :wild)))
 30 |       (when (and (pathname-match-p file "snap-*")
 31 | 		 (or (null snap)
 32 | 		     (> (file-write-date file) (file-write-date snap))))
 33 | 	(setq snap file)))
 34 |     (if snap
 35 | 	(values snap (file-write-date snap))
 36 | 	(values nil nil))))
 37 | 
 38 | (defun find-transactions (store timestamp)
 39 |   (let ((transaction-logs nil)
 40 | 	(location (if (pathnamep (location store))
 41 | 		      (namestring (location store))
 42 | 		      (location store))))
 43 |     (format t "Looking for transactions to restore...~%")
 44 |     (dolist (file (directory (make-pathname :directory location
 45 | 					    :name :wild :type :wild)))
 46 |       (when (and (pathname-match-p file "tx-*")
 47 | 		 (or (null timestamp)
 48 | 		     (and (numberp timestamp)
 49 | 			  (> (file-write-date file) timestamp))))
 50 | 	(format t "Found transaction file ~A~%" file)
 51 | 	(push file transaction-logs)))
 52 |     (sort transaction-logs
 53 | 	  #'(lambda (x y)
 54 | 	      (when (and (stringp x) (stringp y))
 55 | 		(let ((pieces-x (cl-ppcre:split "\-" (pathname-name x)))
 56 | 		      (pieces-y (cl-ppcre:split "\-" (pathname-name y))))
 57 | 		  (or (< (parse-integer (nth 1 pieces-x))
 58 | 			 (parse-integer (nth 1 pieces-y)))
 59 | 		      (and (= (parse-integer (nth 1 pieces-y))
 60 | 			      (parse-integer (nth 1 pieces-x)))
 61 | 			   (< (parse-integer (nth 2 pieces-x))
 62 | 			      (parse-integer (nth 2 pieces-y))))))))
 63 | 	  :key #'namestring)))
 64 | 
 65 | (defun replay-transactions (file &optional (store *store*))
 66 |   (let ((*store* store))
 67 |     (with-open-file (stream file :element-type '(unsigned-byte 8))
 68 |       (let ((magic-byte (read-byte stream nil :eof)))
 69 | 	(unless (= +transaction+ magic-byte)
 70 | 	  (error 'transaction-error
 71 | 		 :reason (format nil "~A is not a tx file!" file)))
 72 | 	(deserialize-action magic-byte stream)))))
 73 | 
 74 | (defun restore-triple-store (store)
 75 |   (let ((*store* store))
 76 |     (with-locked-index ((main-idx store))
 77 |       (multiple-value-bind (snapshot-file timestamp)
 78 |           (find-newest-snapshot store)
 79 | 	(when snapshot-file
 80 | 	  (format t "Restoring from snapshot file ~A~%" snapshot-file)
 81 | 	  (with-open-file (stream snapshot-file
 82 |                                   :element-type '(unsigned-byte 8))
 83 | 	    (do ((code (read-byte stream nil :eof)
 84 |                        (read-byte stream nil :eof)))
 85 | 		((or (eql code :eof) (null code) (= code 0)))
 86 | 	      (deserialize code stream))))
 87 | 	(dolist (file (find-transactions store timestamp))
 88 | 	  (format t "REPLAYING TX ~A~%" file)
 89 | 	  (replay-transactions file))
 90 | 	(do-indexing store)
 91 | 	store))))
 92 | 
 93 | (defun snapshot (store)
 94 |   (with-open-file
 95 |       (stream
 96 |        (format nil "~A/snap-~A" (location store) (get-universal-time))
 97 |        :direction :output
 98 |        :element-type '(unsigned-byte 8)
 99 |        :if-exists :overwrite
100 |        :if-does-not-exist :create)
101 |     (with-locked-index ((main-idx store))
102 |       (maphash #'(lambda (id triple)
103 | 		   (declare (ignore id))
104 | 		   (when (persistent? triple)
105 | 		     (logger :debug "serializing ~A: ~A"
106 | 			     (triple-id triple) triple)
107 | 		     (serialize triple stream)))
108 | 	       (gethash :id-idx (index-table (main-idx store)))))
109 |     (logger :debug "Recording null byte")
110 |     (write-byte 0 stream)
111 |     (force-output stream)))
112 | 
113 | (defun roll-logfile (store stream)
114 |   (when (and (streamp stream) (open-stream-p stream)) (close stream))
115 |   (open (format nil "~A/tx-~A" (location store) (get-universal-time))
116 | 	:element-type '(unsigned-byte 8)
117 | 	:direction :output
118 | 	:if-exists :rename
119 | 	:if-does-not-exist :create))
120 | 
121 | (defun set-dirty (store)
122 |   (with-open-file (stream (format nil "~A/.dirty" (location store))
123 | 			  :direction :output :if-exists :overwrite
124 | 			  :if-does-not-exist :create)
125 |     (format stream "~A" (gettimeofday))))
126 | 
127 | (defun set-clean (store)
128 |   (let ((file (format nil "~A/.dirty" (location store))))
129 |     (when (probe-file file)
130 |       (delete-file file))))
131 | 
132 | (defun clear-tx-log (store)
133 |   (dolist (file (directory
134 | 		 (make-pathname :directory (location store)
135 | 				:name :wild :type :wild)))
136 |     (when (pathname-match-p file "tx-*")
137 |       (delete-file file))))
138 | 
139 | (defun clear-snapshots (store)
140 |   (dolist (file (directory
141 | 		 (make-pathname :directory (location store)
142 | 				:name :wild :type :wild)))
143 |     (when (pathname-match-p file "snap-*")
144 |       (delete-file file))))
145 | 
146 | (defun dump-transaction (stream tx)
147 |   (when (and (transaction? tx) (tx-queue tx))
148 |     (logger :debug "Dumping tx ~A to ~A" tx stream)
149 |     (serialize-action :transaction stream tx)
150 |     (force-output stream)))
151 | 
152 | (defun record-tx (tx store)
153 |   (when (and (transaction? tx) (tx-queue tx))
154 |     (logger :debug "Recording tx ~A~%" (reverse (tx-queue tx)))
155 |     (handler-case
156 | 	(with-open-file (stream
157 | 			 (format nil "~A/tx-~A-~A" (location store)
158 | 				 (get-universal-time) (incf *file-counter*))
159 | 			 :element-type '(unsigned-byte 8) :direction :output
160 | 			 :if-exists :rename :if-does-not-exist :create)
161 | 	  (set-dirty store)
162 | 	  (dump-transaction stream tx))
163 |       (error (c)
164 | 	(logger :err "Unhandled error in record-tx: ~A" c)))))
165 | 
166 | (defun stop-logger (store)
167 |   (sb-concurrency:send-message (log-mailbox store) :shutdown)
168 |   (join-thread (logger-thread store)))
169 | 
170 | (defun start-logger (store)
171 |   (make-thread
172 |    #'(lambda ()
173 |        (let ((mailbox (sb-concurrency:make-mailbox)) (*file-counter* 0)
174 | 	     (last-snapshot (gettimeofday)))
175 | 	 (setf (log-mailbox store) mailbox)
176 | 	 (loop
177 | 	    (handler-case
178 | 		(let ((msg (sb-concurrency:receive-message mailbox)))
179 | 		  (logger :debug "tx-log thread received message ~A" msg)
180 | 		  (typecase msg
181 | 		    (transaction (record-tx msg store))
182 | 		    (keyword
183 | 		     (case msg
184 | 		       (:shutdown-and-clear
185 | 			(clear-tx-log store)
186 | 			(clear-snapshots store)
187 | 			(set-clean store)
188 | 			(quit))
189 | 		       (:shutdown
190 | 			(logger :debug "Processing all pending messages.")
191 | 			(dolist
192 | 			    (msg
193 | 			      (sb-concurrency:receive-pending-messages
194 |                                mailbox))
195 | 			  (logger :debug "Processing message ~A" msg)
196 | 			  (when (transaction? msg)
197 | 			    (record-tx msg store)))
198 | 			;;(logger :info "Snapshotting the store.")
199 | 			;;(snapshot store)
200 | 			;;(logger :info "Marking the store clean.")
201 | 			;;(set-clean store)
202 | 			(logger :info "Logger thread quitting.")
203 | 			(return t))
204 | 		       (:snapshot
205 | 			(logger :info "Snapshot commencing")
206 | 			(snapshot store)
207 | 			(logger :debug "Snapshot complete. Set store CLEAN")
208 | 			(set-clean store)
209 | 			(logger :debug "Store set CLEAN")
210 | 			(setq last-snapshot (gettimeofday))
211 | 			(logger :info "Snapshot finished"))
212 | 		       (otherwise
213 | 			(logger :info "Unknown msg to tx-log thread: ~A"
214 | 				msg))))))
215 | 	      (error (condition)
216 | 		(logger :err "Unhandled error in tx logger for ~A: ~A"
217 | 			store condition))))))
218 |    :name (format nil "tx-log thread for ~A" store)))
219 | 
220 | (defun release-all-locks (tx)
221 |   (sb-ext:with-locked-hash-table ((locks *store*))
222 |     (dolist (pair (tx-locks tx))
223 |       (destructuring-bind (pattern-or-triple lock kind) pair
224 | 	(declare (ignore lock))
225 | 	(if (triple? pattern-or-triple)
226 | 	    (unlock-triple pattern-or-triple :kind kind)
227 | 	    (funcall #'unlock-pattern
228 | 		     (nth 0 pattern-or-triple)
229 | 		     (nth 1 pattern-or-triple)
230 | 		     (nth 2 pattern-or-triple)
231 | 		     (nth 3 pattern-or-triple)
232 | 		     :kind kind))))))
233 | 
234 | (defun enqueue-lock (pattern lock kind)
235 |   (push (list pattern lock kind) (tx-locks *current-transaction*)))
236 | 
237 | (defun rollback-tx (tx)
238 |   (dolist (fn (reverse (tx-rollback tx)))
239 |     (funcall fn)))
240 | 
241 | (defun execute-tx (store fn timeout max-tries retries)
242 |   (if (>= retries max-tries)
243 |       (error 'transaction-error
244 | 	     :reason
245 | 	     (format nil
246 |                      "Unable to execute transaction. Too may retries (~A)."
247 | 		     retries))
248 |       (let ((*current-transaction* (make-transaction :store store)))
249 | 	(logger :debug "~A execute-tx starting" *current-transaction*)
250 | 	(handler-case
251 | 	    (sb-ext:with-timeout timeout
252 | 	      (funcall fn))
253 | 	  (sb-ext:timeout (condition)
254 | 	    (logger :debug "~A execute-tx timeout ~A"
255 | 		    *current-transaction* condition)
256 | 	    (rollback-tx *current-transaction*)
257 | 	    (release-all-locks *current-transaction*)
258 | 	    (execute-tx store fn timeout max-tries (1+ retries)))
259 | 	  (error (condition)
260 | 	    (logger :debug "~A execute-tx error ~A"
261 |                     *current-transaction* condition)
262 | 	    (rollback-tx *current-transaction*)
263 | 	    (release-all-locks *current-transaction*)
264 | 	    (error 'transaction-error
265 | 		   :reason
266 | 		   (format nil "Unable to execute transaction: ~A"
267 |                            condition)))
268 | 	  (:no-error (result)
269 | 	    (logger :debug "~A execute-tx success (~A)"
270 | 		    *current-transaction* result)
271 | 	    (when (tx-queue *current-transaction*)
272 | 	      (sb-concurrency:send-message
273 | 	       (log-mailbox store) *current-transaction*))
274 | 	    (release-all-locks *current-transaction*)
275 | 	    result)))))
276 | 
277 | (defmacro with-graph-transaction ((store &key (timeout 10) (max-tries 10))
278 | 				  &body body)
279 |   ;; body must be idempotent!
280 |   (with-gensyms (atomic-op)
281 |     `(let ((,atomic-op #'(lambda () ,@body)))
282 |        (cond ((and (transaction? *current-transaction*)
283 | 		   (equal (store-name (tx-store *current-transaction*))
284 | 			  (store-name ,store)))
285 | 	      (funcall ,atomic-op))
286 | 	     ((transaction? *current-transaction*)
287 | 	      (error 'transaction-error
288 | 		     :reason
289 | 		     "Transactions cannot currently span multiple stores."))
290 | 	     (t
291 | 	      (execute-tx ,store ,atomic-op ,timeout ,max-tries 0))))))
292 | 


--------------------------------------------------------------------------------
/prolog-functors.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:vivace-graph-v2)
  2 | 
  3 | (defvar *prolog-global-functors*
  4 |   (make-hash-table :synchronized t :test 'equalp))
  5 | 
  6 | (defmacro def-global-prolog-functor (name lambda-list &body body)
  7 |   `(prog1
  8 |        (defun ,name ,lambda-list ,@body)
  9 |      (export ',name)
 10 |      (setf (gethash ',name *prolog-global-functors*) #',name)))
 11 | 
 12 | (defun default-functor? (symbol)
 13 |   (gethash symbol *prolog-global-functors*))
 14 | 
 15 | (def-global-prolog-functor read/1 (exp cont)
 16 |   (if (unify exp (read)) (funcall cont)))
 17 | 
 18 | (def-global-prolog-functor write/1 (exp cont)
 19 |   (format t "~A" (deref-exp exp)) (funcall cont))
 20 | 
 21 | (def-global-prolog-functor nl/0 (cont)
 22 |   (terpri) (funcall cont))
 23 | 
 24 | (def-global-prolog-functor repeat/0 (cont)
 25 |   (loop (funcall cont)))
 26 | 
 27 | (def-global-prolog-functor fail/0 (cont)
 28 |   (declare (ignore cont))
 29 |   nil)
 30 | 
 31 | (def-global-prolog-functor =/2 (?arg1 ?arg2 cont)
 32 |   "Unifies two prolog variables."
 33 |   (if (unify ?arg1 ?arg2) (funcall cont)))
 34 | 
 35 | (def-global-prolog-functor ==/2 (?arg1 ?arg2 cont)
 36 |   "Checks equality of the values of two prolog variables."
 37 |   (if (deref-equal ?arg1 ?arg2) (funcall cont)))
 38 | 
 39 | (def-global-prolog-functor /=/2 (?arg1 ?arg2 cont)
 40 |   "Checks inequality of the values of two prolog variables."
 41 |   (if (not (deref-equal ?arg1 ?arg2)) (funcall cont)))
 42 | 
 43 | (def-global-prolog-functor >/2 (?arg1 ?arg2 cont)
 44 |   "Prolog greater than functor."
 45 |   (if (or (and (numberp (var-deref ?arg1)) (numberp (var-deref ?arg2))
 46 | 	       (> ?arg1 ?arg2))
 47 | 	  (and (timestamp? (var-deref ?arg1)) (timestamp? (var-deref ?arg2))
 48 | 	       (timestamp> ?arg1 ?arg2)))
 49 |       (funcall cont)))
 50 | 
 51 | (def-global-prolog-functor </2 (?arg1 ?arg2 cont)
 52 |   "Prolog less than functor."
 53 |   (if (or (and (numberp (var-deref ?arg1)) (numberp (var-deref ?arg2))
 54 | 	       (< ?arg1 ?arg2))
 55 | 	  (and (timestamp? (var-deref ?arg1)) (timestamp? (var-deref ?arg2))
 56 | 	       (timestamp< ?arg1 ?arg2)))
 57 |       (funcall cont)))
 58 | 
 59 | (def-global-prolog-functor >=/2 (?arg1 ?arg2 cont)
 60 |   "Prolog greater than or equal to functor."
 61 |   (if (or (and (numberp (var-deref ?arg1))
 62 | 	       (numberp (var-deref ?arg2))
 63 | 	       (>= ?arg1 ?arg2))
 64 | 	  (and (timestamp? (var-deref ?arg1)) (timestamp? (var-deref ?arg2))
 65 | 	       (timestamp>= ?arg1 ?arg2)))
 66 |       (funcall cont)))
 67 | 
 68 | (def-global-prolog-functor <=/2 (?arg1 ?arg2 cont)
 69 |   "Prolog less than or equal to functor."
 70 |   (if (or (and (numberp (var-deref ?arg1))
 71 | 	       (numberp (var-deref ?arg2))
 72 | 	       (<= ?arg1 ?arg2))
 73 | 	  (and (timestamp? (var-deref ?arg1)) (timestamp? (var-deref ?arg2))
 74 | 	       (timestamp<= ?arg1 ?arg2)))
 75 |       (funcall cont)))
 76 | 
 77 | ;(def-global-prolog-functor member/2 (?item list cont)
 78 | ;  (var-deref ?item)
 79 | ;  (when (and (listp list)
 80 | ;	     (member ?item list
 81 | ;                    :test #'(lambda (x y) (var-deref y) (prolog-equal x y))))
 82 | ;    (funcall cont)))
 83 | 
 84 | (def-global-prolog-functor lisp/2 (?result exp cont)
 85 |   "Call out to lisp from within a Prolog query.  Assigns result to the
 86 |  supplied Prolog var.  (lisp ?result (+ 1 2)).  Any lisp variables that you
 87 |  wish to access within a prolog query using the lisp functor should be
 88 |  declared special."
 89 |   (let ((exp (var-deref exp)))
 90 |     (when *prolog-trace* (format t "TRACE: LISP/2 ?result <- ~A~%" exp))
 91 |     (cond ((consp exp)
 92 | 	   (if (unify ?result (eval exp))
 93 | 	   ;;(if (unify ?result (apply (first exp) (rest exp)))
 94 | 	       (funcall cont)))
 95 | 	  ((and (symbolp exp) (boundp exp))
 96 | 	   ;;(if (unify ?result (eval exp))
 97 | 	   (if (unify ?result (funcall #'symbol-value exp))
 98 | 	       (funcall cont)))
 99 | 	  (t
100 | 	   (if (unify ?result exp)
101 | 	       (funcall cont))))))
102 | 
103 | (def-global-prolog-functor lispp/1 (exp cont)
104 |   "Call out to lisp from within a Prolog query and throws away the result.
105 |  Any lisp variables that you wish to access within a prolog query using the
106 |  lisp functor should be declared special."
107 |   (let ((exp (var-deref exp)))
108 |     (when *prolog-trace* (format t "TRACE: LISPP/1 ~A~%" exp))
109 |     (cond ((consp exp)
110 | 	   ;;(format t "applying ~A to ~A~%" (first exp) (rest exp))
111 | 	   (eval exp))
112 | 	   ;;(apply (first exp) (rest exp)))
113 | 	  ((and (symbolp exp) (boundp exp)) (funcall #'identity exp))
114 | 	  (t exp))
115 |     (funcall cont)))
116 | 
117 | (def-global-prolog-functor regex-match/2 (?arg1 ?arg2 cont)
118 |   "Functor that treats first arg as a regex and uses cl-ppcre:scan to check
119 |  for the pattern in the second arg."
120 |   (if (and (stringp (var-deref ?arg1))
121 | 	   (stringp (var-deref ?arg2))
122 | 	   (cl-ppcre:scan ?arg1 ?arg2))
123 |       (funcall cont)))
124 | 
125 | (def-global-prolog-functor var/1 (?arg1 cont)
126 |   (if (unbound-var-p ?arg1) (funcall cont)))
127 | 
128 | (def-global-prolog-functor is/2 (var exp cont)
129 |   "Similar to lisp/2, but unifies instead of assigns the lisp return value."
130 |   (if (and (not (find-if-anywhere #'unbound-var-p exp))
131 | 	   (unify var (eval (deref-exp exp))))
132 |       (funcall cont)))
133 | 
134 | (def-global-prolog-functor call/1 (goal cont)
135 |   "Call a prolog form."
136 |   (var-deref goal)
137 |   (let* ((functor (make-functor-symbol (first goal) (length (args goal)))))
138 |     (let ((fn (or (gethash functor *user-functors*)
139 | 		  (gethash functor *prolog-global-functors*))))
140 |       (if (functionp fn)
141 | 	  (apply fn (append (args goal) (list cont)))
142 | 	  (error 'prolog-error
143 | 		 :reason
144 | 		 (format nil "Unknown Prolog functor in call/1 ~A"
145 |                          functor))))))
146 | 
147 | (def-global-prolog-functor if/2 (?test ?then cont)
148 |   (when *prolog-trace* (format t "TRACE: IF/2(~A ~A)~%" ?test ?then))
149 |   (call/1 ?test #'(lambda () (call/1 ?then cont))))
150 | 
151 | (def-global-prolog-functor if/3 (?test ?then ?else cont)
152 |   (when *prolog-trace* (format t "TRACE: IF/3(~A ~A ~A)~%" ?test ?then ?else))
153 |   (call/1 ?test #'(lambda ()
154 | 		    (call/1 ?then
155 | 			    #'(lambda () (funcall cont) (return-from if/3)))))
156 |   (call/1 ?else cont))
157 | 
158 | (let ((date-regex
159 |        "^(19|20)\\d\\d[\-\ \/\.](0[1-9]|1[012])[\-\ \/\.](0[1-9]|[12][0-9]|3[01])$"))
160 |   (def-global-prolog-functor valid-date?/1 (date cont)
161 |     "Date validation functor. FIXME: This needs to be fleshed out with a
162 |  more comprehensive regex."
163 |     (var-deref date)
164 |     (if (timestamp? date)
165 | 	(funcall cont)
166 | 	(if (and (stringp date)
167 | 		 (cl-ppcre:scan date-regex date))
168 | 	    (funcall cont)))))
169 | 
170 | (def-global-prolog-functor trigger/1 (exp cont)
171 |   "Call out to lisp ignoring the return value."
172 |   (eval (deref-exp exp))
173 |   ;;(let ((exp (deref-exp exp)))
174 |     ;;(typecase exp
175 |       ;;(cons   (apply (first exp) (rest exp)))
176 |       ;;(symbol (symbol-value exp))))
177 |   (funcall cont))
178 | 
179 | (def-global-prolog-functor not/1 (relation cont)
180 |   "Prolog negation.  Does not retract, simply negates in the context of the
181 | query."
182 |   (with-undo-bindings
183 |     (call/1 relation #'(lambda () (return-from not/1 nil)))
184 |     (funcall cont)))
185 | 
186 | (def-global-prolog-functor bagof/3 (exp goal result cont)
187 |   (let ((answers nil))
188 |     (call/1 goal #'(lambda () (push (deref-copy exp) answers)))
189 |     (if (and (not (null answers))
190 | 	     (unify result (nreverse answers)))
191 | 	(funcall cont))))
192 | 
193 | (def-global-prolog-functor setof/3 (exp goal result cont)
194 |   (let ((answers nil))
195 |     (call/1 goal #'(lambda () (push (deref-copy exp) answers)))
196 |     (if (and (not (null answers))
197 | 	     (unify result (delete-duplicates answers :test #'deref-equal)))
198 | 	(funcall cont))))
199 | 
200 | (def-global-prolog-functor show-prolog-vars/2 (var-names vars cont)
201 |   (if (null vars)
202 |       (format t "~&Yes")
203 |       (loop for name in var-names
204 | 	 for var in vars do
205 | 	   (format t "~&~a = ~a" name (deref-exp var))))
206 |   (if (continue-p)
207 |       (funcall cont)
208 |       (throw 'top-level-prove nil)))
209 | 
210 | (let ((graph-pkg (find-package :graph-words)))
211 |   (def-global-prolog-functor select/2 (var-names vars cont)
212 |     (if (null vars)
213 | 	nil
214 | 	(push (loop for name in var-names
215 | 		 for var in vars
216 | 		 collect (let ((var (deref-exp var)))
217 | 			   (cond ((and (symbolp var)
218 | 				       (eq graph-pkg (symbol-package var)))
219 | 				  (symbol-name var))
220 | 				 ((and (consp var)
221 | 				       (eq (first var) name)
222 | 				       (symbolp (second var))
223 | 				       (eq graph-pkg
224 | 					   (symbol-package (second var))))
225 | 				  (list name (symbol-name (second var))))
226 | 				 (t var))))
227 | 	      *select-list*))
228 |     (funcall cont))
229 | 
230 |   (def-global-prolog-functor map-query/3 (fn vars collect? cont)
231 |     (when *prolog-trace*
232 |       (format t "TRACE: MAP-QUERY/3 FN (~A) IS ~A~%COLLECT? is ~A~%"
233 | 	      (type-of fn) fn collect?))
234 |     (if (null vars)
235 | 	nil
236 | 	(let ((new-vars
237 | 	       (loop
238 | 		  for var in vars
239 | 		  collect (let ((v (deref-exp var)))
240 | 			    (if (and (symbolp v)
241 | 				     (eq graph-pkg (symbol-package v)))
242 | 				(symbol-name v)
243 | 				v)))))
244 | 	  (let ((result (eval `(apply ,fn ',new-vars))))
245 | 	    (if collect? (push result *select-list*)))))
246 |     (funcall cont)))
247 | 
248 | (def-global-prolog-functor q-/4 (s p o g cont)
249 |   (when *prolog-trace* (format t "TRACE: Q-/4(~A ~A ~A ~A)~%" s p o g))
250 |   (let ((triples
251 | 	 (get-triples
252 | 	  :p (and (or (not (var-p p))
253 |                       (and (var-p p) (bound-p p))) (var-deref p))
254 | 	  :s (and (or (not (var-p s))
255 |                       (and (var-p s) (bound-p s))) (var-deref s))
256 | 	  :o (or (and (not (consp o))
257 |                       (or (not (var-p o)) (and (var-p o) (bound-p o)))
258 | 		      (var-deref o))
259 | 		 (and (consp o) (cdr o)))
260 | 	  :g (and (or (not (var-p g)) (and (var-p g) (bound-p g)))
261 | 		  (var-deref g)))))
262 |     (multiple-value-bind (s p o g) (intern-spog s p o g)
263 |       (map-cursor #'(lambda (id)
264 | 		      (let ((triple (get-triple-by-id id)))
265 | 			(let ((old-trail (fill-pointer *trail*)))
266 | 			  (when (and (triple? triple) (not (deleted? triple)))
267 | 			    (when (unify g (graph triple))
268 | 			      (when (unify p (triple-predicate triple))
269 | 				(when (unify s (triple-subject triple))
270 | 				  (if (consp o)
271 | 				      (when (unify (car o)
272 | 						   (triple-object triple))
273 | 					(funcall cont))
274 | 				      (when (unify o (triple-object triple))
275 | 					(funcall cont))))))
276 | 			    (undo-bindings old-trail)))))
277 | 		  triples))))
278 | 
279 | (def-global-prolog-functor q-/3 (s p o cont)
280 |   (when *prolog-trace* (format t "TRACE: Q-/3(~A ~A ~A)~%" s p o))
281 |   (q-/4 s p o *graph* cont))
282 | 
283 | (def-global-prolog-functor assert/1 (clause cont)
284 |   "Add a triple to the datastore."
285 |   (when (consp clause)
286 |     (setq clause (mapcar #'(lambda (c) (var-deref c)) clause))
287 |     (when *prolog-trace* (format t "TRACE: Asserting ~A~%" clause))
288 |     (if (and (or (= 3 (length clause))
289 | 		 (= 4 (length clause)))
290 | 	     (not (some #'var-p clause)))
291 | 	(let ((triple (add-triple (first clause)
292 |                                   (second clause)
293 |                                   (third clause)
294 | 				  (or (fourth clause) *graph*))))
295 | 	  (when *prolog-trace*
296 | 	    (format t "TRACE: Asserted new triple ~A~%" triple))
297 | 	  (when (triple? triple)
298 | 	    (funcall cont)))
299 | 	(error 'prolog-error
300 | 	       :reason
301 | 	       (format nil "assert is only for triples, not ~A" clause)))))
302 | 
303 | (def-global-prolog-functor subject/2 (?arg1 ?arg2 cont)
304 |   (when (and (triple? ?arg2) (unify ?arg1 (subject ?arg2)))
305 |     (funcall cont)))
306 | 
307 | (def-global-prolog-functor predicate/2 (?arg1 ?arg2 cont)
308 |   (when (and (triple? ?arg2) (unify ?arg1 (predicate ?arg2)))
309 |     (funcall cont)))
310 | 
311 | (def-global-prolog-functor object/2 (?arg1 ?arg2 cont)
312 |   (when (and (triple? ?arg2) (unify ?arg1 (object ?arg2)))
313 |     (funcall cont)))
314 | 
315 | (def-global-prolog-functor graph/2 (?arg1 ?arg2 cont)
316 |   (when (and (triple? ?arg2) (unify ?arg1 (graph ?arg2)))
317 |     (funcall cont)))
318 | 
319 | (def-global-prolog-functor triple-id/2 (?arg1 ?arg2 cont)
320 |   (when (and (triple? ?arg2) (unify ?arg1 (id ?arg2)))
321 |     (funcall cont)))
322 | 
323 | (def-global-prolog-functor certainty-factor/2 (?arg1 ?arg2 cont)
324 |   (cond ((and (triple? ?arg2) (unify ?arg1 (cf ?arg2)))
325 | 	 (funcall cont))
326 | 	((listp ?arg2)
327 | 	 (let ((triple (lookup-triple (var-deref (nth 0 ?arg2))
328 | 				      (var-deref (nth 1 ?arg2))
329 | 				      (var-deref (nth 2 ?arg2))
330 | 				      (if (nth 3 ?arg2)
331 | 					  (var-deref (nth 3 ?arg2))
332 | 					  *graph*))))
333 | 	   (when (and (triple? triple) (unify ?arg1 (cf triple)))
334 | 	     (funcall cont))))))
335 | 
336 | (def-global-prolog-functor is-true?/2 (?arg1 cont)
337 |   (when (and (triple? ?arg1) (= +cf-true+ (cf ?arg1)))
338 |     (funcall cont)))
339 | 
340 | (def-global-prolog-functor is-false?/2 (?arg1 cont)
341 |   (when (and (triple? ?arg1) (= +cf-false+ (cf ?arg1)))
342 |     (funcall cont)))
343 | 
344 | (def-global-prolog-functor is-unknown?/2 (?arg1 cont)
345 |   (when (and (triple? ?arg1) (= +cf-unknown+ (cf ?arg1)))
346 |     (funcall cont)))
347 | 
348 | (def-global-prolog-functor retract/1 (clause cont)
349 |   "Retract a fact from the datastore."
350 |   (when (consp clause)
351 |     (setq clause (mapcar #'(lambda (c) (var-deref c)) clause))
352 |     (if (and (or (= (length clause) 3)
353 | 		 (= (length clause) 4))
354 | 	     (not (some #'var-p clause)))
355 | 	(handler-case
356 | 	    (with-graph-transaction (*store*)
357 | 	      (when *prolog-trace*
358 | 		(format t "TRACE: Retracting fact ~A~%" clause))
359 | 	      (let ((triple (lookup-triple (first clause) (second clause)
360 | 					   (third clause)
361 | 					   (or (fourth clause) *graph*)
362 | 					   :retrieve-deleted? t)))
363 | 		(if (triple? triple)
364 | 		    (delete-triple triple)
365 | 		    (error 'prolog-error
366 | 			   :reason
367 | 			   (format nil "clause ~A does not represent a fact"
368 | 				   clause)))))
369 | 	  (prolog-error (condition)
370 | 	    (error 'prolog-error
371 | 		   :reason
372 | 		   (format nil "Cannot retract ~A: ~A~%" clause condition)))
373 | 	  (:no-error (result)
374 | 	    (declare (ignore result))
375 | 	    (funcall cont)))
376 | 	(error 'prolog-error
377 | 	       :reason
378 | 	       (format nil "Cannot retract a clause with variables: ~A"
379 | 		       clause)))))
380 | 
381 | (def-global-prolog-functor is-valid/1 (item cont)
382 |   "Mark a triple as VALID and remove an INVALID marker."
383 |   (var-deref item)
384 |   (with-graph-transaction (*store*)
385 |     (let ((triple (lookup-triple item "has-property" "invalid" *graph*)))
386 |       (when (triple? triple)
387 | 	(delete-triple triple)))
388 |     (and (add-triple item "has-property" "valid")
389 | 	 (funcall cont))))
390 | 
391 | (def-global-prolog-functor is-valid?/1 (item cont)
392 |   "Ask if a triple is valid."
393 |   (var-deref item)
394 |   (let ((triple (lookup-triple item "has-property" "valid" *graph*)))
395 |     (when (triple? triple)
396 |       (funcall cont))))
397 | 
398 | (def-global-prolog-functor is-invalid/1 (item cont)
399 |   "Mark a triple as INVALID and remove a VALID marker."
400 |   (var-deref item)
401 |   (with-graph-transaction (*store*)
402 |     (let ((triple (lookup-triple item "has-property" "valid" *graph*)))
403 |       (when (triple? triple)
404 | 	(delete-triple triple)))
405 |     (and (add-triple item "has-property" "invalid")
406 | 	 (funcall cont))))
407 | 
408 | (def-global-prolog-functor is-invalid?/1 (item cont)
409 |   "Ask if a triple is invalid."
410 |   (var-deref item)
411 |   (let ((triple (lookup-triple item "has-property" "invalid" *graph*)))
412 |     (when (triple? triple)
413 |       (funcall cont))))
414 | 
415 | (defmethod reify (node)
416 |   (declare (special node))
417 |   (select (?p ?o)
418 | 	  (lisp ?s node)
419 | 	  (q- ?s ?p ?o)))
420 | 
421 | (defun reify-recursive (node &key (max-levels 2) (level 0))
422 |   (unless (>= level max-levels)
423 |     (let ((relations (reify node)))
424 |       (list node
425 | 	    (mapcar #'(lambda (relation)
426 | 			(if (anonymous? (second relation))
427 | 			    (nconc (list (first relation))
428 | 				   (reify-recursive (second relation)
429 | 						    :max-levels max-levels
430 | 						    :level (1+ level)))
431 | 			    relation))
432 | 		    relations)))))
433 | 
434 | 


--------------------------------------------------------------------------------
/triples.lisp:
--------------------------------------------------------------------------------
  1 | (in-package #:vivace-graph-v2)
  2 | 
  3 | (defgeneric triple-eql (t1 t2)
  4 |   (:method ((t1 triple) (t2 triple)) (uuid:uuid-eql (id t1) (id t2)))
  5 |   (:method (t1 t2) nil))
  6 | 
  7 | (defgeneric triple-equal (t1 t2)
  8 |   (:method ((t1 triple) (t2 triple))
  9 |     (and (uuid:uuid-eql (id t1) (id t2))
 10 | 	 (equal (triple-subject t1) (triple-subject t2))
 11 | 	 (equal (triple-predicate t1) (triple-predicate t2))
 12 | 	 (equal (triple-object t1) (triple-object t2))))
 13 |   (:method (t1 t2) nil))
 14 | 
 15 | (defgeneric triple-equalp (t1 t2)
 16 |   (:method ((t1 triple) (t2 triple))
 17 |     (and (triple-equal t1 t2)
 18 | 	 (equal (triple-graph t1) (triple-graph t2))))
 19 |   (:method (t1 t2) nil))
 20 | 
 21 | (defmethod deleted? ((triple triple))
 22 |   (if (not *read-uncommitted*)
 23 |       (with-graph-transaction (*store*)
 24 | 	(enqueue-lock triple (lock-triple triple :kind :read) :read)
 25 | 	(triple-deleted? triple))
 26 |       (triple-deleted? triple)))
 27 | 
 28 | (defmethod subject ((triple triple))
 29 |   (flet ((get-value ()
 30 | 	   (if (and (symbolp (triple-subject triple))
 31 | 		    (eq *graph-words*
 32 |                         (symbol-package (triple-subject triple))))
 33 | 	       (symbol-name (triple-subject triple))
 34 | 	       (triple-subject triple))))
 35 |   (if (not *read-uncommitted*)
 36 |       (with-graph-transaction (*store*)
 37 | 	(enqueue-lock triple (lock-triple triple :kind :read) :read)
 38 | 	(get-value))
 39 |       (get-value))))
 40 | 
 41 | (defmethod subject ((list list))
 42 |   (second list))
 43 | 
 44 | (defmethod predicate ((triple triple))
 45 |   (flet ((get-value ()
 46 | 	   (if (and (symbolp (triple-predicate triple))
 47 | 		    (eq *graph-words*
 48 | 			(symbol-package (triple-predicate triple))))
 49 | 	       (symbol-name (triple-predicate triple))
 50 | 	       (triple-predicate triple))))
 51 |     (if (not *read-uncommitted*)
 52 | 	(with-graph-transaction (*store*)
 53 | 	  (enqueue-lock triple (lock-triple triple :kind :read) :read)
 54 | 	  (get-value))
 55 | 	(get-value))))
 56 | 
 57 | (defmethod predicate ((list list))
 58 |   (first list))
 59 | 
 60 | (defmethod object ((triple triple))
 61 |   (flet ((get-value ()
 62 | 	   (if (and (symbolp (triple-object triple))
 63 | 		    (eq *graph-words*
 64 |                         (symbol-package (triple-object triple))))
 65 | 	       (symbol-name (triple-object triple))
 66 | 	       (triple-object triple))))
 67 |     (if (not *read-uncommitted*)
 68 | 	(with-graph-transaction (*store*)
 69 | 	  (enqueue-lock triple (lock-triple triple :kind :read) :read)
 70 | 	  (get-value))
 71 | 	(get-value))))
 72 | 
 73 | (defmethod object ((list list))
 74 |   (third list))
 75 | 
 76 | (defmethod graph ((triple triple))
 77 |   (if (not *read-uncommitted*)
 78 |       (with-graph-transaction (*store*)
 79 | 	(enqueue-lock triple (lock-triple triple :kind :read) :read)
 80 | 	(triple-graph triple))
 81 |       (triple-graph triple)))
 82 | 
 83 | (defmethod graph ((list list))
 84 |   (fourth list))
 85 | 
 86 | (defmethod id ((triple triple))
 87 |   (if (not *read-uncommitted*)
 88 |       (with-graph-transaction (*store*)
 89 | 	(enqueue-lock triple (lock-triple triple :kind :read) :read)
 90 | 	(triple-id triple))
 91 |       (triple-id triple)))
 92 | 
 93 | (defmethod id ((list list))
 94 |   (fifth list))
 95 | 
 96 | (defmethod cf ((triple triple))
 97 |   (if (not *read-uncommitted*)
 98 |       (with-graph-transaction (*store*)
 99 | 	(enqueue-lock triple (lock-triple triple :kind :read) :read)
100 | 	(triple-cf triple))
101 |       (triple-cf triple)))
102 | 
103 | (defmethod belief-factor ((triple triple))
104 |   (if (not *read-uncommitted*)
105 |       (with-graph-transaction (*store*)
106 | 	(enqueue-lock triple (lock-triple triple :kind :read) :read)
107 | 	(triple-cf triple))
108 |       (triple-cf triple)))
109 | 
110 | (defmethod persistent? ((triple triple))
111 |   (if (not *read-uncommitted*)
112 |       (with-graph-transaction (*store*)
113 | 	(enqueue-lock triple (lock-triple triple :kind :read) :read)
114 | 	(triple-persistent? triple))
115 |       (triple-persistent? triple)))
116 | 
117 | (defun make-anonymous-node ()
118 |   "Create a unique anonymous node."
119 |   (format nil "_anon:~A" (make-uuid)))
120 | 
121 | (let ((regex
122 |        "^_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}$"))
123 |   (defun anonymous? (node)
124 |     (and (stringp node)
125 | 	 (cl-ppcre:scan regex node))))
126 | 
127 | (defun make-text-idx-key (g s p o)
128 |   (string-downcase (format nil "~A~A~A~A~A~A~A" g #\Nul s #\Nul p #\Nul o)))
129 | 
130 | (defun index-predicate (name-string)
131 |   (setf (gethash (format nil "~A" name-string) (indexed-predicates *store*))
132 |         t))
133 | 
134 | (defun unindex-predicate (name-string)
135 |   (setf (gethash (format nil "~A" name-string) (indexed-predicates *store*))
136 |         nil))
137 | 
138 | (defmethod make-anonymous-node-name ((uuid uuid:uuid))
139 |   (format nil "_anon:~A" uuid))
140 | 
141 | (defun set-triple-cf (triple new-value)
142 |   (with-graph-transaction (*store*)
143 |     (enqueue-lock triple (lock-triple triple :kind :write) :write)
144 |     (let ((old-cf (triple-cf triple)))
145 |       (when (persistent? triple)
146 | 	(push (list :set-cf triple) (tx-queue *current-transaction*)))
147 |       (push (lambda () (setf (triple-cf triple) old-cf))
148 | 	    (tx-rollback *current-transaction*))
149 |       (cas (triple-cf triple) (triple-cf triple) new-value))))
150 | 
151 | (defun undelete-triple (triple &key (persistent? t))
152 |   (with-graph-transaction (*store*)
153 |     (enqueue-lock triple (lock-triple triple :kind :write) :write)
154 |     (when persistent?
155 |       (push (list :undelete-triple triple) (tx-queue *current-transaction*)))
156 |     (let ((old-value (triple-deleted? triple)))
157 |       (push (lambda () (setf (triple-deleted? triple) old-value))
158 | 	    (tx-rollback *current-transaction*)))
159 |     (cas (triple-deleted? triple) (triple-deleted? triple) nil))
160 |   triple)
161 | 
162 | (defun delete-triple (triple &key (persistent? t))
163 |   (with-graph-transaction (*store*)
164 |     (enqueue-lock triple (lock-triple triple :kind :write) :write)
165 |     (when persistent?
166 |       (push (list :delete-triple triple) (tx-queue *current-transaction*)))
167 |     (let ((old-value (triple-deleted? triple)))
168 |       (push (lambda () (setf (triple-deleted? triple) old-value))
169 | 	    (tx-rollback *current-transaction*)))
170 |     (cas (triple-deleted? triple) nil (gettimeofday))))
171 | 
172 | (defun truly-delete-triple (triple &key (persistent? t))
173 |   ;; FIXME: create method for truly deleting triples, rather than marking them deleted.
174 |   (with-graph-transaction (*store*)
175 |     (enqueue-lock triple (lock-triple triple :kind :write) :write)
176 |     (when persistent?
177 |       (push (list :delete-triple triple) (tx-queue *current-transaction*)))
178 |     (cas (triple-deleted? triple) nil (gettimeofday))))
179 | 
180 | (defun %deindex-triple (triple &optional (store *store*))
181 |   (delete-from-index (main-idx store) (id triple) :gspoi-idx
182 | 		     (triple-graph triple) (triple-subject triple)
183 | 		     (triple-predicate triple) (triple-object triple))
184 |   (delete-from-index (main-idx store) (id triple) :spogi-idx
185 | 		     (triple-subject triple) (triple-predicate triple)
186 | 		     (triple-object triple) (triple-graph triple))
187 |   (delete-from-index (main-idx store) (id triple) :posgi-idx
188 | 		     (triple-predicate triple) (triple-object triple)
189 | 		     (triple-subject triple) (triple-graph triple))
190 |   (delete-from-index (main-idx store) (id triple) :ospgi-idx
191 | 		     (triple-object triple) (triple-subject triple)
192 | 		     (triple-predicate triple) (triple-graph triple))
193 |   (delete-from-index (main-idx store) (id triple) :gposi-idx
194 | 		     (triple-graph triple) (triple-predicate triple)
195 | 		     (triple-object triple) (triple-subject triple))
196 |   (delete-from-index (main-idx store) (id triple) :gospi-idx
197 | 		     (triple-graph triple) (triple-object triple)
198 | 		     (triple-subject triple) (triple-predicate triple))
199 |   (when (index-predicate? (predicate triple))
200 |     (remove-from-text-index (text-idx *store*) triple))
201 | ;;			    (make-text-idx-key
202 | ;;                             (graph triple) (subject triple)
203 | ;;                             (predicate triple) (object triple))))
204 |   t)
205 | 
206 | (defun index-triple (triple &optional (store *store*))
207 |   (with-graph-transaction (store)
208 |     (enqueue-lock triple (lock-triple triple :kind :write) :write)
209 |     (push (lambda () (%deindex-triple triple))
210 |           (tx-rollback *current-transaction*))
211 |     (add-to-index (main-idx store) (id triple) :gspoi-idx
212 | 		  (triple-graph triple) (triple-subject triple)
213 | 		  (triple-predicate triple) (triple-object triple))
214 |     (add-to-index (main-idx store) (id triple) :spogi-idx
215 | 		  (triple-subject triple) (triple-predicate triple)
216 | 		  (triple-object triple) (triple-graph triple))
217 |     (add-to-index (main-idx store) (id triple) :posgi-idx
218 | 		  (triple-predicate triple) (triple-object triple)
219 | 		  (triple-subject triple) (triple-graph triple))
220 |     (add-to-index (main-idx store) (id triple) :ospgi-idx
221 | 		  (triple-object triple) (triple-subject triple)
222 | 		  (triple-predicate triple) (triple-graph triple))
223 |     (add-to-index (main-idx store) (id triple) :gposi-idx
224 | 		  (triple-graph triple) (triple-predicate triple)
225 | 		  (triple-object triple) (triple-subject triple))
226 |     (add-to-index (main-idx store) (id triple) :gospi-idx
227 | 		  (triple-graph triple) (triple-object triple)
228 | 		  (triple-subject triple) (triple-predicate triple))
229 |     (when (index-predicate? (predicate triple))
230 |       (add-to-text-index (text-idx *store*) triple))
231 | ;;			 (make-text-idx-key
232 | ;;                          (graph triple) (subject triple)
233 | ;;                          (predicate triple) (object triple))
234 | ;;			 (id triple)))
235 |     triple))
236 | 
237 | (defun do-indexing (&optional (store *store*))
238 |   (with-graph-transaction (store)
239 |     (loop for triple = (sb-concurrency:dequeue (index-queue store)) do
240 | 	 (when (triple? triple)
241 | 	   (index-triple triple *store*))
242 | 	 (when (sb-concurrency:queue-empty-p (index-queue store))
243 | 	   (return)))))
244 | 
245 | (defun enqueue-triple-for-indexing (triple)
246 |   (add-to-index-queue triple))
247 | 
248 | (defun lookup-triple (subject predicate object graph &key retrieve-deleted?
249 | 		      already-locked?)
250 |   (multiple-value-bind (subject predicate object graph)
251 |       (intern-spog subject predicate object graph)
252 |     (flet ((lookup (s p o g)
253 | 	     (let ((cursor (get-from-index
254 |                             (main-idx *store*) :gspoi-idx g s p o)))
255 | 	       (if (uuid:uuid? (cursor-value cursor))
256 | 		   (let ((triple (cursor-value
257 | 				  (get-from-index (main-idx *store*)
258 | 						  :id-idx
259 | 						  (cursor-value cursor)))))
260 | 		     (when (triple? triple)
261 | 		       (if (deleted? triple)
262 | 			   (when retrieve-deleted?
263 | 			     triple)
264 | 			   triple)))))))
265 |       (if (or *read-uncommitted* already-locked?)
266 | 	  (lookup subject predicate object graph)
267 | 	  (with-graph-transaction (*store*)
268 | 	    (enqueue-lock (list subject predicate object graph)
269 | 			  (lock-pattern subject predicate object graph
270 |                                         :kind :read)
271 | 			  :read)
272 | 	    (lookup subject predicate object graph))))))
273 | 
274 | (defun add-triple (subject predicate object &key (graph *graph*)
275 |                    (index-immediate? t) cf (persistent? t))
276 |   (multiple-value-bind (subject predicate object graph)
277 |       (intern-spog subject predicate object graph)
278 |     (with-graph-transaction (*store*)
279 |       (let ((lock (lock-pattern subject predicate object graph :kind :write)))
280 | 	(enqueue-lock (list subject predicate object graph) lock :write)
281 | 	(or
282 | 	 (let ((triple (lookup-triple subject predicate object graph
283 | 				      :retrieve-deleted? t
284 | 				      :already-locked? t)))
285 | 	   (when (triple? triple)
286 | 	     (when cf
287 | 	       (set-triple-cf triple cf))
288 | 	     (when (deleted? triple)
289 | 	       (undelete-triple triple :persistent? persistent?))
290 | 	     triple))
291 | 	 (let ((id (uuid:make-v1-uuid)))
292 | 	   (let ((triple (make-triple :subject subject
293 | 				      :predicate predicate
294 | 				      :object object
295 | 				      :graph graph
296 | 				      :cf (or cf +cf-true+)
297 | 				      :persistent? persistent?
298 | 				      :id id)))
299 | 	     (when persistent?
300 | 	       (push (list :add-triple subject predicate object graph id nil
301 | 			   (cf triple))
302 | 		     (tx-queue *current-transaction*)))
303 | 	     (push (lambda ()
304 |                      (delete-from-index (main-idx *store*) triple :id-idx id))
305 | 		   (tx-rollback *current-transaction*))
306 | 	     (add-to-index (main-idx *store*) triple :id-idx id)
307 | 	     (if index-immediate?
308 | 		 (index-triple triple *store*)
309 | 		 (enqueue-triple-for-indexing triple))
310 | 	     triple)))))))
311 | 
312 | (defun get-triple-by-id (id &optional (store *store*))
313 |   (cursor-value (get-from-index (main-idx store) :id-idx id)))
314 | 
315 | (defun list-triples (&optional (store *store*))
316 |   (let ((triples nil))
317 |     (with-locked-index ((main-idx store))
318 |       (maphash #'(lambda (id triple)
319 | 		   (declare (ignore id))
320 | 		   (when (not (deleted? triple)) (push triple triples)))
321 | 	       (gethash :id-idx (index-table (main-idx store)))))
322 |     triples))
323 | 
324 | (defun triple-count (&optional (store *store*))
325 |   (let ((triple-count 0))
326 |     (with-locked-index ((main-idx store))
327 |       (maphash #'(lambda (id triple)
328 | 		   (when (not (deleted? triple)) (incf triple-count)))
329 | 	       (gethash :id-idx (index-table (main-idx store)))))
330 |     triple-count))
331 | 
332 | (defun get-triples (&key s p o search-string (g *graph*) (store *store*))
333 |   "Returns a cursor to the results."
334 |   (flet ((get-them ()
335 | 	   (multiple-value-bind (s p o g) (intern-spog s p o g)
336 | 	     (cond
337 |                (search-string
338 |                 (full-text-search (text-idx store) search-string
339 |                                   :g g :s s :p p))
340 |                ((and g s p o)
341 |                 (get-from-index (main-idx store) :gspoi-idx g s p o))
342 |                ((and g p s)
343 |                 (get-from-index (main-idx store) :gspoi-idx g s p))
344 |                ((and g p o)
345 |                 (get-from-index (main-idx store) :gposi-idx g p o))
346 |                ((and g p)
347 |                 (get-from-index (main-idx store) :gposi-idx g p))
348 |                ((and g s)
349 |                 (get-from-index (main-idx store) :gspoi-idx g s))
350 |                ((and g o)
351 |                 (get-from-index (main-idx store) :gospi-idx g o))
352 |                (g
353 |                 (get-from-index (main-idx store) :gospi-idx g))
354 |                (s
355 |                 (get-from-index (main-idx store) :spogi-idx s))
356 |                (o
357 |                 (get-from-index (main-idx store) :ospgi-idx o))
358 |                (p
359 |                 (get-from-index (main-idx store) :posgi-idx p))
360 |                ((and (null s) (null p) (null o) (null g))
361 |                 (get-from-index (main-idx store) :gspoi-idx))
362 |                (t
363 |                 (error
364 |                  "Other combinations of spogi to be implemented later."))))))
365 |     (if *read-uncommitted*
366 | 	(get-them)
367 | 	(with-locked-pattern (s p o g :read)
368 | 	  (get-them)))))
369 | 
370 | (defun get-triples-list (&key s p o search-string (g *graph*) (store *store*)
371 |                          retrieve-deleted? limit)
372 |   (let ((triples (map 'list
373 | 		      #'get-triple-by-id
374 | 		      (index-cursor-vector
375 | 		       (get-triples :s s :p p :o o :g g :store store
376 |                                     :search-string search-string)))))
377 |     (if retrieve-deleted?
378 | 	(if limit
379 | 	    (subseq triples 0 (if (> (length triples) limit) limit))
380 | 	    triples)
381 | 	(if limit
382 | 	    (let ((triples (remove-if #'deleted? triples)))
383 | 	      (subseq triples 0 (if (> (length triples) limit) limit)))
384 | 	    (remove-if #'deleted? triples)))))
385 | 
386 | (defun clear-graph (&optional (name *graph*))
387 |   (with-graph-transaction (*store*)
388 |     (map-cursor #'(lambda (id)
389 | 		    (delete-triple (get-triple-by-id id)))
390 | 		(get-from-index (main-idx *store*) :gspoi-idx name))))
391 | 
392 | (defun %set-triple-cf (id cf)
393 |   (let ((triple (get-triple-by-id (if (uuid:uuid? id)
394 | 				      id
395 | 				      (uuid:make-uuid-from-string id)))))
396 |     (when (triple? triple)
397 |       (cas (triple-cf triple) (triple-cf triple) cf))))
398 | 
399 | (defun %undelete-triple (id)
400 |   (let ((triple (get-triple-by-id (if (uuid:uuid? id)
401 | 				      id
402 | 				      (uuid:make-uuid-from-string id)))))
403 |     (when (triple? triple)
404 |       (cas (triple-deleted? triple) (triple-deleted? triple) nil))))
405 | 
406 | (defun %delete-triple (id timestamp)
407 |   (let ((triple (get-triple-by-id (if (uuid:uuid? id)
408 | 				      id
409 | 				      (uuid:make-uuid-from-string id)))))
410 |     (when (triple? triple)
411 |       (cas (triple-deleted? triple) (triple-deleted? triple) timestamp))))
412 | 
413 | (defun %index-triple (triple &optional (store *store*))
414 |   (add-to-index (main-idx store) triple :id-idx (id triple))
415 |   (add-to-index (main-idx store) (id triple) :gspoi-idx
416 | 		(triple-graph triple) (triple-subject triple)
417 | 		(triple-predicate triple) (triple-object triple))
418 |   (add-to-index (main-idx store) (id triple) :spogi-idx
419 | 		(triple-subject triple) (triple-predicate triple)
420 | 		(triple-object triple) (triple-graph triple))
421 |   (add-to-index (main-idx store) (id triple) :posgi-idx
422 | 		(triple-predicate triple) (triple-object triple)
423 | 		(triple-subject triple) (triple-graph triple))
424 |   (add-to-index (main-idx store) (id triple) :ospgi-idx
425 | 		(triple-object triple) (triple-subject triple)
426 | 		(triple-predicate triple) (triple-graph triple))
427 |   (add-to-index (main-idx store) (id triple) :gposi-idx
428 | 		(triple-graph triple) (triple-predicate triple)
429 | 		(triple-object triple) (triple-subject triple))
430 |   (add-to-index (main-idx store) (id triple) :gospi-idx
431 | 		(triple-graph triple) (triple-object triple)
432 | 		(triple-subject triple) (triple-predicate triple))
433 |   (when (index-predicate? (predicate triple))
434 |     (format t "%index-triple: indexing ~A~%" triple)
435 |     (add-to-text-index (text-idx *store*) triple))
436 | ;;		       (make-text-idx-key (graph triple) (subject triple)
437 | ;;					  (predicate triple) (object triple))
438 | ;;		       (id triple)))
439 |   triple)
440 | 
441 | (defun %add-triple (subject predicate object id graph cf deleted?)
442 |   (let ((triple (make-triple :subject subject
443 | 			     :predicate predicate
444 | 			     :object object
445 | 			     :graph graph
446 | 			     :cf cf
447 | 			     :id id
448 | 			     :persistent? t
449 | 			     :deleted? deleted?)))
450 |     (%index-triple triple)
451 |     triple))
452 | 
453 | (defun dump-triples (file &optional (store *store*))
454 |   (with-open-file (stream file
455 | 			  :direction :output
456 | 			  :if-exists :supersede
457 | 			  :if-does-not-exist :create)
458 |     (with-graph-transaction (store)
459 |       (maphash #'(lambda (id triple)
460 | 		   (when (persistent? triple)
461 | 		     (write `(,(subject triple)
462 | 			       ,(predicate triple)
463 | 			       ,(object triple)
464 | 			       ,(format nil "~A" id)
465 | 			       ,(graph triple)
466 | 			       ,(cf triple)
467 | 			       ,(deleted? triple))
468 | 			    :stream stream :pretty nil)
469 | 		     (format stream "~%")))
470 | 	       (gethash :id-idx (index-table (main-idx store)))))))
471 | 
472 | (defun load-triples (file)
473 |   (with-open-file (stream file)
474 |     (let ((count 0))
475 |       (handler-case
476 | 	  (loop
477 | 	     (let ((triple (read stream)))
478 | 	       (%add-triple (nth 0 triple)
479 | 			    (nth 1 triple)
480 | 			    (nth 2 triple)
481 | 			    (uuid:make-uuid-from-string (nth 3 triple))
482 | 			    (nth 4 triple)
483 | 			    (nth 5 triple)
484 | 			    (nth 6 triple))
485 | 	       (incf count)))
486 | 	(end-of-file (condition)
487 | 	  (declare (ignore condition))
488 | 	  (do-indexing)
489 | 	  (format t "Loaded ~A triples~%" count))
490 | 	(error (condition)
491 | 	  (format t "Error loading triples: ~A / ~A~%"
492 | 		  (type-of condition) condition))))))
493 | 
494 | 


--------------------------------------------------------------------------------
/prologc.lisp:
--------------------------------------------------------------------------------
  1 | ;;;; This is Kevin Raison's customization of Mr. Norvig's PAIP Prolog.
  2 | ;;;; Thanks Mr. Norvig!
  3 | ;;;; Copyright (c) 1991 Peter Norvig, (c) 2010 Kevin Raison
  4 | (in-package #:vivace-graph-v2)
  5 | 
  6 | (defun trace-prolog () (setq *prolog-trace* t))
  7 | (defun untrace-prolog () (setq *prolog-trace* nil))
  8 | 
  9 | (defstruct (var (:constructor ? ())
 10 |                 (:print-function print-var))
 11 |   (name (incf *var-counter*))
 12 |   (binding +unbound+))
 13 | 
 14 | (defmacro var-deref (exp)
 15 |   "Follow pointers for bound variables."
 16 |   `(progn (loop while (and (var-p ,exp) (bound-p ,exp))
 17 |              do (setf ,exp (var-binding ,exp)))
 18 | 	  ,exp))
 19 | 
 20 | (defun print-var (var stream depth)
 21 |   (if (or (and *print-level*
 22 |                (>= depth *print-level*))
 23 |           (var-p (var-deref var)))
 24 |       (format stream "?~a" (var-name var))
 25 |       (write var :stream stream)))
 26 | 
 27 | (defun bound-p (var) (not (eq (var-binding var) +unbound+)))
 28 | 
 29 | (defgeneric prolog-equal (x y)
 30 |   (:documentation "Generic equality operator for prolog unification.
 31 |  Specialize this for new types that will be stored in the db.")
 32 |   (:method ((x number) (y number)) (= x y))
 33 |   (:method ((x string) (y string)) (string= x y))
 34 |   (:method ((x character) (y character)) (char= x y))
 35 |   (:method ((x timestamp) (y timestamp)) (timestamp= x y))
 36 |   (:method ((x timestamp) (y integer)) (= (timestamp-to-universal x) y))
 37 |   (:method ((x integer) (y timestamp)) (= (timestamp-to-universal y) x))
 38 |   (:method ((x triple) (y triple)) (triple-equal x y))
 39 |   (:method ((x uuid:uuid) (y uuid:uuid)) (uuid:uuid-eql x y))
 40 |   (:method (x y) (equal x y)))
 41 | 
 42 | (defun unify (x y)
 43 |   "Destructively unify two expressions."
 44 |   (cond ((prolog-equal (var-deref x) (var-deref y)) t)
 45 |         ((var-p x) (set-binding x y))
 46 |         ((var-p y) (set-binding y x))
 47 |         ((and (consp x) (consp y))
 48 |          (and (unify (first x) (first y))
 49 |               (unify (rest x) (rest y))))
 50 |         (t nil)))
 51 | 
 52 | (defun set-binding (var value)
 53 |   "Set var's binding to value, after saving the variable
 54 |   in the trail.  Always returns t."
 55 |   (unless (eq var value)
 56 |     (vector-push-extend var *trail*)
 57 |     (setf (var-binding var) value))
 58 |   t)
 59 | 
 60 | (defun undo-bindings (old-trail)
 61 |   "Undo all bindings back to a given point in the trail."
 62 |   (loop until (= (fill-pointer *trail*) old-trail)
 63 |      do (setf (var-binding (vector-pop *trail*)) +unbound+)))
 64 | 
 65 | (defmethod clause-head ((triple triple))
 66 |   (list (predicate triple) (subject triple) (object triple) (graph triple)))
 67 | 
 68 | (defmethod clause-head ((list list))
 69 |   (first list))
 70 | 
 71 | (defun prolog-compile-help (functor clauses)
 72 |   (let ((arity (relation-arity (clause-head (first clauses)))))
 73 |     (compile-functor functor arity (clauses-with-arity clauses #'= arity))
 74 |     (prolog-compile-help functor (clauses-with-arity clauses #'/= arity))))
 75 | 
 76 | (defmethod prolog-compile ((functor functor))
 77 |   (if (null (functor-clauses functor))
 78 |       (prolog-compile-null functor)
 79 |       (prolog-compile-help functor (functor-clauses functor))))
 80 | 
 81 | (defun clauses-with-arity (clauses test arity)
 82 |   "Return all clauses whose head has given arity."
 83 |   (find-all arity clauses
 84 |             :key #'(lambda (clause) (relation-arity (clause-head clause)))
 85 |             :test test))
 86 | 
 87 | (defun relation-arity (relation)
 88 |   "The number of arguments to a relation.
 89 |   Example: (relation-arity '(p a b c)) => 3"
 90 |   (length (args relation)))
 91 | 
 92 | (defun args (x) "The arguments of a relation" (rest x))
 93 | 
 94 | (defun make-parameters (arity)
 95 |   "Return the list (?arg1 ?arg2 ... ?arg-arity)"
 96 |   (loop for i from 1 to arity
 97 |         collect (new-interned-symbol '?arg i)))
 98 | 
 99 | (defun make-functor-symbol (symbol arity)
100 |   (new-interned-symbol symbol '/ arity))
101 | 
102 | (defun make-= (x y) `(= ,x ,y))
103 | 
104 | (defun compile-call (predicate arity args cont)
105 |   "Compile a call to a prolog predicate."
106 |   (let ((functor (make-functor-symbol predicate arity)))
107 |     `(let ((func (or (get-functor-fn ',functor)
108 | 		     (gethash ',functor *prolog-global-functors*))))
109 |        (when *prolog-trace*
110 | 	 (format t "TRACE: ~A/~A~A~%" ',predicate ',arity ',args))
111 |        (if (functionp func)
112 | 	   (funcall func ,@args ,cont)))))
113 | 
114 | (defun prolog-compiler-macro (name)
115 |   "Fetch the compiler macro for a Prolog predicate."
116 |   ;; Note NAME is the raw name, not the name/arity
117 |   (typecase name
118 |     (string (get (intern (string-upcase name)) 'prolog-compiler-macro))
119 |     (symbol (get name 'prolog-compiler-macro))
120 |     (otherwise nil)))
121 | 
122 | (defmacro def-prolog-compiler-macro (name arglist &body body)
123 |   "Define a compiler macro for Prolog."
124 |   `(setf (get ',name 'prolog-compiler-macro)
125 |          #'(lambda ,arglist .,body)))
126 | 
127 | (defun binding-val (binding)
128 |   (cdr binding))
129 | 
130 | (defun get-binding (var bindings)
131 |   (assoc var bindings))
132 | 
133 | (defun variable-p (x)
134 |   ;;(and (symbolp x) (not (eq x '??)) (equal (char (symbol-name x) 0) #\?)))
135 |   (and (symbolp x) (equal (char (symbol-name x) 0) #\?)))
136 | 
137 | (defun compile-arg (arg bindings)
138 |   "Generate code for an argument to a goal in the body."
139 |   (cond ((eq arg '?) '(?))
140 |         ((variable-p arg)
141 |          (let ((binding (get-binding arg bindings)))
142 |            (if (and (not (null binding))
143 |                     (not (eq arg (binding-val binding))))
144 |              (compile-arg (binding-val binding) bindings)
145 |              arg)))
146 |         ((not (find-if-anywhere #'variable-p arg)) `',arg)
147 |         ((proper-listp arg)
148 |          `(list .,(mapcar #'(lambda (a) (compile-arg a bindings))
149 |                           arg)))
150 |         (t `(cons ,(compile-arg (first arg) bindings)
151 |                   ,(compile-arg (rest arg) bindings)))))
152 | 
153 | (defun has-variable-p (x)
154 |   "Is there a variable anywhere in the expression x?"
155 |   (find-if-anywhere #'variable-p x))
156 | 
157 | (defun proper-listp (x)
158 |   "Is x a proper (non-dotted) list?"
159 |   (or (null x)
160 |       (and (consp x) (proper-listp (rest x)))))
161 | 
162 | (defun maybe-add-undo-bindings (compiled-exps)
163 |   "Undo any bindings that need undoing.
164 |   If there are any, bind the trail before we start."
165 |   (if (length=1 compiled-exps)
166 |       compiled-exps
167 |       `((let ((old-trail (fill-pointer *trail*)))
168 |           ,(first compiled-exps)
169 |           ,@(loop for exp in (rest compiled-exps)
170 |                   collect '(undo-bindings old-trail)
171 |                   collect exp)))))
172 | 
173 | (defmacro with-undo-bindings (&body body)
174 |   (if (length=1 body)
175 |       (first body)
176 |       `(let ((old-trail (fill-pointer *trail*)))
177 | 	 ,(first body)
178 | 	 ,@(loop for exp in (rest body)
179 | 	      collect '(undo-bindings old-trail)
180 | 	      collect exp))))
181 | 
182 | (defun variables-in (exp)
183 |   (unique-find-anywhere-if #'variable-p exp))
184 | 
185 | (defun unbound-var-p (exp)
186 |   (and (var-p exp) (not (bound-p exp))))
187 | 
188 | (defun bind-unbound-vars (parameters exp)
189 |   "If there are any variables in exp (besides the parameters)
190 |   then bind them to new vars."
191 |   (let ((exp-vars (remove '? (set-difference (variables-in exp)
192 | 					     parameters))))
193 |     (if exp-vars
194 |         `(let ,(mapcar #'(lambda (var) `(,var (?)))
195 |                        exp-vars)
196 |            ,exp)
197 |         exp)))
198 | 
199 | (defun make-anonymous (exp &optional (anon-vars (anonymous-variables-in exp)))
200 |   "Replace variables that are only used once with ?."
201 |   (cond ((consp exp)
202 |          (reuse-cons (make-anonymous (first exp) anon-vars)
203 |                      (make-anonymous (rest exp) anon-vars)
204 |                      exp))
205 |         ((member exp anon-vars) '?)
206 |         (t exp)))
207 | 
208 | (defun anonymous-variables-in (tree)
209 |   "Return a list of all variables that occur only once in tree."
210 |   (values (anon-vars-in tree nil nil)))
211 | 
212 | (defun anon-vars-in (tree seen-once seen-more)
213 |   "Walk the data structure TREE, returning a list of variabless
214 |    seen once, and a list of variables seen more than once."
215 |   (cond
216 |     ((consp tree)
217 |      (multiple-value-bind (new-seen-once new-seen-more)
218 |          (anon-vars-in (first tree) seen-once seen-more)
219 |        (anon-vars-in (rest tree) new-seen-once new-seen-more)))
220 |     ((not (variable-p tree)) (values seen-once seen-more))
221 |     ((member tree seen-once)
222 |      (values (delete tree seen-once) (cons tree seen-more)))
223 |     ((member tree seen-more)
224 |      (values seen-once seen-more))
225 |     (t (values (cons tree seen-once) seen-more))))
226 | 
227 | (defun compile-unify (x y bindings)
228 |   "Return 2 values: code to test if x and y unify,
229 |   and a new binding list."
230 |   (cond
231 |     ;; Unify constants and conses:                       ; Case
232 |     ((not (or (has-variable-p x) (has-variable-p y)))    ; 1,2
233 |      (values (prolog-equal x y) bindings))
234 |     ((and (consp x) (consp y))                           ; 3
235 |      (multiple-value-bind (code1 bindings1)
236 |          (compile-unify (first x) (first y) bindings)
237 |        (multiple-value-bind (code2 bindings2)
238 |            (compile-unify (rest x) (rest y) bindings1)
239 |          (values (compile-if code1 code2) bindings2))))
240 |     ;; Here x or y is a variable.  Pick the right one:
241 |     ((variable-p x) (compile-unify-variable x y bindings))
242 |     (t              (compile-unify-variable y x bindings))))
243 | 
244 | (defun compile-if (pred then-part)
245 |   "Compile a Lisp IF form. No else-part allowed."
246 |   (case pred
247 |     ((t) then-part)
248 |     ((nil) nil)
249 |     (otherwise `(if ,pred ,then-part))))
250 | 
251 | (defun extend-bindings (var val bindings)
252 |   (cons (cons var val)
253 | 	(if (eq bindings +no-bindings+)
254 | 	    nil
255 | 	    bindings)))
256 | 
257 | (defun compile-unify-variable (x y bindings)
258 |   "X is a variable, and Y may be."
259 |   (let* ((xb (follow-binding x bindings))
260 |          (x1 (if xb (cdr xb) x))
261 |          (yb (if (variable-p y) (follow-binding y bindings)))
262 |          (y1 (if yb (cdr yb) y)))
263 |     (cond                                                  ; Case:
264 |       ((or (eq x '?) (eq y '?)) (values t bindings))       ; 12
265 |       ((not (and (prolog-equal x x1) (prolog-equal y y1))) ; deref
266 |        (compile-unify x1 y1 bindings))
267 |       ((find-anywhere x1 y1) (values nil bindings))        ; 11
268 |       ((consp y1)                                          ; 7,10
269 |        (values `(unify ,x1 ,(compile-arg y1 bindings))
270 |                (bind-variables-in y1 bindings)))
271 |       ((not (null xb))
272 |        ;; i.e. x is an ?arg variable
273 |        (if (and (variable-p y1) (null yb))
274 |            (values 't (extend-bindings y1 x1 bindings))    ; 4
275 |            (values `(unify ,x1 ,(compile-arg y1 bindings))
276 |                    (extend-bindings x1 y1 bindings))))     ; 5,6
277 |       ((not (null yb))
278 |        (compile-unify-variable y1 x1 bindings))
279 |       (t (values 't (extend-bindings x1 y1 bindings))))))  ; 8,9
280 | 
281 | (defun bind-variables-in (exp bindings)
282 |   "Bind all variables in exp to themselves, and add that to
283 |   bindings (except for variables already bound)."
284 |   (dolist (var (variables-in exp))
285 |     (unless (get-binding var bindings)
286 |       (setf bindings (extend-bindings var var bindings))))
287 |   bindings)
288 | 
289 | (defun follow-binding (var bindings)
290 |   "Get the ultimate binding of var according to bindings."
291 |   (let ((b (get-binding var bindings)))
292 |     (if (eq (car b) (cdr b))
293 |         b
294 |         (or (follow-binding (cdr b) bindings)
295 |             b))))
296 | 
297 | (defun bind-new-variables (bindings goal)
298 |   "Extend bindings to include any unbound variables in goal."
299 |   (let ((variables (remove-if #'(lambda (v) (assoc v bindings))
300 |                               (variables-in goal))))
301 |     (nconc (mapcar #'self-cons variables) bindings)))
302 | 
303 | (defun self-cons (x) (cons x x))
304 | 
305 | (def-prolog-compiler-macro = (goal body cont bindings)
306 |   "Compile a goal which is a call to =."
307 |   (let ((args (args goal)))
308 |     (if (/= (length args) 2)
309 |         :pass ;; decline to handle this goal
310 |         (multiple-value-bind (code1 bindings1)
311 |             (compile-unify (first args) (second args) bindings)
312 |           (compile-if
313 |             code1
314 |             (compile-body body cont bindings1))))))
315 | 
316 | (def-prolog-compiler-macro true (goal body cont bindings)
317 |   (declare (ignore goal))
318 |   (compile-body body cont bindings))
319 | 
320 | (def-prolog-compiler-macro fail (goal body cont bindings)
321 |   (declare (ignore goal body cont bindings))
322 |   nil)
323 | 
324 | (def-prolog-compiler-macro and (goal body cont bindings)
325 |   (compile-body (append (args goal) body) cont bindings))
326 | 
327 | (def-prolog-compiler-macro or (goal body cont bindings)
328 |   (let ((disjuncts (args goal)))
329 |     (case (length disjuncts)
330 |       (0 +fail+)
331 |       (1 (compile-body (cons (first disjuncts) body) cont bindings))
332 |       (t (let ((fn (gensym "F")))
333 | 	   `(flet ((,fn () ,(compile-body body cont bindings)))
334 | 	      .,(maybe-add-undo-bindings
335 | 		 (loop for g in disjuncts collect
336 | 		      (compile-body (list g) `#',fn bindings)))))))))
337 | 
338 | (defmethod clause-body ((triple triple))
339 |   nil)
340 | 
341 | (defmethod clause-body ((list list))
342 |   (rest list))
343 | 
344 | (defun compile-clause (parms clause cont)
345 |   "Transform away the head, and compile the resulting body."
346 |   (let ((body
347 | 	 (bind-unbound-vars
348 | 	  parms
349 | 	  (compile-body
350 | 	   (nconc
351 | 	    (mapcar #'make-= parms (args (clause-head clause)))
352 | 	    (clause-body clause))
353 | 	   cont
354 | 	   (mapcar #'self-cons parms)))))
355 |     (when *prolog-trace*
356 |       (format t "TRACE: ~A BODY:~% ~A~%" (clause-head clause) body))
357 |     body))
358 | 
359 | (defun add-clause (clause)
360 |   "add a user-defined functor"
361 |   (let* ((functor-name (first (clause-head clause))))
362 |     (when *prolog-trace* (format t "TRACE:  Adding clause ~A~%" clause))
363 |     (assert (and (atom functor-name) (not (variable-p functor-name))))
364 |     (let* ((arity (relation-arity (clause-head clause)))
365 | 	   (functor (make-functor-symbol functor-name arity)))
366 |       (if (gethash functor *prolog-global-functors*)
367 | 	  (error 'prolog-error
368 | 		 :reason
369 | 		 (format nil "Cannot override default functor ~A." functor))
370 | 	  (let ((f (lookup-functor functor)))
371 | 	    (if (functor? f)
372 | 		(add-functor-clause f clause)
373 | 		(make-functor :name functor :clauses (list clause))))))))
374 | 
375 | ;(defun deref-copy (exp)
376 | ;  (sublis (mapcar #'(lambda (var) (cons (var-deref var) (?)))
377 | ;		  (unique-find-anywhere-if #'var-p exp))
378 | ;	  exp))
379 | 
380 | (defun deref-copy (exp)
381 |   (let ((var-alist nil))
382 |     (labels ((walk (exp)
383 | 	       (deref-exp exp)
384 | 	       (cond ((consp exp)
385 | 		      (reuse-cons (walk (first exp))
386 | 				  (walk (rest exp))
387 | 				  exp))
388 | 		     ((var-p exp)
389 | 		      (let ((entry (assoc exp var-alist)))
390 | 			(if (not (null entry))
391 | 			    (cdr entry)
392 | 			    (let ((var-copy (?)))
393 | 			      (push (cons exp var-copy) var-alist)
394 | 			      var-copy))))
395 | 		     (t exp))))
396 |       (walk exp))))
397 | 
398 | (defun deref-exp (exp)
399 |   "Build something equivalent to EXP with variables dereferenced."
400 |   (if (atom (var-deref exp))
401 |       exp
402 |       (reuse-cons
403 |         (deref-exp (first exp))
404 |         (deref-exp (rest exp))
405 |         exp)))
406 | 
407 | (defun deref-equal (x y)
408 |   (or (prolog-equal (var-deref x) (var-deref y))
409 |       (and (consp x)
410 | 	   (consp y)
411 | 	   (deref-equal (first x) (first y))
412 | 	   (deref-equal (rest x) (rest y)))))
413 | 
414 | (defmethod prolog-compile-null ((functor functor))
415 |   (let ((*functor* (functor-name functor)))
416 |     (set-functor-fn *functor*
417 | 		    #'(lambda (&rest args) (declare (ignore args)) nil))))
418 | 
419 | (defun compile-functor (functor arity clauses)
420 |   "Compile all the clauses for a given symbol/arity into a single LISP
421 |  function."
422 |   (let ((*functor* (functor-name functor))
423 | 	(parameters (make-parameters arity)))
424 |     (let ((func `#'(lambda (,@parameters cont)
425 | 		     (block ,*functor*
426 | 		       .,(maybe-add-undo-bindings
427 | 			  (mapcar
428 |                            #'(lambda (clause)
429 |                                (compile-clause parameters clause 'cont))
430 |                            clauses))))))
431 |       (when *prolog-trace*
432 |         (format t "TRACE: Adding ~A to ~A~%" func *functor*))
433 |       (set-functor-fn *functor* (eval func)))))
434 | 
435 | (defun compile-body (body cont bindings)
436 |   "Compile the body of a clause."
437 |   (cond
438 |     ((null body)
439 |      `(funcall ,cont))
440 |     ((or (eq (first body) '!) (eq (first body) 'cut)
441 |          (equalp (first body) "cut"))
442 |      `(progn ,(compile-body (rest body) cont bindings)
443 |              (return-from ,*functor* nil)))
444 |     (t (let* ((goal (first body))
445 |               (macro (prolog-compiler-macro (predicate goal)))
446 |               (macro-val (if macro
447 | 			     (funcall macro goal (rest body) cont bindings))))
448 | 	 (if (and macro (not (eq macro-val :pass)))
449 | 	     macro-val
450 | 	     (compile-call
451 |               (predicate goal) (relation-arity goal)
452 |               (mapcar #'(lambda (arg)
453 |                           (compile-arg arg bindings))
454 |                       (args goal))
455 |               (if (null (rest body))
456 |                   cont
457 |                   `#'(lambda ()
458 |                        ,(compile-body
459 |                          (rest body) cont
460 |                          (bind-new-variables bindings goal))))))))))
461 | 
462 | (defun replace-?-vars (exp)
463 |   "Replace any ? within exp with a var of the form ?123."
464 |   (cond ((eq exp '?) (intern (symbol-name (gensym "?"))))
465 | 	((atom exp) exp)
466 | 	(t (reuse-cons (replace-?-vars (first exp))
467 | 		       (replace-?-vars (rest exp))
468 | 		       exp))))
469 | 
470 | (defmacro <- (&rest clause)
471 |   "Add a user-defined functor, or add clauses to an existing functor."
472 |   `(let ((*functor* nil)) (add-clause ',(make-anonymous clause))))
473 | 
474 | (defmacro insert (&rest triples)
475 |   "Add triples to the data base. Wraps all additions in a single transaction."
476 |   `(let ((count 0))
477 |      (with-graph-transaction (*store*)
478 |        (dolist (triple ',triples)
479 | 	 (add-triple (first triple) (second triple) (third triple)
480 | 		     :graph (or (fourth triple) *graph*))
481 | 	 (incf count))
482 |        (do-indexing))
483 |      count))
484 | 
485 | (defun prolog-ignore (&rest args)
486 |   (declare (ignore args))
487 |   nil)
488 | 
489 | (defmacro ?- (&rest goals)
490 |   "Execute an interactive prolog query."
491 |   (let* ((goals (replace-?-vars goals))
492 | 	 (vars (delete '? (variables-in goals)))
493 | 	 (top-level-query (gensym "PROVE"))
494 | 	 (*functor* (make-functor-symbol top-level-query 0)))
495 |     `(let* ((*trail* (make-array 200 :fill-pointer 0 :adjustable t))
496 | 	    (*var-counter* 0)
497 | 	    (*functor* ',*functor*)
498 | 	    (functor (make-functor :name *functor* :clauses nil)))
499 |        (unwind-protect
500 | 	    (catch 'top-level-prove
501 | 	      (let ((func #'(lambda (cont)
502 | 			      (handler-case
503 | 				  (block ,*functor*
504 | 				    .,(maybe-add-undo-bindings
505 | 				       (mapcar
506 | 					#'(lambda (clause)
507 | 					    (compile-clause nil clause 'cont))
508 | 					`(((,top-level-query)
509 | 					   ,@goals
510 | 					   (show-prolog-vars
511 | 					    ,(mapcar #'symbol-name vars)
512 | 					    ,vars))))))
513 | 				(undefined-function (condition)
514 | 				  (error 'prolog-error :reason condition))))))
515 | 		(set-functor-fn *functor* func)
516 | 		(funcall func #'prolog-ignore)
517 | 		(format t "~&No.~%")))
518 | 	 (delete-functor functor))
519 |        (values))))
520 | 
521 | (defmacro select (vars &rest goals)
522 |   "Select specific variables as a list of lists using the following form:
523 |  (select (?x ?y) (is-a ?x ?y)) could return ((Joe Human) (Spot Dog)) and
524 |  (select ((:entity ?x) (:species ?y)) could return
525 |  (((:entity Joe) (:species Human))
526 |   ((:entity Spot)(:species Dog)))"
527 |   (let* ((top-level-query (gensym "PROVE"))
528 | 	 (goals (replace-?-vars goals))
529 | 	 (*functor* (make-functor-symbol top-level-query 0)))
530 |     `(let* ((*trail* (make-array 200 :fill-pointer 0 :adjustable t))
531 | 	    (*var-counter* 0)
532 | 	    (*functor* ',*functor*)
533 | 	    (*select-list* nil)
534 | 	    (functor (make-functor :name *functor* :clauses nil)))
535 |        (unwind-protect
536 | 	    (let ((func
537 | 		   #'(lambda (cont)
538 | 		       (handler-case
539 | 			   (block ,*functor*
540 | 			     .,(maybe-add-undo-bindings
541 | 				(mapcar #'(lambda (clause)
542 | 					    (compile-clause nil clause 'cont))
543 | 					`(((,top-level-query)
544 | 					   ,@goals
545 | 					   (select
546 | 					    ,(mapcar
547 | 					      #'(lambda (var)
548 | 						  (typecase var
549 | 						    (symbol (symbol-name var))
550 | 						    (list (first var))))
551 | 					      vars) ,vars))))))
552 | 			 (undefined-function (condition)
553 | 			   (error 'prolog-error :reason condition))))))
554 | 	      (set-functor-fn *functor* func)
555 | 	      (funcall func #'prolog-ignore))
556 | 	 (delete-functor functor))
557 |        (nreverse *select-list*))))
558 | 
559 | (defmacro select-flat (vars &rest goals)
560 |   `(flatten (select ,vars ,@goals)))
561 | 
562 | (defmacro select-first (vars &rest goals)
563 |   `(first (select ,vars ,@goals !)))
564 | 
565 | (defmacro select-one (vars &rest goals)
566 |   `(first (flatten (select ,vars ,@goals !))))
567 | 
568 | (defmacro do-query (&rest goals)
569 |   `(select () ,@goals))
570 | 
571 | (defmacro map-query (fn query &key collect?)
572 |   "Maps fn over the results of query. collect? will return a list of the
573 |  results of each application of fn."
574 |   (with-gensyms (result)
575 |     (if collect?
576 | 	`(mapcar #'(lambda (,result)
577 | 		     (apply ,fn ,result))
578 | 		 ,query)
579 | 	`(dolist (,result ,query)
580 | 	   (apply ,fn ,result)))))
581 | 
582 | (defun valid-prolog-query? (form)
583 |   (case (first form)
584 |     (select t)
585 |     (select-one t)
586 |     (select-flat t)
587 |     (select-first t)
588 |     (<- t)
589 |     (insertt)
590 |     (otherwise nil)))
591 | 


--------------------------------------------------------------------------------