diff --git a/fact.lisp b/fact.lisp
index 8a35de4..d8f54f5 100644
--- a/fact.lisp
+++ b/fact.lisp
@@ -37,21 +37,22 @@
(deftype fact () '(or fact/v fact/l))
(defun fact-subject (f)
- (if (consp f)
- (first f)
- (svref f 0)))
+ (when f
+ (if (consp f)
+ (first f)
+ (svref f 0))))
(defun fact-predicate (f)
- (declare (type fact f))
- (if (consp f)
- (second f)
- (svref f 1)))
+ (when f
+ (if (consp f)
+ (second f)
+ (svref f 1))))
(defun fact-object (f)
- (declare (type fact f))
- (if (consp f)
- (third f)
- (svref f 2)))
+ (when f
+ (if (consp f)
+ (third f)
+ (svref f 2))))
(defun fact-equal (a b)
(and (equal (fact-subject a) (fact-subject b))
diff --git a/index.lisp b/index.lisp
index 43fc611..bc8964e 100644
--- a/index.lisp
+++ b/index.lisp
@@ -28,16 +28,31 @@
(0 0)))))))
(defun compare-facts-spo (a b)
- (compare/3 (fact-subject a) (fact-predicate a) (fact-object a)
- (fact-subject b) (fact-predicate b) (fact-object b)))
+ (cond
+ ((eq a b) 0)
+ ((null a) -1)
+ ((null b) 1)
+ (t
+ (compare/3 (fact-subject a) (fact-predicate a) (fact-object a)
+ (fact-subject b) (fact-predicate b) (fact-object b)))))
(defun compare-facts-pos (a b)
- (compare/3 (fact-predicate a) (fact-object a) (fact-subject a)
- (fact-predicate b) (fact-object b) (fact-subject b)))
+ (cond
+ ((eq a b) 0)
+ ((null a) -1)
+ ((null b) 1)
+ (t
+ (compare/3 (fact-predicate a) (fact-object a) (fact-subject a)
+ (fact-predicate b) (fact-object b) (fact-subject b)))))
(defun compare-facts-osp (a b)
- (compare/3 (fact-object a) (fact-subject a) (fact-predicate a)
- (fact-object b) (fact-subject b) (fact-predicate b)))
+ (cond
+ ((eq a b) 0)
+ ((null a) -1)
+ ((null b) 1)
+ (t
+ (compare/3 (fact-object a) (fact-subject a) (fact-predicate a)
+ (fact-object b) (fact-subject b) (fact-predicate b)))))
;; Index operations
diff --git a/skip-list.lisp b/skip-list.lisp
index be1c701..3c27f59 100644
--- a/skip-list.lisp
+++ b/skip-list.lisp
@@ -182,7 +182,7 @@ L1: 50%, L2: 25%, L3: 12.5%, ..."
(defstruct usl
(spacing 3 :type (positive-fixnum 2))
- (compare #'compare:compare :type (function (t t) (or t nil)))
+ (compare #'compare:compare :type (function (t t) fixnum))
(head (make-usl-node nil 1) :type usl-node)
(length 0 :type positive-fixnum))
diff --git a/test.lisp b/test.lisp
index 86aad9d..075b385 100644
--- a/test.lisp
+++ b/test.lisp
@@ -13,33 +13,21 @@
(in-package :facts)
-(add ('result 'source ?s)
- (?s 'id "plop")
- (?s 'score 42))
+(facts:add ("Blade Runner" :is-a :movie
+ :director "Ridley Scott"
+ :actor "Harison Ford"
+ :actor "Rutger Hauer")
+ ("Snow White" :is-a :movie
+ :director "William Cottrell"
+ :director "David Hand"))
-(trace replace-bindings collect-bindings% with%)
-(trace make-fact/v fact/v-subject fact/v-predicate fact/v-object)
+(trace with/0 db-each usl-each usl-find)
(with ((?s ?p ?o))
(format t "~&~S ~S ~S~&" ?s ?p ?o))
-(llrbtree:map-tree (lambda (key value)
- (format t "~&~S -> ~S~%" key value))
- (db-pos-tree *db*)
- :START (MAKE-FACT/V NIL nil NIL))
+facts:*db*
-(macroexpand-1
- (third
- (macroexpand-1
- '(with (('result 'source ?p))
- (format t "~S~&" ?p)))))
+(untrace usl-compare)
-(with (('result 'source ?p)
- (?p 'id ?id))
- (return (list ?p ?id)))
-
-(with (('result 'source ?p)
- (?p 'id ?id)
- (?p 'score ?score))
- (format t "~S~%" (list (list ?p 'score ?score)
- (list ?p 'id ?id))))
+(clear-db)
diff --git a/usl.lisp b/usl.lisp
index 3d0a50d..68ee5ca 100644
--- a/usl.lisp
+++ b/usl.lisp
@@ -251,14 +251,15 @@ L1: 50%, L2: 25%, L3: 12.5%, ..."
;; Skip list
(defstruct (usl (:constructor make-usl%))
- (compare-fun nil :type (function (t t) (or t nil)))
+ (compare-fun nil :type (function (t t) fixnum))
(head nil :type usl-node)
(length 0 :type (fixnum* 0))
(spacing nil :type (fixnum-float 1))
(height-fun nil :type (function () (fixnum* 1))))
(defun make-usl (&key (compare #'compare:compare) (height 3) (spacing +e+))
- (make-usl% :compare-fun compare :spacing spacing
+ (make-usl% :compare-fun compare
+ :spacing spacing
:head (make-usl-node nil height)
:height-fun (usl-random-height-fun height spacing)))
@@ -267,10 +268,18 @@ L1: 50%, L2: 25%, L3: 12.5%, ..."
(defun usl-compare (usl a b)
(declare (type usl usl))
- (funcall (the (function (t t) t)
+ (funcall (the (function (t t) fixnum)
(usl-compare-fun usl))
a b))
+(defun usl-compare (usl a b)
+ (declare (type usl usl))
+ (let* ((compare-fun (the (function (t t) fixnum)
+ (usl-compare-fun usl)))
+ (result (funcall compare-fun a b)))
+ (format t "~&USL-COMPARE: ~S ~S ~S => ~S~%" compare-fun a b result)
+ result))
+
;; Find
(defun usl-find (usl value &optional pred)
@@ -285,14 +294,14 @@ PRED if given must be an array, fill it with predecessor usl nodes."
((< level 0))
(do ((n node (usl-node-next n level)))
((or (null n)
- (< -1 (usl-compare usl (usl-node-value n) value))))
+ (not (= -1 (usl-compare usl (usl-node-value n) value)))))
(setf node n))
(when (and pred (< level (length pred)))
(setf (aref pred level) node)))
(let* ((next (usl-node-next node 0))
(found (when next
(let ((next-value (usl-node-value next)))
- (unless (> -1 (usl-compare usl value next-value))
+ (unless (= -1 (usl-compare usl value next-value))
value)))))
found))))
diff --git a/with.lisp b/with.lisp
index 1bf15a7..51f4470 100644
--- a/with.lisp
+++ b/with.lisp
@@ -61,38 +61,25 @@
(eval-when (:compile-toplevel :load-toplevel)
+ (defun with/dispatch (s p o binding-vars body)
+ (let ((var-s (when (binding-p s) (cdr (assoc s binding-vars))))
+ (var-p (when (binding-p p) (cdr (assoc p binding-vars))))
+ (var-o (when (binding-p o) (cdr (assoc o binding-vars)))))
+ (cond ((and var-s var-p var-o) (with/0 var-s var-p var-o body))
+ ((nor var-s var-p var-o) (with/3 s p o body))
+ (t (with/1-2 s p o var-s var-p var-o
+ (cond ((and (null var-s) var-o) 'db-index-spo)
+ ((null var-p) 'db-index-pos)
+ (t 'db-index-osp))
+ body)))))
+
(defun with/iter (spec binding-vars body)
- (destructuring-bind (s p o) spec
- (let ((var-s (when (binding-p s) (cdr (assoc s binding-vars))))
- (var-p (when (binding-p p) (cdr (assoc p binding-vars))))
- (var-o (when (binding-p o) (cdr (assoc o binding-vars)))))
- (cond ((and var-s var-p var-o) (with/0 var-s var-p var-o body))
- ((nor var-s var-p var-o) (with/3 s p o body))
- (t (with/1-2 s p o var-s var-p var-o
- (cond ((and (null var-s) var-o) 'db-index-spo)
- ((null var-p) 'db-index-pos)
- (t 'db-index-osp))
- body))))))
-
- (defun without/iter (spec binding-vars body)
- (destructuring-bind (not s p o) spec
- (assert (eq :not not))
- (let ((var-s (when (binding-p s) (cdr (assoc s binding-vars))))
- (var-p (when (binding-p p) (cdr (assoc p binding-vars))))
- (var-o (when (binding-p o) (cdr (assoc o binding-vars)))))
- (unless (cond ((and var-s var-p var-o)
- (with/0 var-s var-p var-o '(return t)))
- ((nor var-s var-p var-o)
- (with/3 s p o '(return t)))
- (t (with/1-2 s p o var-s var-p var-o
- (cond ((and (null var-s) var-o)
- 'db-index-spo)
- ((null var-p)
- 'db-index-pos)
- (t
- 'db-index-osp))
- '(return t))))
- body)))))
+ (ecase (length spec)
+ ((3) (destructuring-bind (s p o) spec
+ (with/dispatch s p o binding-vars body)))
+ ((4) (destructuring-bind (not s p o) spec
+ (assert (eq :not not))
+ (with/dispatch s p o binding-vars '(return nil)))))))
(defmacro with/rec ((spec &rest more-specs) &body body)
(let* ((bindings (collect-bindings spec))
@@ -110,7 +97,7 @@
,@body)))
(defmacro with (binding-specs &body body)
- `(with/expanded ,(sort-bindings (expand-specs binding-specs))
+ `(with/expanded ,(expand-specs binding-specs)
,@body))
(defmacro bound-p (binding-specs)