; bst.scm
; Binary search trees
(define (reduce op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(reduce op initial (cdr sequence)))))
;;;
; Pairs
;;;
; Consructors
(define bst-pair cons)
(define bst-pair-empty
(bst-pair '() '()))
; Selectors
(define bst-pair-key car)
(define bst-pair-val cdr)
; Predicate to find out if pair is empty
(define (bst-pair-empty? pair)
(null? (bst-pair-key pair)))
;;;
; Nodes
;;;
; Constructors
(define (bst-node value lchild rchild)
(list value lchild rchild))
(define (bst-root-node value)
(bst-node value '() '()))
(define bst-node-empty
(bst-root-node '()))
; Selectors
(define bst-node-value car)
(define bst-node-lchild cadr)
(define bst-node-rchild caddr)
; Predicate to find out if node is empty
(define (bst-node-empty? node)
(null? (bst-node-value node)))
; Predicate to find out if node is a left (haven't children)
(define (bst-node-leaf? node)
(and (null? (bst-node-lchild node)) (null? (bst-node-rchild node))))
;;;
; Trees
;;;
; Contructors
(define (bst node lbranch rbranch)
(bst-node (bst-node-value node)
lbranch
rbranch))
(define (bst-root tree) tree)
(define bst-empty bst-node-empty)
; Selectors
(define (bst-lbranch tree)
(cond ((null? (bst-node-lchild (bst-root tree))) bst-empty)
(else (bst-node-lchild (bst-root tree)))))
(define (bst-rbranch tree)
(cond ((null? (bst-node-rchild (bst-root tree))) bst-empty)
(else (bst-node-rchild (bst-root tree)))))
; Predicate to find out if tree is empty
(define bst-empty? bst-node-empty?)
; Insertion
(define (bst-insert pair tree)
(cond ((bst-empty? tree) (bst-root (bst-root-node pair)))
((> (bst-pair-key pair)
(bst-pair-key (bst-node-value (bst-root tree))))
(bst (bst-root tree)
(bst-lbranch tree)
(bst-insert pair (bst-rbranch tree))))
(else
(bst (bst-root tree)
(bst-insert pair (bst-lbranch tree))
(bst-rbranch tree)))))
; Searching
(define (bst-find key tree)
(cond ((bst-empty? tree) #f)
((let ((ckey (bst-pair-key (bst-node-value (bst-root tree)))))
(cond ((= key ckey) (bst-pair-val (bst-node-value (bst-root tree))))
((> key ckey) (bst-find key (bst-rbranch tree)))
(else (bst-find key (bst-lbranch tree))))))))
; Traversal
(define (bst-traversal tree)
(let ((value (list (bst-node-value (bst-root tree)))))
(cond ((bst-node-leaf? tree) value)
((bst-node-empty? (bst-rbranch tree))
(append (bst-traversal (bst-lbranch tree)) value))
((bst-node-empty? (bst-lbranch tree))
(append value (bst-traversal (bst-rbranch tree))))
(else
(append (bst-traversal (bst-lbranch tree))
value
(bst-traversal (bst-rbranch tree)))))))
; Deleting
(define (bst-remove key tree)
(cond ((bst-empty? tree) #f)
((let ((ckey (bst-pair-key (bst-node-value (bst-root tree)))))
(cond ((= key ckey) (bst-pair-val (bst-node-value (bst-root tree))))
((> key ckey) (bst-find key (bst-rbranch tree)))
(else (bst-find key (bst-lbranch tree))))))))
;;;
; Sorting using bst
;;;
(define (bst-sort nums)
(reduce cons '() (bst-traversal (reduce bst-insert bst-empty (map (lambda (num) (bst-pair num num)) nums)))))
;;;
; Examples
;;;
(define array
(list (bst-pair 2 "foo!")
(bst-pair 5 "xyz!")
(bst-pair 3 "bar!")
(bst-pair 1 "abc!")))
(define my-tree
(bst-insert (cadddr array) (bst-insert (caddr array) (bst-insert (cadr array) (bst-insert (car array) bst-empty)))))
(display my-tree)
(display (bst-find 7 my-tree))
(map (lambda (pair) (display (bst-pair-val pair))) (bst-traversal my-tree))
(bst-sort (list 8 2 7 0 1 3 5 4))
(define Y (reduce bst-insert bst-empty (map (lambda (num) (bst-pair num (* num 10))) (list 8 2 9 7 0 1 3 5 4))))
(bst-traversal Y)