;; (C) 2008 Jörg F. Wittenberger.

;; Redistribution permitted under either GPL, LGPL or BSD style
;; license.

;;* Left Leaning Red Black Tree

;;** Code Generator

;; The code generating macro expander, written in procedural style.

;;; This code is written in a style, which hides the algorithm behind
;;; the quot/unquote macro expansion.  Sorry for that.  I just did not
;;; dare to learn hygienic macros at the same time as writing this
;;; code and, moreover, want to use it in a an environment, which does
;;; not yet have R5RS macros.

;; The "update*" arguments to make-llrbtree-code are subject to
;; change.

;;; Using these arguments, one can control the style of the expanded
;;; code.  But while the scheme is visible, the code is not yet clean
;;; enough.

;;; If the programmer - that is me in this case - had already finished
;;; this work, there would be no "update+".  Right now, there are
;;; almost only "update+"'s.
;;;
;;; When an expression useable as "update" is supplied for "update",
;;; "update+" and "update!", the expanded code will create a side
;;; effect free version (with a slightly different API).  This version
;;; is currently morely for test and development purposed, because it
;;; expands to many superflous allocations.

;;; Since the expansion is by no means hygienic, better be careful!
;;; One character names and "node" are currently risky options symbols
;;; being passed to this code.

(define (make-llrbtree-code
	 ;; The "features" is a list of symbols to control code
	 ;; expansion.  "pure" will use "update" and "update+",
	 ;; otherwise only "update!" will be used.  "ordered" will
	 ;; enforce total order among the element.  "debug" will
	 ;; expand a simple tree printer, and "leftmost" will include
	 ;; untested code to maintain a leftmost value of the tree.
	 features
	 ;; The "update*" expressions are lambda abstractions (sans
	 ;; the 'lambda' keyword) evaluated at compile time to produce
	 ;; the actual code to update a node.  These procedures take
	 ;; 1+ arguments.  A original node and a keyword: <value>
	 ;; ... list of desired updates.  Possible keywords are left:
	 ;; right: and color:

	 ;; "update" : Always expands to a newly allocated node.
	 update
	 ;; "update+": May expand to a newly allocated node may update
	 ;; the original node updated via side effects.
	 update+
	 ;; "update!": Always expands to a side effect full update of
	 ;; the original node.
	 update!
	 init-root-node!		;; defined
	 t-lookup			;; defined
	 t-min				;; defined
	 t-fold				;; defined
	 t-for-each			;; defined
	 t-insert			;; defined
	 t-delete			;; defined
	 t-delete-min			;; defined
	 t-empty?			;; defined

	 ;; These procedures expand to code for comparision
	 ;; expressions.
	 t-k-eq?			;; key<>node-key "equal"
	 t-k-<?				;; key<>node-key "less then"
	 t-<?				;; node<>node "less then"

	 left set-left!
	 right set-right!
	 color set-color!
      ;;; This is an experiment too.  But since it adds non-constant
      ;;; complexity to the code, I recommend to pass #f here.  It's
      ;;; also not really tested.
	 set-leftmost!
	 )

  (define maintain-leftmost! (memq 'leftmost features))

  (define pure (memq 'pure features))

  (define ordered (memq 'ordered features))

  (if (not pure) (set! update+ update!))

  (define root-node left)

  (define empty?
    (if pure
	(lambda (t node) `(not ,node))
	(lambda (t node) `(eq? ,t ,node))))

  (define empty
    (if pure
	(lambda (t) #f)
	(lambda (t) t)))

  (define black
    (if pure
	(lambda (t) #t)
	(lambda (t) t)))

  (define (red)
    #f)

  (define (red? t)
    `(lambda (node)
       (if ,(empty? 't 'node) #f (not (,color node)))))

  (define (ptred? t . sel)
    `(lambda (n)
       ,(let loop ((sel sel) (n 'n))
	  `(let loop ((n ,n))
	     (if ,(empty? 't 'n) #f
		 ,(if (null? sel)
		      `(not (,color n))
		      (loop (cdr sel) `(,(car sel) n))))))))

  (define (black? t)
    `(lambda (node)
       (,color node)))

  (define (color-flip-node! t n)
    `(let ((n ,n))
       (if ,(empty? 't 'n) n
	   ,(update+ 'n color: `(if (,(black? t) n) ,(red) ,(black t))))))

  (define (color-flip! t n)
    `(let ((n ,n))
       (if ,(empty? 't 'n) n
	   ,(update+
	     'n
	     left: (color-flip-node! t `(,left n))
	     right: (color-flip-node! t `(,right n))
	     color: `(if (,(black? 't) n) ,(red) ,(black 't))))))

  (define (rotate-left! t n)
    `(let ((n ,n))
       (let ((x (,right n))
	     (c (,color n)))
	 (let ((l (,left x)))
	   ,(update+
	     'x
	     left: (update+ 'n right: 'l color: (red))
	     color: 'c)))))

  (define (rotate-right! t n)
    `(let ((n ,n))
       (let ((x (,left n))
	     (c (,color n)))
	 (let ((r (,right x)))
	   ,(update+
	     'x
	     right: (update+ 'n left: 'r color: (red))
	     color: 'c)))))

  (define (fixup! t h)
    `(begin
       (if (,(red? 't) (,right ,h))
	   (set! ,h ,(rotate-left! t h)))
       (if (and (,(red? t) (,left ,h)) (,(ptred? t left left) ,h))
	   (set! ,h ,(rotate-right! t h)))
       (if (and (,(red? t) (,left ,h)) (,(red? t) (,right ,h)))
	   ,(color-flip! t h)
	   ,h)))

  (define (move-red-right! t n)
    `(let ((n ,(color-flip! t n)))
       (if (,(ptred? 't left left) n)
	   ,(color-flip! t (rotate-right! t 'n))
	   n)))

  (define (move-red-left! t h)
    `(let ((h ,(color-flip! t h)))
       (if (,(ptred? 't right left) h)
	   ,(color-flip! t (rotate-left! t (update+ 'h right: (rotate-right! t `(,right h)))))
	   h)))

  (define (define-delete-min t)
    `(define (delete-min set-leftmost! r n)
       (if ,(empty? 't `(,left n))
	   (begin
	     (vector-set! r 0 n)
	     (,left n))
	   (let* ((n (if (and (not (,(red? t) (,left n)))
			      (not (,(ptred? t left left) n)))
			 ,(move-red-left! t 'n)
			 n))
		  (nl (delete-min set-leftmost! r (,left n))))
	     (set! n ,(update+ 'n left: 'nl))
	     ,@(if maintain-leftmost!
		   `((if (and set-leftmost! ,(empty? 't `(,left n)) ,(empty? 't 'nl))
			 (set-leftmost! n)))
		   '())
	     (set! n ,(fixup! t 'n))
	     n))))

  `(begin
     ,@(if init-root-node!
	   `((define (,init-root-node! t)
	       ,((if pure update update!) 't color: (black 't) left: (empty 't))))
	   '())
     ,@(if t-empty?
	   `((define (,t-empty? t)
	       ,(empty? 't `(,root-node t))))
	   '())
     ,@(if t-lookup
	   `((define (,t-lookup t k)
	       (and (not ,(empty? 't 't))
		    (let loop ((node (,root-node t)))
		      (cond
		       (,(empty? 't 'node) node)
		       (,(t-k-eq? 'k 'node) node)
		       (,(t-k-<? 'k 'node) (loop (,left node)))
		       (else (loop (,right node))))))))
	   '())
     ;; Handy help for debugging.
     ,@(if (memq 'debug features)
	   `((define (print-tree t . mode)
	       (let loop ((node (,root-node t)) (lvl 0))
		 (if ,(empty? 't 'node)
		     (flush-output)
		     (let ((gap (make-string lvl #\space)) (c (if (,color node) 'B 'R))
			   (tag (rfc-822-timestring
				 (time-utc->date (timeout-queue-time node) (timezone-offset)))))
		       (if (pair? mode) (print gap "Key " tag " " c " left:"))
		       (loop (,left node) (add1 lvl))
		       (print gap "Key " tag " " c (if (pair? mode) " right:" ""))
		       (loop (,right node) (add1 lvl)))))))
	   '())
     ,@(if t-min
	   `((define (,t-min t)
	       (if ,(empty? 't `(,root-node t)) #f
		   (let loop ((node (,root-node t)))
		     (cond
		      (,(empty? 't `(,left node)) node)
		      (else (loop (,left node))))))))
	   '())
     ,@(if t-fold
	   `((define (,t-fold procedure init t)
	       (define (fold init node)
		 (if ,(empty? 't 'node)
		     init
		     (fold (procedure node (fold init (,right node))) (,left node))))
	       (fold init (,root-node t))))
	   '())
     ,@(if t-for-each
	   `((define (,t-for-each procedure t)
	       (let loop ((node (,root-node t)))
		 (or ,(empty? 't 'node)
		     (begin
		       (procedure node)
		       (loop (,left node))
		       (loop (,right node)))))))
	   '())
     ,@(if t-insert
	   `((define (,t-insert t n . set-leftmost!)
	       ,@(if pure '()
		     (list (update! 'n color: (red) left: (empty 't) right: (empty 't))))
	       (let ((nr (let loop ((node (,root-node t))
				    (sl (and (pair? set-leftmost!) (car set-leftmost!))))
			   (if ,(empty? 't 'node)
			       (if sl (begin (sl n) n) n)
			       (let ((node (if ,(t-<? 'n 'node)
					       (let ((l (loop (,left node) sl)))
						 ,(update+ 'node left: 'l))
					       (let ((r (loop (,right node) #f)))
						 ,(update+ 'node right: 'r)))))
				 (if (,(red? 't) (,right node))
				     (set! node ,(rotate-left! 't 'node)))
				 (if (and-let* ((l (,left node))
						((,(red? 't) l)))
					       (,(red? 't) (,left l)))
				     (set! node ,(rotate-right! 't 'node)))
				 (if (and (,(red? 't) (,left node)) (,(red? 't) (,right node)))
				     ,(color-flip! 't 'node)
				     node))))))
		 (if (,(red? 't) nr) (set! nr ,(update+ 'nr color: (black 't))))
		 ,((if pure update update!) 't left: 'nr color: (black 't)))))
	   '())
     ,@(if t-delete-min
	   `((define (,t-delete-min t . cont)
	       ,(define-delete-min 't)
	       (define set-leftmost! (and (pair? cont) (pair? (cdr cont)) (cadr cont)))
	       (if ,(empty? 't `(,root-node t))
		   ,(if pure
			`(if (pair? cont) ((car cont) t #f) 't)
			#f)
		   (let* ((min (vector #f))
			  (r (delete-min set-leftmost! min (,left t))))
		     ,@(if maintain-leftmost!
			   `((if (and set-leftmost! ,(empty? 't 'r))
				 (set-leftmost! r)))
			   '())
		     ,(if pure
			  `(let ((nt ,(update 't left: 'r)))
			     (if (pair? cont) ((car cont) nt (vector-ref min 0)) nt))
			  `(begin
			     ,(update! 't left: 'r color: (black 't))
			     (vector-ref min 0)))))))
	   '())
     ,@(if t-delete
	   `((define (,t-delete t n/k . rest)
	       ,(define-delete-min 't)
	       (define (delete! set-leftmost! h)
		 (if ,(if ordered
			  (t-k-<? 'n/k 'h)
			  `(and (not (eq? n/k h)) ,(t-<? 'n/k 'h)))
		     (let* ((h (if (and (not (,(red? 't) (,left h)))
					(not (,(ptred? 't left left) h)))
				   ,(move-red-left! 't 'h)
				   h))
			    (nl (if ,(empty? 't `(,left h)) ,(empty 't)
				    (delete! set-leftmost! (,left h)))))
		       (if (not (eq? (,left h) nl))
			   (set! h ,(update+ 'h left: 'nl)))
		       ,@(if maintain-leftmost!
			     `((if (and set-leftmost! ,(empty? 't `(,left h)) ,(empty? 't 'nl))
				   (set-leftmost! h)))
			     '())
		       ,(fixup! 't 'h))
		     (let ((h (if (,(red? 't) (,left h))
				  ,(rotate-right! 't 'h)
				  h)))
		       (if (and ,(if ordered (t-k-eq? 'n/k 'h) `(eq? n/k h))
				,(empty? 't `(,right h)))
			   (,right h)
			   (begin
			     (if (and (not (,(red? 't) (,right h)))
				      (not (,(ptred? 't right left) h)))
				 (set! h ,(move-red-right! 't 'h)))
			     (if (eq? n/k h)
				 (let* ((minv (vector #f))
					(nr (delete-min #f minv (,right h)))
					(min (vector-ref minv 0)))
				   (set! h ,(update+ 'min right: 'nr left: `(,left h))))
				 (if (not ,(empty? 't `(,right h)))
				     (let ((nr (delete! #f (,right h))))
				       (set! h ,(update+ 'h right: 'nr)))))
			     ,(fixup! 't 'h))))))
	       (define set-leftmost! (and (pair? rest) (car rest)))
	       (if ,(empty? 't `(,root-node t))
		   (let ((r (delete! set-leftmost! (,left t))))
		     ,(if pure
			  (update 't left: 'r)
			  (update! 't left: 'r color: (black 't))))
		   t)))
	   '())))