;; 10/27/08  hacking r3tree.lisp to make faster
;;;  exponents and coefficients are FIXNUMS
;;; DANGEROUS.  Generally works but arrays can overflow/ error.
;;; NOT MUCH FASTER, EITHER.
;;; maybe fixed? 10/28

;;; Like rtree, but terminal nodes can either be full array or array
;;; of length 2, adjustable.  if the entry is isolated, e.g. a short
;;; tree with a very long extra key, the length-2 array will just
;;; store [key , value] if/until some other key makes it necessary to
;;; expand out.

;;; just starting this, oct 26 2008.
;;; is this going to work???

 ;;; A multi-way tree for storing sparse indexed items. Although I just
;;; made this up, it looks like it is basically around in the
;;; literature, sometimes called a radix tree or a crit bit tree.  It
;;; is an alternative to a hash table or an array, and is, in some
;;; sense, a data structure that can be made more array-like or more
;;; tree-like. The index or key is always an integer, perhaps a
;;; bignum.

;;; The size of the nodes is parameterized: each internal node is a
;;; small array, say of length 8 =2^logsize Then <key, data> is
;;; stored in a node by decomposing the key into 3 =logsize bits at
;;; a time per layer in tree.  thus 30-bit keys will have depth 10
;;; max.  The initial sub-keys are the rightmost bits, and the remaining
;;; keys are computed by shifting the keys by logsize at each level.

;;; The key is never in fact stored in the tree, but computed by position.
;;; There is one subtlety worth noting. 

;;; Note that with logsize 3, we can store items with keys
;;; [0,1,...,7] in the topmost node.  If we need to store an item with
;;; key 9, it has the same trailing 3 bits as 1. To accomodate, we
;;; move the 1 down exactly one level.  That is, the topmost node
;;; looks like [0,p,...,7] where p=[1,9,nil,nil...nil].

;;; so an key like 1  be at the top level (or maybe 1 down).

;;; CON: Keys must be integers or mapped to integers.  Traversing the
;;; tree "in order" is tricky. Numerically adjacent keys will not be
;;; adjacent in the tree, except in the trivial case where all keys
;;; fit in one node.  Nodes may be largely empty.  A key with N bits
;;; will take about (N/logsize) probes.

;;; PRO: we need not know how long the longest key is, which would be
;;; the case if we were using a string-type decomposition starting
;;; from the left.  Short keys will be located near the top of the
;;; tree. The keys are not stored, saving space. By increasing logsize
;;; we can make the performance closer to that of an array.  We never
;;; compare keys; we only extract sub-keys and use them as indexes
;;; into arrays.

;;; author RJF June 13, 2008

;;; caution. some comments were not fixed from previous version.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (declaim (optimize (speed 3)(safety 0)))
 ;;   (defconstant logsize 5)		; intermediate node will have 2^logsize slots
  (defconstant logsize 3)		; best for debugging, not bad for running some tests.
)

(defun init-rtree(key val) ;; always make full array; truncate it initially
  (let ((ans (init-rtree-mt)))
    (setf (aref ans 0) key (aref ans 1) val (aref ans #.(expt 2 logsize)) -1 )
    ans))

(defun init-rtree-mt()			; empty rtree
   (make-array #.(1+(expt 2 logsize)) :element-type 'fixnum :initial-element 0))
       
(defmacro leafp(x) `(numberp ,x))
(defmacro nodep(x) `(arrayp ,x))

;; initially
;; (setf mt (init-rtree-mt))


(defparameter *debug* nil)

(defun insert-rtree(key val tree &aux node)
  (declare(fixnum key val)(type (simple-array fixnum (*)) tree))
  (cond ((= -1 (aref tree #.(expt 2 logsize)))		; it is a single-entry node
	 (cond ((= key (aref tree 0))
		(setf (aref tree 1) val)) ;; case where key matches exactly. replace value
	       (t
		(setf (aref tree #.(expt 2 logsize)) 0) ;expand the node
		(let ((oldkey (aref tree 0))
		      (oldval (aref tree 1)))
		  (setf (aref tree 0) 0)
		  (setf (aref tree 1) 0)
;;		  (if *debug*   (format t "~% oldkey= ~s key=~s tree=~s" oldkey key tree))
		  (setf tree(insert-rtree oldkey oldval tree)) ; re-insert the old key ;ok
;;		  (if *debug*  (format t "~%  tree=~s" tree))
		  (insert-rtree key val tree)
	 ;;  (format t "~%  tree=~s" tree)
	   ))))
	;; the node (i.e. tree) is array >2 in length
	;; the key is small enough to fit in this array
	((< key #.(expt 2 logsize))
	 ;; we have found the level, or level-1 for the key.
	 (cond ((nodep (setf node (aref tree key))) ; not a leaf
		;; if a node here, must descend one level further in tree; key now is 0
		(insert-rtree 0 val node)); and update that node's location 0.
	       (t 
;;		(if *debug* (format t "~%case 1 key=~s" key))
		(setf (aref tree key) val))));; put it here.
	;;The key has too many bits to insert at this level. 
	;;Compute the subkey and separate the rest of the key by masking and shifting.
	(t (let ((ind(logand key #.(1- (expt 2 logsize))));rightmost logsize bits
		 (newkey (ash key #.(- logsize)))
		 )			; reduced key
;;	     (if *debug* (format t "~%case 2, newkey=~s ind=~s tree=~s" newkey ind tree))
	     (setf node (aref tree ind))
	     (cond((nodep node) (setf (aref tree ind) (insert-rtree newkey val node)))
		  (t ;; a single item, must be moved
		   (let ()
		     (setf (aref tree ind) (init-rtree newkey  val))
		    ;;  (insert-rtree thiskey thisval node)
		      (unless (= node 0)(insert-rtree ind node tree)) ;; re-insert 
		     ))))))

  tree)
(defvar *m nil)
(defun ir (i j)(insert-rtree i j *m))
(defun t2()(setf *m (init-rtree-mt))(ir 1000 1000)(ir 2000 2000) (ir 1002 10002) (ordertree-nz *m))

(defun query-rtree(key tree) ;; returns 0 if no entry in the tree for that key
  (cond 
   ((leafp tree) 0)
   ((= -1 (aref tree #.(expt 2 logsize)))
    (if (= (aref tree 0)key)(aref tree 1) nil))

   ;; case 1: the key should be in this node.
   ((< key #.(expt 2 logsize)) 
    (if (arrayp (aref tree key));; if the node is an array
	(query-rtree 0 (aref tree key));; look in the zero location
      (aref tree key)));; the node is NOT an array: this is the value.
   (t (let* ((ind(logand key #.(1- (expt 2 logsize))));;otherwise compute the offset
	     (h (aref tree ind)))	; and the subtree to use for further search
	(if h (query-rtree (ash key #.(- logsize)) h) nil)))))

(defun maptree (fn mt);; order appears jumbled, actually reversed-radix order
  ;; apply fn, a function of 2 arguments, to key and val, for each entry in tree.
  ;; order is "radix reversed"
  (declare (optimize (speed 3)(safety 0)))
  (labels 
      ((tt1 (path displace mt);; path = path to the key's location
	    (cond ((null mt) nil)
		  ((leafp mt) (funcall fn path mt));; function applied to key  and val.
		  (t;; must be an array
		   (do ((i 0 (1+ i)))
		       ((= i #.(expt 2 logsize)))
		     (declare (fixnum i))
		     (tt1 (+ (ash i displace) path) (+ displace logsize)(aref mt i)))))))
    (tt1 0 0  mt)))

#| example
(setf mt (init-rtree))
(dotimes (i (expt 8 3))(update-rtree i i mt))
mt  ;;; a fully populated b-rtree with value n at location n, 0<= n < 8^3
(ordertree-nz mt)
|#

	    

(defun ordertree-nz(mt);;   order-tree the tree removing zeros.  sort after the whole tree is traversed
  (declare  (type (simple-array fixnum (*)) mt))
  (let ((ans (make-array 10 :adjustable t :fill-pointer 0)))
     (declare   (type (array t (*)) ans))
  (labels 
      ((tt1 (path displace mt);; path = path to the key's location
	    (cond ((null mt) nil)
		  ;; line below changed to return nil if mt is zero
		  ((leafp mt)(unless (zerop mt) 
			       (vector-push-extend (cons path mt) ans)))
		  ((= -1 (aref mt #.(expt 2 logsize)))
	;;	   (format t "~% mt=~s displace=~s path=~s" mt displace path)
		   
		   (unless (zerop (aref mt 1))
		     (vector-push-extend 
		      (cons  (+ path (ash (aref mt 0)displace))
			     (aref mt 1)) ans)))
		  (t;; mt must be an array
		   (locally (declare (type (simple-array fixnum (*)) mt))
		   (do ((i #.(1- (expt 2 logsize)) (1- i)))
		       ((< i 0) ans)
		     (declare (fixnum i) (type (simple-array fixnum (*)) mt))
		     (tt1 (+ (ash i displace) path) (+ displace logsize)(aref mt i))))))))
    (sort (tt1 0 0 mt) #'< :key #'car))))


(defun mul-rtree (r s)			;multiply two polynomials, in arrays
  (declare (optimize (speed 3)(safety 0)))
  (let* ((er (car r)) (es (car s))
	 (cr (cdr r)) (cs (cdr s))
	 (cri 0) (eri 0)
	 (ler (length er))
	 (les (length es))
	 (ans (init-rtree-mt)) )
    (declare (type (simple-array t (*)) cr cs er es)
	     (fixnum ler les cri eri ))		;maybe some others are fixnums too..
    ;; do the NXM multiplies into the answer tree
    (dotimes (i ler (A2PA (ordertree-nz ans)))
      (declare (fixnum i))
      (setf cri (aref cr i) eri(aref er i))
      (dotimes (j les)
	(declare (fixnum j))
	(update-rtree (+ eri(aref es j)) (* cri(aref cs j)) ans)))))

(defun mul-rtree-nosort (r s)			;multiply two polynomials, in arrays
  (declare (optimize (speed 3)(safety 0)))
  (let* ((er (car r)) (es (car s))
	 (cr (cdr r)) (cs (cdr s))
	 (cri 0) (eri 0)
	 (ler (length er))
	 (les (length es))
	 (ans (init-rtree-mt)) )
    (declare (type (simple-array t (*)) cr cs er es)
	     (fixnum ler les cri eri ))		;maybe some others are fixnums too..
    ;; do the NXM multiplies into the answer tree
    (dotimes (i ler			;(A2PA (ordertree-nz ans))
	       ans)
      (declare (fixnum i))
      (setf cri (aref cr i) eri(aref er i))
      (dotimes (j les)
	(declare (fixnum j))
	(update-rtree (+ eri(aref es j)) (* cri(aref cs j)) ans)))))



(defun A2PA(A) ;; array of (exp . coef) to 2 arrays.
  (let* ((LA (length A))
	 (V nil)
	 (anse (make-array LA))
	 (ansc (make-array LA)))
    (dotimes (i LA (cons anse ansc))
      (setf V (aref A i))
      (setf (aref anse i) (car V))
      (setf (aref ansc i) (cdr V)))))




(defun update-rtree(key val tree &aux node)
    (declare(fixnum key val)(type (simple-array fixnum (*)) tree))
  (cond ((= -1 (aref tree #.(expt 2 logsize)))
	 (cond ((= key (aref tree 0))
		(incf (aref tree 1) val)) ;; case where key matches exactly. replace value
	       (t
		(setf (aref tree #.(expt 2 logsize)) 0)
		(let ((oldkey (aref tree 0))
		      (oldval (aref tree 1)))
		  (setf (aref tree 0) 0)
		  (setf (aref tree 1) 0)
;;		  (if *debug*   (format t "~% oldkey= ~s key=~s tree=~s" oldkey key tree))
		  (setf tree(insert-rtree oldkey oldval tree)) ; re-insert the old key ;ok
;;		  (if *debug*  (format t "~%  tree=~s" tree))
		  (update-rtree key val tree)
;	   (format t "~%  tree=~s" tree)
	   ))))
	;; the node (i.e. tree) is array >2 in length
	;; the key is small enough to fit in this array
	((< key #.(expt 2 logsize))
	 ;; we have found the level, or level-1 for the key.
	 (cond ((nodep (setf node (aref tree key))) ; not a leaf
		;; if a node here, must descend one level further in tree; key now is 0
		(update-rtree 0 val node)); and update that node's location 0.
	       (t 
;;		(if *debug* (format t "~%case 1 key=~s" key))
		(incf (aref tree key) val))));; put it here.
	;;The key has too many bits to insert at this level. 
	;;Compute the subkey and separate the rest of the key by masking and shifting.
	(t (let ((ind(logand key #.(1- (expt 2 logsize))));rightmost logsize bits
		 (newkey (ash key #.(- logsize)))
		 )			; reduced key
;;	     (if *debug* (format t "~%case 2, newkey=~s ind=~s tree=~s" newkey ind tree))
	     (setf node (aref tree ind))
	     (cond((nodep node) (setf (aref tree ind) (update-rtree newkey val node)))
		  (t ;; a single item, must be moved
		   (let ()
		     (setf (aref tree ind) (init-rtree newkey  val))
		      (unless (= node 0)(insert-rtree ind node tree)) ;; re-insert 
		     ))))))  tree)