mas01cr@511: (in-package "SB-ADB")
mas01cr@511: 
mas01cr@511: (defclass adb ()
mas01cr@511:   ((alien :initarg alien)))
mas01cr@511: (defmethod initialize-instance :after ((o adb) &key)
mas01cr@511:   (when (and (slot-boundp o 'alien)
mas01cr@511:              (not (null-alien (slot-value o 'alien))))
mas01cr@511:     (let ((alien (slot-value o 'alien)))
mas01cr@511:       (sb-ext:finalize o (lambda () (%close alien))))))
mas01cr@511: 
mas01cr@511: ;;; FIXME: deal with interrupt-safety / leak issues
mas01cr@511: 
mas01cr@511: ;;; FIXME: if-does-not-exist.
mas01cr@511: (defun open (path &key (direction :input) (if-exists :error) (adb-class 'adb))
mas01cr@511:   (flet ((direction-flag (direction)
mas01cr@511:            (ecase direction
mas01cr@511:              ((:input :probe) sb-posix:o-rdonly)
mas01cr@511:              ((:output :io) sb-posix:o-rdwr))))
mas01cr@511:     (let* ((truepath (probe-file path))
mas01cr@511:            (alien (cond
mas01cr@511:                     (truepath
mas01cr@511:                      (ecase direction
mas01cr@511:                        ((:input :probe) 
mas01cr@511:                         (%%open path (direction-flag direction)))
mas01cr@511:                        ((:output :io)
mas01cr@511:                         (case if-exists
mas01cr@511:                           (:error (error "database already exists: ~S" path))
mas01cr@511:                           (:append (%open path (direction-flag direction)))
mas01cr@511:                           ;; FIXME: not the best implementation of
mas01cr@511:                           ;; :SUPERSEDE semantics ever.
mas01cr@511:                           (:supersede (delete-file path) (%create path 0 0 0))))))
mas01cr@511:                     ((eql direction :input)
mas01cr@511:                      (error "database does not exist: ~S" path))
mas01cr@511:                     (t (%create path 0 0 0)))))
mas01cr@511:       (cond
mas01cr@511:         ((null-alien alien)
mas01cr@511:          (case direction
mas01cr@511:            (:probe nil)
mas01cr@511:            (t (error "opening database failed: ~S" path))))
mas01cr@511:         (t (make-instance adb-class 'alien alien))))))
mas01cr@511: (defmethod close ((o adb))
mas01cr@511:   (when (and (slot-boundp o 'alien)
mas01cr@511:              (not (null-alien (slot-value o 'alien))))
mas01cr@511:     (%close (slot-value o 'alien))
mas01cr@511:     (sb-ext:cancel-finalization o)
mas01cr@511:     (slot-makunbound o 'alien)))
mas01cr@511: (defmacro with-adb ((adb path &rest open-args &key direction adb-class if-exists)
mas01cr@511:                     &body body)
mas01cr@511:   (declare (ignore direction adb-class if-exists))
mas01cr@511:   `(let ((,adb (open ,path ,@open-args)))
mas01cr@511:      (unwind-protect
mas01cr@511:           (locally ,@body)
mas01cr@511:        (close ,adb))))
mas01cr@511: 
mas01cr@511: (defgeneric l2norm (db))
mas01cr@511: (defmethod l2norm ((db adb))
mas01cr@511:   (%l2norm (slot-value db 'alien)))
mas01cr@511: 
mas01cr@511: (defstruct (datum
mas01cr@511:              (:constructor %make-datum)
mas01cr@511:              (:constructor 
mas01cr@511:               make-datum 
mas01cr@511:               (key %data &key times power
mas01cr@511:                &aux (data 
mas01cr@511:                      (make-array (list (length %data) (length (elt %data 0)))
mas01cr@511:                                  :element-type 'double-float 
mas01cr@511:                                  :initial-contents %data)))))
mas01cr@511:   (key (error "missing argument") :type string)
mas01cr@511:   (data (error "missing argument") :type (simple-array double-float (* *)))
mas01cr@511:   (times nil :type (or null (simple-array double-float)))
mas01cr@511:   (power nil :type (or null (simple-array double-float))))
mas01cr@511: 
mas01cr@511: (defgeneric insert (datum db))
mas01cr@511: 
mas01cr@511: (defmethod insert ((datum datum) (db adb))
mas01cr@511:   (let* ((data (datum-data datum))
mas01cr@511:          (nvectors (array-dimension data 0))
mas01cr@511:          (dim (array-dimension data 1)))
mas01cr@511:     (when (datum-times datum)
mas01cr@511:       (unless (= (array-total-size (datum-times datum)) (* 2 nvectors))
mas01cr@511:         (error "dimension mismatch for times: ~S" datum)))
mas01cr@511:     (when (datum-power datum)
mas01cr@511:       (unless (= (array-total-size (datum-power datum)) nvectors) 
mas01cr@511:         (error "dimension mismatch for power: ~S" datum)))
mas01cr@511:     (with-alien ((d adb-datum-t))
mas01cr@511:       (sb-sys:with-pinned-objects ((datum-data datum)
mas01cr@511:                                    (datum-times datum)
mas01cr@511:                                    (datum-power datum))
mas01cr@511:         (setf (slot d 'dim) dim)
mas01cr@511:         (setf (slot d 'nvectors) nvectors)
mas01cr@511:         (setf (slot d 'key) (datum-key datum))
mas01cr@511:         (setf (slot d 'data) 
mas01cr@511:               (sb-sys:vector-sap (sb-ext:array-storage-vector (datum-data datum))))
mas01cr@511:         (if (datum-times datum)
mas01cr@511:             (setf (slot d 'times) (sb-sys:vector-sap (sb-ext:array-storage-vector (datum-times datum))))
mas01cr@511:             (setf (slot d 'times) nil))
mas01cr@511:         (if (datum-power datum)
mas01cr@635:             (setf (slot d 'power) (sb-sys:vector-sap (sb-ext:array-storage-vector (datum-power datum))))
mas01cr@511:             (setf (slot d 'power) nil))
mas01cr@511:         (sb-int:with-float-traps-masked (:invalid)
mas01cr@511:           (%insert-datum (slot-value db 'alien) (addr d)))))))
mas01cr@580: 
mas01cr@580: (defgeneric retrieve (key db))
mas01cr@580: 
mas01cr@580: (defmethod retrieve ((key string) (db adb))
mas01cr@580:   ;; KLUDGE: this does multiple copies of the floating point data:
mas01cr@580:   ;; once within audiodb_retrieve_datum(), and once from the alien to
mas01cr@580:   ;; the lisp arrays.  Oh well.
mas01cr@580:   (with-alien ((d adb-datum-t))
mas01cr@580:     (setf (slot d 'times) nil
mas01cr@580:           (slot d 'power) nil)
mas01cr@580:     (%retrieve-datum (slot-value db 'alien) key (addr d))
mas01cr@580:     (let* ((dim (slot d 'dim))
mas01cr@580:            (nvectors (slot d 'nvectors))
mas01cr@580:            (data (make-array (list nvectors dim) :element-type 'double-float))
mas01cr@580:            (vector (sb-ext:array-storage-vector data))
mas01cr@580:            ;; FIXME: this shares KEY
mas01cr@580:            (datum (%make-datum :key key :data data)))
mas01cr@636:       (flet ((system-area-dfloat-copy (from-sap from-offset to-sap to-offset ndfloats)
mas01cr@636:                ;; FIXME: the horror
mas01cr@636:                #+#.(cl:if (cl:= sb-vm:n-word-bits 64) '(:and) '(:or))
mas01cr@636:                (sb-kernel:system-area-ub64-copy
mas01cr@636:                 from-sap from-offset to-sap to-offset ndfloats)
mas01cr@636:                #-#.(cl:if (cl:= sb-vm:n-word-bits 64) '(:and) '(:or))
mas01cr@636:                (sb-kernel:system-area-ub32-copy 
mas01cr@636:                 from-sap from-offset to-sap to-offset (* 2 ndfloats))))
mas01cr@636:         (system-area-dfloat-copy (alien-sap (slot d 'data)) 0
mas01cr@636:                                  (sb-sys:vector-sap vector) 0
mas01cr@636:                                  (* dim nvectors))
mas01cr@636:         (unless (null-alien (slot d 'times))
mas01cr@636:           (let ((times (make-array (* 2 nvectors) :element-type 'double-float)))
mas01cr@636:             (system-area-dfloat-copy (alien-sap (slot d 'times)) 0
mas01cr@636:                                      (sb-sys:vector-sap times) 0
mas01cr@636:                                      (* 2 nvectors))
mas01cr@636:             (setf (datum-times datum) times)))
mas01cr@636:         (unless (null-alien (slot d 'power))
mas01cr@636:           (let ((power (make-array nvectors :element-type 'double-float)))
mas01cr@636:             (system-area-dfloat-copy (alien-sap (slot d 'power)) 0
mas01cr@636:                                      (sb-sys:vector-sap power) 0
mas01cr@636:                                      nvectors)
mas01cr@636:             (setf (datum-power datum) power)))
mas01cr@636:         (%free-datum (slot-value db 'alien) (addr d))
mas01cr@636:         datum))))
mas01cr@511: 
mas01cr@511: (defstruct result
mas01cr@672:   (qkey "" :type string)
mas01cr@672:   (ikey "" :type string)
mas01cr@511:   (distance 0d0 :type double-float)
mas01cr@511:   (qpos 0 :type (and unsigned-byte fixnum))
mas01cr@511:   (ipos 0 :type (and unsigned-byte fixnum)))
mas01cr@511: 
mas01cr@511: ;;; Hrm.  To copy (from the malloc heap) or not to copy?  Copying
mas01cr@511: ;;; would make things generally easier, I guess, and we have to hope
mas01cr@511: ;;; that the order of magnitude is not such that the copying causes
mas01cr@511: ;;; pain.
mas01cr@511: (defclass results (sequence standard-object)
mas01cr@511:   ())
mas01cr@511: (defclass copied-query-results (results)
mas01cr@511:   ((results :initarg results :accessor %copied-results)))
mas01cr@511: (defmethod print-object ((o copied-query-results) s)
mas01cr@511:   (pprint-logical-block (s nil)
mas01cr@511:     (print-unreadable-object (o s :type t)
mas01cr@511:       (format s "(~D results):~2I~@:_" (length o))
mas01cr@511:       (sequence:dosequence (r o)
mas01cr@511:         (pprint-pop)
mas01cr@511:         (format s "~A ~6,3e ~D ~D~@:_"
mas01cr@672:                 (result-ikey r) (result-distance r)
mas01cr@511:                 (result-qpos r) (result-ipos r))))))
mas01cr@511:       
mas01cr@511: (defmethod sequence:length ((o copied-query-results))
mas01cr@511:   (length (%copied-results o)))
mas01cr@511: (defmethod sequence:elt ((o copied-query-results) index)
mas01cr@511:   (elt (%copied-results o) index))
mas01cr@511: (defmethod (setf sequence:elt) (new-value (o copied-query-results) index)
mas01cr@511:   (setf (elt (%copied-results o) index) new-value))
mas01cr@511: (defmethod sequence:make-sequence-like 
mas01cr@511:     ((o copied-query-results) length &rest args 
mas01cr@511:      &key initial-element initial-contents)
mas01cr@511:   (declare (ignore initial-element initial-contents))
mas01cr@511:   (let ((vector (apply #'make-array length args)))
mas01cr@511:     (make-instance 'copied-query-results 'results vector)))
mas01cr@511: (defmethod sequence:adjust-sequence
mas01cr@511:     ((o copied-query-results) length &rest args
mas01cr@511:      &key initial-element initial-contents)
mas01cr@511:   (declare (ignore initial-element initial-contents))
mas01cr@511:   (let ((results (%copied-results o)))
mas01cr@511:     (apply #'sequence:adjust-sequence results length args))
mas01cr@511:   o)
mas01cr@511: 
mas01cr@511: (defclass proxied-query-results (results)
mas01cr@511:   ((adb :initarg adb)
mas01cr@511:    (spec :initarg spec)
mas01cr@511:    (results :initarg results)))
mas01cr@511: (defmethod initialize-instance :after ((o proxied-query-results) &key)
mas01cr@511:   (when (and (slot-boundp o 'results)
mas01cr@511:              (not (null-alien o))
mas01cr@511:              (slot-boundp o 'spec))
mas01cr@511:     (with-slots (results spec adb) o
mas01cr@511:       (flet ((results-finalizer ()
mas01cr@511:                (with-slots (alien) adb
mas01cr@511:                  (%free-query-results alien spec results))))
mas01cr@511:         (sb-ext:finalize o #'results-finalizer)))))
mas01cr@511: 
mas01cr@511: (defgeneric query (datum db &key))
mas01cr@511: 
mas01cr@511: ;;; FIXME: I don't like this way of generalizing the boilerplate;
mas01cr@511: ;;; isn't there a nice functional way of doing this?
mas01cr@511: (macrolet 
mas01cr@511:     ((def (name datum-class &body qdatum-forms)
mas01cr@511:        `(defmethod ,name ((datum ,datum-class) (db adb) &key 
mas01cr@511:                           (sequence-length 1) (sequence-start 0)
mas01cr@511:                           exhaustivep accumulation distance
mas01cr@511:                           ;; FIXME: dubious historical defaults
mas01cr@511:                           (npoints 10) (ntracks 10)
mas01cr@511: 
mas01cr@511:                           (radius nil radiusp)
mas01cr@511:                           (include-keys nil include-keys-p)
mas01cr@677:                           (exclude-keys nil exclude-keys-p)
mas01cr@677:                           (query-hop 1 query-hop-p)
mas01cr@677:                           (db-hop 1 db-hop-p))
mas01cr@511:           (unless (slot-boundp db 'alien)
mas01cr@511:             (error "database ~S is closed" db))
mas01cr@511:          (with-alien ((qid adb-query-id-t)
mas01cr@511:                       (qparams adb-query-parameters-t)
mas01cr@511:                       (qrefine adb-query-refine-t)
mas01cr@511:                       (qdatum adb-datum-t))
mas01cr@511:            ,@qdatum-forms
mas01cr@511:            (setf (slot qid 'datum) (addr qdatum))
mas01cr@511:            (setf (slot qid 'sequence-length) sequence-length)
mas01cr@511:            (setf (slot qid 'sequence-start) sequence-start)
mas01cr@511:            (setf (slot qid 'flags) (if exhaustivep 1 0))
mas01cr@511: 
mas01cr@511:            (setf (slot qparams 'accumulation)
mas01cr@511:                  (ecase accumulation
mas01cr@511:                    (:db 1)
mas01cr@511:                    (:per-track 2)
mas01cr@511:                    (:one-to-one 3)))
mas01cr@511:            (setf (slot qparams 'distance)
mas01cr@511:                  (ecase distance
mas01cr@511:                    (:dot-product 1)
mas01cr@511:                    (:euclidean-normed 2)
mas01cr@511:                    (:euclidean 3)))
mas01cr@511:            (setf (slot qparams 'npoints) (or npoints 0))
mas01cr@511:            (setf (slot qparams 'ntracks) (or ntracks 0))
mas01cr@511: 
mas01cr@511:            (let ((refine-flags 0))
mas01cr@511:              (when radiusp 
mas01cr@511:                (setf refine-flags (logior refine-flags 4))
mas01cr@511:                (setf (slot qrefine 'radius) (float radius 0d0)))
mas01cr@511:              ;; FIXME: the freeing of the KEYS slot in these
mas01cr@511:              ;; include/exclude keylists isn't interrupt-safe.
mas01cr@511:              ;;
mas01cr@511:              ;; FIXME: think quite hard about the behaviour of this
mas01cr@511:              ;; when LENGTH is 0.
mas01cr@511:              (when include-keys-p
mas01cr@511:                (setf refine-flags (logior refine-flags 1))
mas01cr@511:                (let ((length (length include-keys)))
mas01cr@511:                  (setf (slot (slot qrefine 'include) 'nkeys) length)
mas01cr@511:                  (let ((keys (make-alien c-string length)))
mas01cr@511:                    (setf (slot (slot qrefine 'include) 'keys) keys)
mas01cr@511:                    (loop for key being the elements of include-keys
mas01cr@511:                          for i upfrom 0
mas01cr@511:                          do (setf (deref keys i) key)))))
mas01cr@511:              (when exclude-keys-p
mas01cr@511:                (setf refine-flags (logior refine-flags 2))
mas01cr@511:                (let ((length (length exclude-keys)))
mas01cr@511:                  (setf (slot (slot qrefine 'exclude) 'nkeys) length)
mas01cr@511:                  (let ((keys (make-alien c-string length)))
mas01cr@511:                    (setf (slot (slot qrefine 'exclude) 'keys) keys)
mas01cr@511:                    (loop for key being the elements of exclude-keys
mas01cr@511:                          for i upfrom 0
mas01cr@511:                          do (setf (deref keys i) key)))))
mas01cr@677:              (when (or query-hop-p db-hop-p)
mas01cr@677:                (setf refine-flags (logior refine-flags 64))
mas01cr@677:                (setf (slot qrefine 'qhopsize) query-hop
mas01cr@677:                      (slot qrefine 'ihopsize) db-hop))
mas01cr@511:              (setf (slot qrefine 'flags) refine-flags))
mas01cr@511:            
mas01cr@511:            ;; FIXME: hm, this possibly suggests that there's something
mas01cr@511:            ;; a bit wrong with the C audioDB interface.  The API
mas01cr@511:            ;; currently exposed effectively requires either that all
mas01cr@511:            ;; the processing of query results happens in the same
mas01cr@511:            ;; dynamic extent as the call to audiodb_query_spec(), or
mas01cr@511:            ;; that the adb_query_spec_t object is allocated on the
mas01cr@511:            ;; heap.  We need to think harder about whether the spec
mas01cr@511:            ;; argument is really required (I think it probably isn't).
mas01cr@511:            ;;
mas01cr@511:            ;; meanwhile, here we're using it with dynamic extent anyway, so
mas01cr@511:            ;; we could put it right back on the stack.
mas01cr@511:            (let ((qspec (make-alien adb-query-spec-t)))
mas01cr@511:              (unwind-protect
mas01cr@511:                   (progn
mas01cr@511:                     (setf (slot qspec 'qid) qid)
mas01cr@511:                     (setf (slot qspec 'params) qparams)
mas01cr@511:                     (setf (slot qspec 'refine) qrefine)
mas01cr@511:                     
mas01cr@511:                     (let ((results 
mas01cr@511:                            (sb-int:with-float-traps-masked (:invalid)
mas01cr@511:                              (%query (slot-value db 'alien) qspec))))
mas01cr@511:                       (flet ((collect-copied-results ()
mas01cr@511:                                (let ((nresults (slot results 'nresults))
mas01cr@511:                                      (cresults (slot results 'results)))
mas01cr@511:                                  (coerce 
mas01cr@511:                                   (loop for i below nresults
mas01cr@511:                                         for r = (deref cresults i)
mas01cr@511:                                         collect (make-result 
mas01cr@672:                                                  :ikey (slot r 'ikey) 
mas01cr@672:                                                  :qkey (slot r 'qkey) 
mas01cr@511:                                                  :distance (slot r 'dist)
mas01cr@511:                                                  :qpos (slot r 'qpos) 
mas01cr@511:                                                  :ipos (slot r 'ipos)))
mas01cr@511:                                   'vector))))
mas01cr@511:                         (unwind-protect
mas01cr@511:                              (make-instance 'copied-query-results
mas01cr@511:                                             'results (collect-copied-results))
mas01cr@511:                           (%free-query-results (slot-value db 'alien) qspec results)))))
mas01cr@511:                (when (logbitp 0 (slot (slot qspec 'refine) 'flags))
mas01cr@511:                  (free-alien (slot (slot (slot qspec 'refine) 'include) 'keys)))
mas01cr@511:                (when (logbitp 1 (slot (slot qspec 'refine) 'flags))
mas01cr@511:                  (free-alien (slot (slot (slot qspec 'refine) 'exclude) 'keys)))
mas01cr@511:                (free-alien qspec)))))))
mas01cr@647:   (def query string (setf (slot qdatum 'key) datum
mas01cr@647:                           (slot qdatum 'data) nil))
mas01cr@511:   (def query datum 
mas01cr@511:     (setf (slot qdatum 'key) (datum-key datum))
mas01cr@511:     (setf (slot qdatum 'dim) (array-dimension (datum-data datum) 1))
mas01cr@511:     (setf (slot qdatum 'nvectors) (array-dimension (datum-data datum) 0))
mas01cr@511:     (setf (slot qdatum 'data) (sb-sys:vector-sap (sb-ext:array-storage-vector (datum-data datum))))
mas01cr@511:     (if (datum-times datum)
mas01cr@511:         (setf (slot qdatum 'times) (sb-sys:vector-sap (sb-ext:array-storage-vector (datum-times datum))))
mas01cr@511:         (setf (slot qdatum 'times) nil))
mas01cr@511:     (if (datum-power datum)
mas01cr@511:         (setf (slot qdatum 'power) (sb-sys:vector-sap (sb-ext:array-storage-vector (datum-times datum))))
mas01cr@511:         (setf (slot qdatum 'power) nil))))
mas01cr@511: 
mas01cr@646: (defgeneric liszt (adb))
mas01cr@646: (defmethod liszt ((db adb))
mas01cr@646:   (let ((results (%liszt (slot-value db 'alien))))
mas01cr@646:     (unwind-protect
mas01cr@646:          (loop for i below (slot results 'nresults)
mas01cr@646:                with entries = (slot results 'entries)
mas01cr@646:                for entry = (deref entries i)
mas01cr@646:                collect (cons (slot entry 'key) (slot entry 'nvectors)))
mas01cr@646:       (%free-liszt-results (slot-value db 'alien) results))))
mas01cr@646:       
mas01cr@511: #+test
mas01cr@511: (sb-adb:with-adb (db "/home/csr21/tmp/omras2-workshop/9.adb")
mas01cr@511:   (sb-adb:query "KSA_CHARM_337" db :exhaustivep t :sequence-length 30 
mas01cr@511:                 :accumulation :per-track :distance :euclidean :npoints 1 :ntracks 20))
mas01cr@511: 
mas01cr@511: #+test
mas01cr@511: (sb-adb:with-adb (db "/home/csr21/tmp/omras2-workshop/9.adb")
mas01cr@511:   (sb-adb:query "KSA_CHARM_337" db :sequence-start 20 :sequence-length 20
mas01cr@511:                 :accumulation :per-track :distance :euclidean-normed
mas01cr@511:                 :npoints 10 :ntracks 1))
mas01cr@511: 
mas01cr@511: #+test
mas01cr@511: (sb-adb:with-adb (db "/home/csr21/tmp/omras2-workshop/9.adb")
mas01cr@511:   (sb-adb:query "KSA_CHARM_337" db 
mas01cr@511:                 :exhaustivep t :sequence-length 30
mas01cr@511:                 :accumulation :per-track :distance :euclidean-normed 
mas01cr@511:                 :npoints 2 :ntracks 10))
mas01cr@511: 
mas01cr@511: ;;; only hacks and tests below
mas01cr@511: #|
mas01cr@511: (defun foo ()
mas01cr@511:   (let ((db (%open "/home/csr21/tmp/omras2-workshop/9.adb" sb-posix:o-rdonly)))
mas01cr@511:     (unless (null-alien db)
mas01cr@511:       (unwind-protect
mas01cr@511:            (with-alien ((status adb-status-t))
mas01cr@511:            (%status db (addr status))
mas01cr@511:            (print (list (slot status 'dim) (slot status 'nfiles))))
mas01cr@511:         (%close db)))))
mas01cr@511: 
mas01cr@511: (defun set-up-spec (spec qid qparams qrefine)
mas01cr@511:   (declare (type (alien adb-query-parameters-t) qparams)
mas01cr@511:            (type (alien adb-query-refine-t) qrefine)
mas01cr@511:            (type (alien adb-query-id-t) qid)
mas01cr@511:            (type (alien adb-query-spec-t) spec))
mas01cr@511:   (setf (slot spec 'refine) qrefine)
mas01cr@511:   nil)
mas01cr@511: 
mas01cr@511: (defun bar ()
mas01cr@511:   (let ((db (%open "/home/csr21/tmp/omras2-workshop/9.adb" sb-posix:o-rdonly)))
mas01cr@511:     (unless (null-alien db)
mas01cr@511:       (unwind-protect
mas01cr@511:            (with-alien ((qid adb-query-id-t)
mas01cr@511:                         (qparams adb-query-parameters-t)
mas01cr@511:                         (qrefine adb-query-refine-t)
mas01cr@511:                         (qspec adb-query-spec-t)
mas01cr@511:                         (datum adb-datum-t))
mas01cr@511:              (setf (slot datum 'key) "KSA_CHARM_337")
mas01cr@511:              (setf (slot datum 'data) (sap-alien (sb-sys:int-sap 0) (* double)))
mas01cr@511:              
mas01cr@511:              (setf (slot qid 'datum) (addr datum))
mas01cr@511:              (setf (slot qid 'sequence-length) 30)
mas01cr@511:              (setf (slot qid 'flags) 1) ; ADB_QID_FLAG_EXHAUSTIVE
mas01cr@511:              
mas01cr@511:              (setf (slot qparams 'accumulation) 2) ; ADB_ACCUMULATION_PER_TRACK
mas01cr@511:              (setf (slot qparams 'distance) 2) ; ADB_DISTANCE_EUCLIDEAN_NORMED
mas01cr@511:              (setf (slot qparams 'npoints) 1)
mas01cr@511:              (setf (slot qparams 'ntracks) 20)
mas01cr@511:              
mas01cr@511:              (setf (slot qrefine 'flags) 0)
mas01cr@511:              (setf (slot qrefine 'hopsize) 1)
mas01cr@511:              
mas01cr@511:              (setf (slot qspec 'qid) qid)
mas01cr@511:              (setf (slot qspec 'params) qparams)
mas01cr@511:              (setf (slot qspec 'refine) qrefine)
mas01cr@511:              (let ((results (%query db (addr qspec))))
mas01cr@511:                (unless (null-alien results)
mas01cr@511:                  (unwind-protect
mas01cr@511:                       (flet ((print-result (n)
mas01cr@511:                                (let ((result (deref (slot results 'results) n)))
mas01cr@511:                                  (format t "~&~A ~F ~D ~D~%"
mas01cr@511:                                          (slot result 'key) (slot result 'dist)
mas01cr@511:                                          (slot result 'qpos) (slot result 'ipos)))))
mas01cr@511:                         (dotimes (i (slot results 'nresults))
mas01cr@511:                           (print-result i)))
mas01cr@511:                    (%free-query-results db (addr qspec) results)))))
mas01cr@511:         (%close db)))))
mas01cr@511: |#