;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                           BINARY TREE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define *trace* t)
;;;
;;; Old convention ... *global-var*
;;;

(define bnode (make-record-type "bnode" '(left label right)))
(define make-bnode (record-constructor bnode '(left label right)))
;;;
;;; A bnode is a node within a binary tree, and has a label,
;;; a left branch, and a right branch
;;;

(define bnode? (record-predicate bnode))

(define empty '())

(define (empty? bnode) (null? bnode))

(define (leaf? n)
  (and (empty? (left n)) (empty? (right n))))

(define left (record-accessor bnode 'left))
(define label (record-accessor bnode 'label))
(define right (record-accessor bnode 'right))

(define left! (record-modifier bnode 'left))
(define label! (record-modifier bnode 'label))
(define right! (record-modifier bnode 'right))

(define (print-node node)
  (display (label node)) (display " "))


(define (preorder bnode)
  (cond ((not (empty? bnode))
	 (print-node bnode)
	 (preorder (left bnode))
	 (preorder (right bnode)))))

(define (inorder bnode)
  (cond ((not (empty? bnode))
	 (inorder (left bnode))
	 (print-node bnode)
	 (inorder (right bnode)))))

(define (postorder bnode)
  (cond ((not (empty? bnode))
	 (postorder (left bnode))
	 (postorder (right bnode))
	 (print-node bnode))))

(define (list->bintree l)
  (cond ((empty? l) empty)
	((list? l)
	 (make-bnode (list->bintree (first l))
		    (second l)
		    (list->bintree (third l))))
	(t (make-bnode empty l empty))))
;;;
;;; Convert expression (* (+ a b) (/ (+ c d) f))
;;; into a binary tree.
;;; 
;;; NOTE: this is NOT the same as inserting elements into
;;;       a binary tree, were insertion is with respect to some
;;;       predicate. To create a more general tree see insert!
;;;

;;;
;;; Example
;;;

;(define l '((10 + 4) * (3 + (6 / 2))))
;(define b (list->bintree l))
;(preorder b)
;(inorder b)



;;; AND NOW ... PREORDER WITHOUT RECURSION !! (not for the faint hearted)

(define (npreorder n) ; non-recursive preorder traversal of binary tree
  (let ((s '()))
    (do () ((and (empty? n) (null? s))) ; stop when node and stack empty
      (cond ((not (empty? n))
	     (print-node n)
	     (set! s (cons n s)) ; push n onto stack s
	     (set! n (left n))) ; explore left branch
	    ((not (null? s))
	     (set! n (right (first s))) ; explore right branch
	     (set! s (cdr s))))))) ; pop off the stack
;;;
;;; Similar to depth first search (dfs)
;;; 1. go left, by printing node n, pushing n onto
;;;    the stack s, and making n left of n
;;; 2. When we bottom out on left branch then pop 
;;;    off the stack a new node n, and set n to be the 
;;;    right of n (ie. explore right)
;;; 3. finish when n is empty and s is empty
;;;
;;; General comment ... don't let anyone tell
;;; you that it's easy. Considerable thought required!
;;;
    
(define (insert! e bnode p)
  (cond ((empty? bnode) (make-bnode empty e empty))
	((and (p e (label bnode)) (empty? (left bnode)))
	 (left! bnode (make-bnode empty e empty)))
	((and (not (p e (label bnode))) (empty? (right bnode)))
	 (right! bnode (make-bnode empty e empty)))
	((p e (label bnode)) (insert! e (left bnode) p))
	((not (p e (label bnode))) (insert! e (right bnode) p))))
;;;
;;; Assume that p is <, such that all nodes to the left of
;;; N are less than N, and all nodes to the right of N
;;  are greater than or equal to N 
;;;
;;; Five scenarios to consider
;;; (1) N is empty: deliver (empty e empty), ie new node
;;; (2) e < N and (empty? (left N)): produce new node
;;;     left of N
;;; (3) e > N and (empty? (right N)): produce new node
;;;     right of N
;;; (4) e < N and (not (empty? (left N))): traverse left
;;; (5) e > N and (not (empty? (left N))) ; traverse right
;;;
;;;

(define b (insert! 20 empty <))
(do ((l '(10 30 5 15 25 35 3 7 13 17 23 27 33 37) (cdr l)))
    ((null? l))
  (insert! (car l) b <))
;;;
;;; Binary tree b is now a perfectly balanced tree
;;;

(define (classify bnode)
  (cond ((empty? bnode) -1)
	((leaf? bnode) 0)
	((and (not (empty? (left bnode)))
	      (empty? (right bnode))) 1)
	((and (empty? (left bnode))
	      (not (empty? (right bnode)))) 2)
	((and (not (empty? (left bnode)))
	      (not (empty? (right bnode)))) 3)))
;;;
;;; 0 it is a leaf, 1 it has only a left branch,
;;; 2 it has only a right branch, 3 it has left and right branches
;;; -1 its empty :(
;;;

;;; 
;;; Delete e from a binary tree NON TRIVIAL!!
;;;

(define (get-min-label bnode)
  (cond (*trace* (display (list 'get-min-label (label bnode))) (newline)))
  (cond ((empty? (left bnode)) (label bnode))
	(t (get-min-label (left bnode)))))

(define (delete e bnode)
  (cond (*trace* (display (list 'delete e
				(cond ((not (empty? bnode))
				       (label bnode))))) (newline)))
  (cond ((empty? bnode) empty)
	((= e (label bnode))
	 (case (classify bnode)
	   ((0) empty)
	   ((1) (left bnode))
	   ((2) (right bnode))
	   ((3) (let ((ml (get-min-label (right bnode))))
		  (make-bnode (left bnode) ml (delete ml (right bnode)))))))
	((< e (label bnode))
	 (make-bnode (delete e (left bnode)) (label bnode) (right bnode)))
	((> e (label bnode))
	 (make-bnode (left bnode) (label bnode)(delete e (right bnode))))))

;
; Btree demo 
;

(define (draw-btree bnode)
  (let ((y-inc 20))
    (define (draw-beetree bnode x-lo x x-hi y)
      (cond ((and (not (empty? bnode)) (not (empty? (left bnode))))
	     (let ((lx (quotient (+ x-lo x -1) 2))
		   (ly (+ y y-inc)))
	       (draw-line x y (quotient (+ x-lo x -1) 2) ly 2)
	       (draw-beetree (left bnode) x-lo lx x ly))))
      (cond ((and (not (empty? bnode)) (not (empty? (right bnode))))
	     (let ((rx (quotient (+ x x-hi 1) 2))
		   (ry (+ y y-inc)))
	       (draw-line x y rx ry 2)
	       (draw-beetree (right bnode) x rx x-hi ry)))))
    (clear-graphics!)
    (draw-beetree bnode 20 300 600 30)))

(define (demo n)
  (do ((i 1 (+ i 1))) ((> i n))
    (let ((b (make-bnode empty (random 1000) empty)))
      (do ((i 1 (+ i 1))) ((> i 64))
	(insert! (random 1000) b <))
      (draw-btree b))))

(demo 1)