diff bindings/sb-alien/tests.lisp @ 511:3141e51cb077

Initial checkin of WIP sb-alien bindings.

Includes some analogues to libtests/ test files in tests.lisp

Coverage of the C API is not complete, but I think there's enough to
implement all the same functionality tests as there are in the libtests/
suite.

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/bindings/sb-alien/tests.lisp	Wed Jan 21 21:48:25 2009 +0000
@@ -0,0 +1,136 @@
+(in-package "SB-ADB")
+
+(define-symbol-macro %default-query-args nil)
+(defmacro with-default-query-args (args &body body &environment env)
+  (let ((current-args (macroexpand '%default-query-args env)))
+    `(symbol-macrolet ((%default-query-args ,(append args current-args)))
+       ,@body)))
+
+(defmacro with-query-result-assertions 
+    ((query db &rest query-args) &body body &environment env)
+  (let ((results (gensym "RESULTS"))
+        (default-args (macroexpand '%default-query-args env)))
+    `(let* ((,results (query ,query ,db ,@query-args ,@default-args))
+            (length (length ,results)))
+       (flet ((%present (list)
+                (find-if (lambda (r)
+                           (and
+                            (string= (first list) (result-key r))
+                            (< (abs (- (second list) (result-distance r))) 1e-4)
+                            (= (third list) (result-qpos r))
+                            (= (fourth list) (result-ipos r))))
+                         ,results)))
+         (declare (ignorable #'%present))
+         (macrolet ((present (&rest forms)
+                      `(and ,@(loop for f in forms collect `(%present ',f)))))
+           ,@(loop for b in body collect `(assert ,b)))))))
+
+(defmacro with-asserted-query-results ((query db &rest query-args) &body body)
+  `(with-query-result-assertions (,query ,db ,@query-args)
+     (= length ,(length body))
+     (present ,@body)))
+
+(declaim (optimize debug))
+
+(defun test-0003 ()
+  (let ((datum (make-datum "testfeature" '((1d0)))))
+    (with-adb (db "testdb.0003" :direction :output :if-exists :supersede)
+      (l2norm db)
+      (insert datum db)
+      (with-asserted-query-results
+          (datum db :npoints 10 :accumulation :db :distance :dot-product)
+        ("testfeature" 1 0 0)))))
+
+(defun test-0004 ()
+  (let ((feature (make-datum "testfeature" '((0d0 1d0) (1d0 0d0))))
+        (query05 (make-datum "testquery" '((0d0 0.5d0))))
+        (query50 (make-datum "testquery" '((0.5d0 0d0)))))
+    (with-adb (db "testdb.0004" :direction :output :if-exists :supersede)
+      (l2norm db)
+      (insert feature db)
+      (with-default-query-args (:accumulation :db :distance :dot-product)
+        (with-asserted-query-results (query05 db :npoints 10)
+          ("testfeature" 0.5 0 0) ("testfeature" 0 0 1))
+        (with-asserted-query-results (query05 db :npoints 1)
+          ("testfeature" 0.5 0 0))
+        (with-asserted-query-results (query50 db :npoints 10)
+          ("testfeature" 0.5 0 1) ("testfeature" 0 0 0))
+        (with-asserted-query-results (query50 db :npoints 1)
+          ("testfeature" 0.5 0 1))))))
+
+(defun test-0010 ()
+  (let ((feature01 (make-datum "testfeature01" '((0d0 1d0))))
+        (feature10 (make-datum "testfeature10" '((1d0 0d0))))
+        (query05 (make-datum "testquery" '((0d0 0.5d0))))
+        (query50 (make-datum "testquery" '((0.5d0 0d0)))))
+    (with-adb (db "testdb.0010" :direction :output :if-exists :supersede)
+      (insert feature01 db)
+      (insert feature10 db)
+      (l2norm db)
+      (with-default-query-args
+          (:accumulation :per-track :ntracks 10 :npoints 10 :distance :euclidean-normed)
+        (with-asserted-query-results (query05 db)
+          ("testfeature01" 0 0 0) ("testfeature10" 2 0 0))
+        (with-asserted-query-results (query05 db :radius 5)
+          ("testfeature01" 0 0 0) ("testfeature10" 2 0 0))
+        (with-asserted-query-results (query05 db :radius 1)
+          ("testfeature01" 0 0 0))
+        (with-asserted-query-results (query50 db)
+          ("testfeature01" 2 0 0) ("testfeature10" 0 0 0))
+        (with-asserted-query-results (query50 db :radius 5)
+          ("testfeature01" 2 0 0) ("testfeature10" 0 0 0))
+        (with-asserted-query-results (query50 db :radius 1)
+          ("testfeature10" 0 0 0))))))
+
+(defun test-0031 ()
+  (let ((feature01 (make-datum "testfeature01" '((0d0 1d0))))
+        (feature10 (make-datum "testfeature10" '((1d0 0d0))))
+        (query05 (make-datum "testquery" '((0d0 0.5d0)))))
+    (with-adb (db "testdb.0031" :direction :output :if-exists :supersede)
+      (insert feature01 db)
+      (insert feature10 db)
+      (l2norm db)
+      (with-default-query-args 
+          (:accumulation :per-track :ntracks 10 :npoints 10 :distance :euclidean-normed)
+        (with-asserted-query-results (query05 db)
+          ("testfeature01" 0 0 0) ("testfeature10" 2 0 0))
+        (with-asserted-query-results (query05 db :include-keys ()))
+        (with-asserted-query-results (query05 db :include-keys '("testfeature01"))
+          ("testfeature01" 0 0 0))
+        (with-asserted-query-results (query05 db :include-keys '("testfeature10"))
+          ("testfeature10" 2 0 0))
+        (with-asserted-query-results (query05 db :include-keys '("testfeature10" "testfeature01"))
+          ("testfeature01" 0 0 0) ("testfeature10" 2 0 0))
+
+        (with-asserted-query-results (query05 db :exclude-keys '("testfeature10" "testfeature01")))        
+
+        (with-asserted-query-results (query05 db :exclude-keys '("testfeature01"))
+          ("testfeature10" 2 0 0))
+        (with-asserted-query-results (query05 db :exclude-keys '("testfeature10"))
+          ("testfeature01" 0 0 0))
+        (with-asserted-query-results (query05 db :exclude-keys ())
+          ("testfeature01" 0 0 0) ("testfeature10" 2 0 0))))))
+
+(defun test-0036 ()
+  (let ((feature01 (make-datum "testfeature01" '((0d0 1d0) (1d0 0d0))))
+        (feature10 (make-datum "testfeature10" '((1d0 0d0) (0d0 1d0))))
+        (query05 (make-datum "testquery" '((0d0 0.5d0))))
+        (query50 (make-datum "testquery" '((0.5d0 0d0)))))
+    (with-adb (db "testdb.0036" :direction :output :if-exists :supersede)
+      (insert feature01 db)
+      (insert feature10 db)
+      (l2norm db)
+      (with-default-query-args 
+          (:accumulation :per-track :ntracks 10 :distance :euclidean-normed)
+        (dolist (npoints '(10 2 5))
+          (with-asserted-query-results (query05 db :npoints npoints)
+            ("testfeature01" 0 0 0) ("testfeature01" 2 0 1)
+            ("testfeature10" 0 0 1) ("testfeature10" 2 0 0)))
+        (with-asserted-query-results (query05 db :npoints 1)
+          ("testfeature01" 0 0 0) ("testfeature10" 0 0 1))
+        (dolist (npoints '(10 2 5))
+          (with-asserted-query-results (query50 db :npoints npoints)
+            ("testfeature01" 0 0 1) ("testfeature01" 2 0 0)
+            ("testfeature10" 0 0 0) ("testfeature10" 2 0 1)))
+        (with-asserted-query-results (query50 db :npoints 1)
+          ("testfeature01" 0 0 1) ("testfeature10" 0 0 0))))))