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

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

;;* Left Leaning Red Black Tree

;;** Example 1: Allocation Free Ascending String Map

;; Define constructors and accessors for "string-rbtree" and "string-node".

(define-record-type <llrbtree-node>
  (make-string-node color left right key value)
  llrbtree-node?
  (color string-node-color string-node-color-set!)
  (left string-node-left string-node-left-set!)
  (right string-node-right string-node-right-set!)
  (key string-node-key string-node-key-set!)
  (value string-node-value string-node-value-set!))

(define-llrbtree-code
  ()
  (args #f)
  (args #f)
  ((node . args)
   `(let ((node ,node))
      . ,(let loop ((args args))
	   (if (null? args)
	       '(node)
	       (cons
		(case (car args)
		  ((color:) `(string-node-color-set! node ,(cadr args)))
		  ((left:) `(string-node-left-set! node ,(cadr args)))
		  ((right:) `(string-node-right-set! node ,(cadr args)))
		  (else (error  (format "unbrauchbar ~a" args))))
		(loop (cddr args)))))))
  string-llrbtree-init!		   ;; defined
  string-llrbtree-node-lookup	   ;; defined
  string-llrbtree-min		   ;; defined
  string-llrbtree-node-fold	   ;; defined
  string-llrbtree-node-for-each	   ;; defined
  string-llrbtree-node-insert!	   ;; defined
  string-llrbtree-delete!	   ;; defined
  string-llrbtree-node-delete-min! ;; defined
  string-llrbtree-empty?	   ;; defined
  ((key node) ;; key-before? ordering function
   `(string=? ,key (string-node-key ,node)))
  ((key node) ;; key-before? ordering function
   `(string<? ,key (string-node-key ,node)))
  ((node1 node2) ;; before? ordering function
   `(string<? (string-node-key ,node1) (string-node-key ,node2)))
  string-node-left string-node-left-set!
  string-node-right string-node-right-set!
  string-node-color string-node-color-set!
  #f
  )

(define (make-string-llrbtree)
  (string-llrbtree-init! (make-string-node #f #f #f  #f #f)))

(define (string-llrbtree-set! tree key value)
  (let ((node (string-llrbtree-node-lookup tree key)))
    (if node
	(string-node-value-set! node value)
	(string-llrbtree-node-insert! tree (make-string-node #f #f #f key value))))
  #t)

(define (string-llrbtree-ref/default tree key default)
  (let ((node (string-llrbtree-node-lookup tree key)))
    (if node (string-node-value node) default)))

(define (string-llrbtree-ref tree key default)
  (let ((node (string-llrbtree-node-lookup tree key)))
    (if node (string-node-value node) (default))))

(define (string-llrbtree-fold proc init tree)
  (string-llrbtree-node-fold
   (lambda (node init) (proc (string-node-key node) (string-node-value node) init))
   init tree))

(define (string-llrbtree-for-each proc tree)
  (string-llrbtree-node-for-each
   (lambda (node init) (proc (string-node-key node) (string-node-value node)))
   tree))

(define (string-llrbtree/min tree default)
  (let ((node (string-node-leftmost tree)))
    (if node (values (string-node-key node) (string-node-value node)) (default))))

(define (string-llrbtree/delete-min! tree default)
  (let ((node (string-llrbtree-node-delete-min! tree)))
    (if node (values (string-node-key node) (string-node-value node)) (default))))

;;** Exmaple 2: Pure Accending Integer Set

;; This style needs slot setter procedures and a system dependent
;; "copy" procedure, which returns a shallow copy of it's argument.
;; It provides a pure update.

;;; Shallow copy arbitrary object:

#|
(define (shallow-copy x)
  (let ([x x])
    (cond [(not (##core#inline "C_blockp" x)) x]
	  [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
	  [else
	    (let* ([n (##sys#size x)]
		   [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)] )
              (##core#inline "C_copy_block" x (##sys#make-vector words))) ] ) ) )

|#

(define (update!+ node . args)
  `(let ((node (object-copy ,node)))
     . ,(let loop ((args args))
	  (if (null? args)
	      '(node)
	      (cons
	       (case (car args)
		 ((color:) `(set-color! node ,(cadr args)))
		 ((left:) `(set-left! node ,(cadr args)))
		 ((right:) `(set-right! node ,(cadr args)))
		 (else (error  (format "unbrauchbar ~a" args))))
	       (loop (cddr args)))))))

;; The effectful version justs skips the copy.

(define (update! node . args)
  `(let ((node ,node)) . ,(cddr (apply update!+ node args))))

;; Another really pure version, which neither needs slot setters nor a
;; copy operation.  Insted it needs more knowledge of the actual node
;; structure to fully copy it through.

;; The disadvantage: I'm not sure that I can make the code use the
;; required minimum of "update"s.  But it should catch some mistakes,
;; when the others schemes go wrong.

(define (update node . args)
  (let ((other-slots '(key)) ;; value))
	(tree-slots '((color: color)
		      (left: left)
		      (right: right))))
    (define (updater e)
      (let ((c (memq (car e) args)))
	(if c (cadr c)
	    `(,(cadr e) ,node))))
    (define (copyer acc)
      `(,acc ,node))
    `(make-llrbtee-node
      ,@(map updater tree-slots)
      ,@(map copyer other-slots))))

(define update+ update)

(define-record-type <llrbtree-node>
  (make-llrbtee-node color left right key)
  llrbtree-node?
  (color color set-color!)
  (left left set-left!)
  (right right set-right!)
  (key key set-key!))

#|
(pretty-print
 (make-llrbtree-code
  '(pure debug)
  update
  update+
  update!
 'init-int-llrbtree-root-node!
 'int-llrbtree-lookup
 'int-llrbtree-min
 'int-llrbtree-fold
 'int-llrbtree-for-each
 'int-llrbtree-insert!
 'int-llrbtree-delete!
 'int-llrbtree-delete-min!
 'int-llrbtree-empty?
 t-k-eq?
 t-k-<?
 t-<?
 'left 'set-left!
 'right 'set-right!
 'color 'set-color!
 'int-llrbtree-leftmost-set!
 ))
|#

(define int-llrbtree-leftmost-value #f)

(define (int-llrbtree-leftmost-set! n)
  (set! int-llrbtree-leftmost-value n))

(define-llrbtree-code
  (pure debug)
  (args (apply update args))
  (args (apply update+ args))
  (args (apply update! args))
  init-int-llrbtree-root-node!
  int-llrbtree-lookup
  int-llrbtree-min
  int-llrbtree-fold
  int-llrbtree-for-each
  int-llrbtree-insert
  int-llrbtree-delete!
  int-llrbtree-delete-min!
  int-llrbtree-empty?
  ((k n) `(eqv? ,k (key ,n)))
  ((k n) `(< ,k (key ,n)))
  ((n1 n2) `(< (key ,n1) (key ,n2)))
  left set-left!
  right set-right!
  color set-color!
  int-llrbtree-leftmost-set!
  )

(define t (make-llrbtee-node #f #f #f #f))

(set! t (init-int-llrbtree-root-node! t))

(for-each
 (lambda (n)
   (set! t (int-llrbtree-insert t (make-llrbtee-node #f #f #f n))))
 '(1
   2 11 3 7
   ; 11
   10 5 4 6 8 9 12))
(set! t (int-llrbtree-delete-min! t))
(print-tree t)

(print (int-llrbtree-fold (lambda (a b) (cons (key a) b)) '() t))
(format #t "Minumum ~a\n" (and (int-llrbtree-min t) (key (int-llrbtree-min t))))
(set! t (int-llrbtree-delete-min! t))
(print-tree t #t)
(print (int-llrbtree-fold (lambda (a b) (cons (key a) b)) '() t))
(format #t "Minumum ~a\n" (and (int-llrbtree-min t) (key (int-llrbtree-min t))))
(int-llrbtree-delete! t 2)
(format #t "Tree ~a\n" (int-llrbtree-fold (lambda (a b) (cons (key a) b)) '() t))
(int-llrbtree-delete! t 1)
(int-llrbtree-delete-min! t)
(int-llrbtree-delete! t 4)
(int-llrbtree-delete! t 4)
(int-llrbtree-delete-min! t)
(int-llrbtree-delete! t 1)
(int-llrbtree-delete! t 2)
(format #t "leftmost: ~a\n" (and int-llrbtree-leftmost-value (key int-llrbtree-leftmost-value)))
(int-llrbtree-delete! t 4)
(int-llrbtree-delete! t 3)
(int-llrbtree-delete! t 5)
;(set! t (make-llrbtee-node #f (int-llrbtree-insert! t (make-llrbtee-node #f #f #f 4)) #f #f))
;(set! t (make-llrbtee-node #f (int-llrbtree-insert! t (make-llrbtee-node #f #f #f 1)) #f #f))
(int-llrbtree-delete! t 7)
;(set! t (make-llrbtee-node #f (int-llrbtree-insert! t (make-llrbtee-node #f #f #f 2)) #f #f))
;(set! t (make-llrbtee-node #f (int-llrbtree-insert! t (make-llrbtee-node #f #f #f 5)) #f #f))
(int-llrbtree-delete! t 8)
(format #t "Tree ~a\n" (int-llrbtree-fold (lambda (a b) (cons (key a) b)) '() t))
(int-llrbtree-delete! t 5)
(int-llrbtree-delete! t 6)
(int-llrbtree-delete! t 9)
;(print-tree t)
(int-llrbtree-delete! t 9)
(int-llrbtree-delete! t 5)
(int-llrbtree-delete! t 11)
(int-llrbtree-delete-min! t)
(format #t "~a\n" (int-llrbtree-fold (lambda (a b) (cons (key a) b)) '() t))
(format #t "leftmost: ~a\n" (and int-llrbtree-leftmost-value (key int-llrbtree-leftmost-value)))
(print-tree t)

(display
 (with-output-to-string
   (lambda ()
     (int-llrbtree-for-each (lambda (n) (format #t "~a\n" (key n))) t))))

;(int-llrbtree-delete! t 5)

(print (and-let* ((n (int-llrbtree-lookup t 5))) (key n)))