index.lisp

(in-package #:vivace-graph-v2)

(defstruct index-cursor index vector pointer)

(defgeneric idx-equal (a b)
  (:method ((a string) (b string)) (string= a b))
  (:method ((a number) (b number)) (= a b))
  (:method ((a symbol) (b symbol)) (eq a b))
  (:method ((a vector) (b vector))
    (when (= (length a) (length b))
      (every #'idx-equal a b)))
  (:method (a b) (equal a b)))

(defun sxhash-idx (item) (sxhash item))

(sb-ext:define-hash-table-test idx-equal sxhash-idx)

;(defun make-idx-table (&key synchronized)
;  (make-hash-table :test 'idx-equal :synchronized synchronized))

(defun cursor-value (cursor &key (transform-fn #'identity))
  (handler-case
      (funcall transform-fn
	       (aref (index-cursor-vector cursor) (index-cursor-pointer cursor)))
    (SB-INT:INVALID-ARRAY-INDEX-ERROR (condition)
      (declare (ignore condition))
      nil)))

(defun cursor-next (cursor &key (transform-fn #'identity))
  (handler-case
      (funcall transform-fn
	       (aref (index-cursor-vector cursor) 
		     (incf (index-cursor-pointer cursor))))
    (SB-INT:INVALID-ARRAY-INDEX-ERROR (condition)
      (declare (ignore condition))
      (decf (index-cursor-pointer cursor))
      nil)))

(defun cursor-prev (cursor &key (transform-fn #'identity))
  (handler-case
      (funcall transform-fn 
	       (aref (index-cursor-vector cursor) 
		     (decf (index-cursor-pointer cursor))))
    (SB-INT:INVALID-ARRAY-INDEX-ERROR (condition)
      (declare (ignore condition))
      (incf (index-cursor-pointer cursor))
      nil)))

(defun cursor-close (cursor)
  (setf (index-cursor-index cursor) nil
	(index-cursor-vector cursor) nil
	(index-cursor-pointer cursor) nil))

(defun map-cursor (fn cursor &key collect?)
  (setf (index-cursor-pointer cursor) 0)
  (let ((result ()))
    (loop for i from 0 to (1- (length (index-cursor-vector cursor))) do
	 (if collect?
	     (push (funcall fn (aref (index-cursor-vector cursor) i)) result)
	     (funcall fn (aref (index-cursor-vector cursor) i))))
    (nreverse result)))
  
(defstruct index name table test)

;;(defun make-hierarchical-index (&key name (test 'idx-equal))
(defun make-hierarchical-index (&key name (test 'eql))
  (make-index :name name
	      :test test
	      :table (make-hash-table :test test :synchronized t)))

(defun hash-table-keys (ht)
  (let ((keys nil))
    (maphash #'(lambda (k v) (declare (ignore v)) (push k keys)) ht)
    keys))

(defun fetch-all-leaves (ht)
  (let ((leaves (make-array 0 :adjustable t :fill-pointer t)))
    (labels ((fetch-all (ht1)
	       (sb-ext:with-locked-hash-table (ht)
		 (maphash #'(lambda (k v)
			      (declare (ignore k))
			      (typecase v
				(hash-table (fetch-all v))
				(list 
				 (dolist (leaf v) (vector-push-extend leaf leaves)))
				(t (vector-push-extend v leaves))))
			  ht1))))
      (fetch-all ht))
    (if (> (length leaves) 0)
	leaves
	nil)))

(defun delete-index-path (index path &key return-values?)
  (let ((vals nil))
    (labels ((descend (ht keys)
	       (if (eq (first keys) '*)
		   (maphash #'(lambda (k v) 
				(declare (ignore k)) 
				(descend v (rest keys))) ht)
		   (multiple-value-bind (value found?) (gethash (first keys) ht)
		     (when found?
		       (if (hash-table-p value)
			   (if (null (rest keys))
			       (progn
				 (when return-values?
				   (maphash #'(lambda (k v) 
						(declare (ignore k)) 
						(push v vals)) 
					    value))
				 (remhash (first keys) ht))
			       (descend value (rest keys)))
			   (remhash (first keys) ht)))))))
      (descend index path))
    vals))

(defun descend-ht (ht keys)
  (assert (not (null keys)) nil "keys must be non-null.")
  (if (eq (first keys) '*)
      (maphash #'(lambda (k v) 
		   (declare (ignore k)) 
		   (if (hash-table-p v)
		       (descend-ht v (rest keys))
		       ()))
	       ht)
      (multiple-value-bind (value found?) (gethash (first keys) ht)
	(if found?
	    (if (hash-table-p value)
		(if (null (rest keys))
		    (fetch-all-leaves value)
		    (descend-ht value (rest keys)))
		(if (null (rest keys))
		    (values (make-array 1 :initial-element value) t)))
	    (values nil nil)))))

(defun get-from-index (index &rest keys)
  (let ((result (descend-ht (index-table index) keys)))
    (cond ((null result) (make-index-cursor :index index :vector #() :pointer 0))
	  ((vectorp result) (make-index-cursor :index index :vector result :pointer 0))
	  (t result))))

(defun find-or-create-ht (ht keys create-fn &optional (d 0))
  (assert (not (null keys)) nil "keys must be non-null.")
  (sb-ext:with-locked-hash-table (ht)
    (multiple-value-bind (value found?) (gethash (first keys) ht)
      (unless (and found? (typep value 'hash-table))
	;;(dotimes (i d) (format t " "))
	;;(format t "Creating HT at key level ~A~%" keys)
	(setf (gethash (first keys) ht) (funcall create-fn)))))
  (cond ((null (rest keys))
	 (values ht (first keys)))
	((= 1 (length (rest keys)))
	 (values (gethash (first keys) ht) (first (rest keys))))
	(t
	 (find-or-create-ht (gethash (first keys) ht) (rest keys) create-fn (1+ d)))))

(defun add-to-index (index value &rest keys)
  (let ((ht (find-or-create-ht (index-table index) 
			       keys 
			       #'(lambda () 
				   (make-hash-table :synchronized t 
						    :test (index-test index))))))
    (setf (gethash (car (last keys)) ht) value)))

(defun delete-from-index (index value &rest keys)
  (declare (ignore index value keys)))

(defmacro with-locked-index ((idx &rest keys) &body body)
  (with-gensyms (sub-idx last-key)
    `(multiple-value-bind (,sub-idx ,last-key)
	 (find-or-create-ht (index-table ,idx)
			    ',keys 
			    #'(lambda ()
				(make-hash-table :synchronized t 
						 :test (index-test ,idx))))
       (sb-ext:with-locked-hash-table (,sub-idx)
	 ;;(format t "Locked ht ~A / ~A~%" ,last-key ,sub-idx)
	 ,@body))))

(defun test-index ()
  (let ((index (make-hierarchical-index)))
    (add-to-index index "abc" "a" "b" "c")
    (add-to-index index "abd" "a" "b" "d")
    (add-to-index index "abe" "a" "b" "e")
    (add-to-index index "abz" "a" "b" "z")
    (add-to-index index "abx" "a" "b" "x")
    (add-to-index index "aby" "a" "b" "y")
    (add-to-index index "acy" "a" "c" "y")
    (add-to-index index "bcy" "b" "c" "y")
    (get-from-index index "a" "b")))