(module R-tree
	
  ()

  (import scheme chicken data-structures)
  
  (require-extension srfi-1 srfi-4 )



  (define Max (make-parameter 8))
  (define Min (make-parameter 2))


  (define-record-type rnode
    (make-rnode rect parent data sub)
    rnode?
    (rect    rnode-rect rnode-rect-set!) 
    (parent  rnode-parent rnode-parent-set!) 
    (data    rnode-data  rnode-data-set!)
    (sub     rnode-children rnode-children-set!)
    )


  (define-inline (Leaf rect parent data)
    (make-rnode rect parent data #f))

  (define-inline (Tree rect parent sub)
    (make-rnode rect parent #f sub))


  ;; returns the rectangle describing the spatial extent of the given
  ;; node
  (define (I N) (and (rnode? N) (rnode-rect N)))

  ;; returns the parent of a node, or 'root if this is the root node
  (define (P N) (and (rnode? N) (or (rnode-parent N) 'root)))


  ;; returns the child pointer of a non-leaf node, #f otherwise
  (define (CP T) (and (rnode? T) (rnode-children T)))

  (define (leaf-node? x) (and (rnode-data x) (not (pair? (CP x)))))

  (define (R-tree? x) 
    (and (rnode? x) 
	 (or (leaf-node? x)
	     (pair? (cdr (rnode-children x))))))

  (define (push-child! T N)
    (rnode-children-set! T (cons N (rnode-children T)))
    (rnode-parent-set! N T))


  ;; Given an R-tree whose root node is T, find all index records
  ;; whose rectangles overlap a search rectangle S.
  (define (search T S)

    (and (R-tree? T)
	 (let recur ((ts (list T)) (res '()))
	   (if (null? ts) res
	       (recur (cdr ts)
		      (let ((t (car ts)))
			(if (leaf-node? t)
			    (if (rect-intersect? S (I t))
				(cons t res) 
				res)
			    ;; If T is not a leaf, check each entry E to determine
			    ;; whether E I overlaps S. For all overlapping
			    ;; entries, invoke Search on the tree whose root node
			    ;; is pointed to by E p
			    (if (rect-intersect? S (I t))
				(recur children res) 
				res)
			    )))))
	 ))

	
  ;; Insert a new entry E into a tree
  (define (insert T E)
    (and (R-tree? T)
	 (let* (;; find position for new entry
		(L  (choose-leaf T E))

		;; add entry to leaf node
		(Ls (if (or (not (CP L)) (< (length (CP L)) (Max)))

			(let* ((new-child (Leaf (car E) L (cdr E)))
			       (new-rect  (rect-union (car E) (I L))))
			  (push-child! L new-child)
			  (rnode-rect-set! L new-rect)
			  (list L))

			(split-node L E)))
		;; propagate changes upward
		(T1  (apply adjust-tree (cons T Ls))))

	   ;; if node split propagation caused the root to split, create a
	   ;; new root whose children are the two resulting nodes
	   (if (pair? (cdr T1))
	       (let ( (new-root (Tree (rect-union (I (car T1)) (I (cadr T1))) #f T1)) )
		 (rnode-parent-set! (car T1) new-root)
		 (rnode-parent-set! (cadr T1) new-root)
		 new-root)
	       (car T1)))))


  ;; Selects a leaf node in which to place a new index entry E
  (define (choose-leaf T E)
    (if (leaf-node? T) T
	;; Determine F: an entry whose rectangle needs the
	;; least enlargement to include E I
	(let* ((children (CP T))
	       (F (car children))
	       (F-area (rect-area F)))
	  
	  (let recur  ((children (cdr children))
		       (F F) (F-area F-area)
		       (min-extension (- (rect-area (rect-union (car E) (I F)))
					 F-area)))
	    (if (null? children) 
		(choose-leaf F E)
		(let* ((child (car children))
		       (child-area (rect-area (I child)))
		       (new-area (rect-area (rect-union (car E) (I child))))
		       (extension (- new-area child-area)))
		  (if (or (< extension min-extension)
			  (and (= extension min-extension)
			       (< child-area F-area)))
		      (recur (cdr children) child child-area extension)
		      (recur (cdr children) F F-area min-extension))))
	    
	    ))))
		 
		 
  ;;  Ascend from a leaf node L to the root, adjusting covering
  ;;  rectangles and propagating node splits as necessary.

  (define (adjust-tree T L . rest)
    (let-optionals rest ((LL #f))
      (let recur ((N L) (NN LL))
	(if (not (equal? T N))
	    (let ((parent (P N)))
	      (rnode-rect-set! N (minimum-bound-of (rnode-children N)))
	      (if NN
		  (cond
		   ((< (length (rnode-children parent)) (Max))
		    (push-child! parent NN)
		    (recur parent #f))
		   (else
		    (let ((new-parent (split-node T new parent)))
		      (for-each (lambda (n) (rnode-parent-set! n parent))
				(rnode-children parent))
		      (for-each (lambda (n) (rnode-parent-set! n new-parent))
				(rnode-children new-parent))
		      (recur parent new-parent))))
		  
		  (recur parent #f)))))))

  ;; 3.3. Deletion
  
  (define (delete T E)

    (let ((leaf-node (find-leaf T E)))
      (if leaf-node
	  (begin
	    (rnode-data-set! leaf-node #f)
	    (condense-tree T leaf-node )
	    (if (and (pair? (CP T)) (not (pair? (cdr (CP T)))))
		;; If the root node has only one child after the tree has
		;; been adjusted, make the child the new root
		(let ((T1 (car (CP T))))
		  (rnode-parent-set! T1 #f)
		  T1)
	      T)))))

  (define (find-leaf T E)
    (if (leaf-node? T)
	(and (equal? (cadr E) (rnode-data T)) T)
	(let* ((S (car E))
	       (candidates 
		(filter-map (lambda (t) (and (rect-intersect? S (I t)) t)) (CP T))))
	  (find (lambda (t) (find-leaf t E)) candidates))))


  



(defun condense-tree (node tree)
  (labels ((all-leaves-below (node)
             (if (typep node 'spatial-tree-leaf-node)
                 (records node)
                 (apply #'append
                        (mapcar #'all-leaves-below (children node))))))
    (do ((node node (parent node))
         (q nil))
        ((eq node (root-node tree))
         (dolist (orphan q)
           ;; NOTE: this interpretation (reinsert every leaf)
           ;; disagrees with BKSS (R*-trees), section 4.3, "... is
           ;; based on the ability of the insert routine to insert
           ;; entries on every level of the tree as already required
           ;; by the deletion algorithm [Gut 84]."
           (dolist (oleaf (all-leaves-below orphan))
             (insert (leaf-node-entry-datum oleaf) tree))))
      (cond
        ((< (length (children node)) (min-per-node tree))
         (setf (children (parent node)) (remove node (children (parent node))))
         (push node q))
        (t
         (setf (slot-value node 'mbr) (minimum-bound-of (children node) tree)))))))
  

)