;;; author RJF Nov 12, 2008
(eval-when (:compile-toplevel :load-toplevel :execute)
  (declaim (optimize (speed 3)(safety 1)))
  
  (defvar *mlogsizes* (list -8 -5 -3))
  (defvar *sizes* (mapcar #'(lambda(r)(expt 2 (- r))) *logsizes*))
  (defvar *sizesm1* (mapcar #'(lambda(r)(1- (expt 2 (- r)))) *logsizes*))
  (nconc *logsizes* (cddr *logsizes*))
  (nconc *sizes* (cddr *sizes*))
  (nconc *sizesm1* (cddr *sizesm1*))
  (nconc *mlogsizes* (cddr *mlogsizes*))
  
)

(defmacro init-rtree(size)`(make-array si :initial-element nil))

(defmacro leafp(x) `(numberp ,x))
(defmacro nodep(x) `(arrayp ,x))
(defmacro emptynodep(x) `(eq 0 ,x))

(defun insert-rtree(key val tree &optional (sizes *sizes*) (sizesm1 *sizesm1*) (mlogsizes *mlogsizes*)  &aux node)
  (declare (optimize (speed 3)(safety 0))
	   (type (simple-array t (*)) tree))
    (cond  ;;((fixnump key)(update-rtree-fix key val tree)) ;optimized for fixnum key
	 ((< key #.(expt 2 logsize))	; we have found the level, or level-1 for the key.
	  (cond ((nodep (setf node (aref tree key))); if a node here, must descend one level further in tree
		 (insert-rtree 0 val node (cdr sizes)(cdr sizesm1))); and update that node's location 0.
		(t(setf (aref tree key) val))))
	 
	 ;;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 (car sizesm1)))); mask off the relevant bits for subkey
	      (declare (fixnum ind))
	      (setf node (aref tree ind))
	      (cond ((nodep node)
		     (insert-rtree (ash key (car mlogsizes)) val node)) ;descend into tree with rest of key.
		    (t (setf (aref tree ind)
			     (update-rtree (ash key (car mlogsizes)) val 
					   (if (leafp node)
					       (insert-rtree 0 node (init-rtree (car sizes)))
					     (init-rtree (car sizes))))))))))
  tree)

(defun query-rtree(key tree)		;works. though we don't use it..
  (declare (optimize (speed 3)(safety 0))
	   (type (simple-array t (#.(expt 2 logsize))) tree))
  (cond  ((< key #.(expt 2 logsize)) 
	  (if (arrayp (aref tree key)) (query-rtree 0 (aref tree key))
	    (aref tree key)))
	 (t (let* ((ind(logand key #.(1- (expt 2 logsize))))
		   (h (aref tree ind)))
	      (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)))

;; (maptree #'(lambda(a b)(print (list a b) )) rt)

(defun ordertree (mt);; convert an rtree to an ordered list of pairs (... (index . val) ...)
  (declare (optimize (speed 3)(safety 0))
	   (type (simple-array t (#.(expt 2 logsize))) tree))
  (labels 
      ((tt1 (path displace mt);; path = path to the key's location, displace = loc in level
	    (cond ((null mt) nil)
		  ((leafp mt) (list (cons path mt))) ;singleton list ((index . val))
		  (t;; must be an array
		   (do ((i #.(1- (expt 2 logsize)) (1- i))
			(res nil (merge 'list res  
					(tt1 (+ (ash i displace) path) (+ displace logsize)(aref mt i)) 
					#'< :key #'car)))
		       ((< i 0) res)
		     (declare (fixnum i)))))))
    (tt1 0 0 mt)))

#| example

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

(defun ptimes-multivar(r s) ;; leave answer in list, sorted
  (declare(optimize (speed 3)(safety 0)))
  (multiple-value-bind (in out)(make-coders r s)
    (labels ((incode (z)(mapcar #'(lambda(h)(cons (car h)(funcall in (cdr h)))) z)))
        (setf r(ordertree-nz (ptimes-rtree (incode r) (incode s))))
	(dolist (h r r)(setf (cdr h)(funcall out (cdr h)))))))

(defun ptimes-rtree (m n)		;multiply two polynomials, in lists, into rtree result
  (declare (optimize (speed 3)(safety 0)))
  (let((ans (init-rtree)))
    (dolist (i m ans) ;; the cross product
      (dolist (j n)
	(update-rtree (+ (cdr i)(cdr j))
		      (* (car i)(car j))
		      ans)))))


#+ignore
(defun ptimes-rtree (m n)	;false declarations.
  (declare (optimize (speed 3)(safety 0)))
  (let((ans (init-rtree)))
    (dolist (i m ans) ;; the cross product
      (dolist (j n)
	(update-rtree (the fixnum(+ (the fixnum (cdr i))(the fixnum (cdr j))))
		      (the fixnum (* (the fixnum (car i))(the fixnum (car j))))
		      ans)))))



(defun update-rtree-fix(key val tree &aux node)  ;;  optimization for  key being fixnum; minor hacks
  (declare (optimize (speed 3)(safety 0))
	   (type (simple-array t (#.(expt 2 logsize))) tree)
	   (fixnum key))
  
  (cond  ((< key #.(expt 2 logsize))	; we have found the level, or level-1 for the key.
	  (cond ((nodep (setf node (aref tree key))); if a node here, must descend one level further in tree
		 (update-rtree-fix 0 val node)); and update that node's location 0.
		((emptynodep node)(setf (aref tree key) val))
		(t(setf (aref tree key) (+ node val)))));; put it here.
	 
	  (t (let ((ind(logand key #.(1- (expt 2 logsize))))); mask off the relevant bits for subkey
	      (declare (fixnum ind))
	      (setf node (aref tree ind))
	      (cond ((arrayp node)
		     (update-rtree-fix (ash key #.(- logsize)) val node));descend into tree with rest of key.
		    (t (setf (aref tree ind)
			     (update-rtree-fix (ash key #.(- logsize)) val 
					   (if (leafp node)
					       (update-rtree-fix 0 node (init-rtree))
					     (init-rtree)))))))))  
  tree)

(defun insert-rt1-fix(key val tree sizes sizesm1 mlogsizes)
  (labels((insert-rtree  ;;internally, use fixnum keys
	   (key val tree)
	   (declare 
		    (type (simple-array t (*)) tree)
		    (fixnum key))
  	   (cond  ((< key (car sizes)) ; we have found the level, or level-1 for the key.
		   (cond ((nodep (aref tree (the fixnum key))); if a node here, must descend one level further in tree
			  (insert-rtree 0 val (aref tree (the fixnum key)) (cdr sizes)(cdr sizesm1)(cdr mlogsizes))); and update that node's location 0.
			 (t
			  (setf (aref tree (the fixnum key)) 
			    val
			    ))))
		  
		  (t (let* ((ind(logand key (car sizesm1))); mask off the relevant bits for subkey
			    (h (aref tree ind)))
		       (declare (type (simple-array t (*)) tree)(fixnum ind))
		       (cond ((arrayp h)
			      (insert-rtree (ash key (car msizes)) val h (cdr sizes)(cdr sizesm1)(cdr mlogsizes)));descend into tree with rest of key.
			     ((leafp h)	; leaf, not link. We make a subtree and move the leaf down one level.
			      (setf (aref tree ind)
				(insert-rtree (ash key (car mlogsizes))
					      val (inserte-rtree 0 h 
								 (init-rtree (car sizes))))))
			     (t (setf (aref tree ind)(insert-rtree 
						      (ash key (car mlogsizes))
						      val (init-rtree (car sizes)
								      ))))))))
	   tree))
    (insert-rtree key val tree (cdr sizes)(cdr sizesm1)(cdr mlogsizes))))