guile-data-structures/trees/simple-binary-tree/binary-tree.scm

(library (binary-tree)
  (export <tree>
          make-tree
          make-leaf
          make-empty-tree
          make-complete-tree
          make-balanced-tree
          create-balanced-trees-pair

          tree?
          tree-empty?

          tree-value
          tree-left
          tree-right

          set-tree-left
          set-tree-right
          set-tree-value

          tree-leaf?
          tree-member?
          tree-insert
          tree-insert-using-continuation
          tree-insert-with-exception
          tree-depth
          tree-size
          tree-fold
          display-tree

          make-already-exists-exception
          &already-exists
          already-exists?)
  (import (except (rnrs base) error vector-map)
          (only (guile)
                lambda*
                λ
                call-with-output-string
                current-output-port
                display
                error
                even?
                floor
                record-constructor
                simple-format)
          ;; SRFI-9 for structs
          (srfi srfi-9 gnu)
          ;; let-values
          (srfi srfi-11)
          (ice-9 exceptions)
          (string-helpers))


  (define-immutable-record-type <tree>
    (make-tree value left right)
    tree?
    (left tree-left set-tree-left)
    (right tree-right set-tree-right)
    (value tree-value set-tree-value))

  (define-immutable-record-type <empty-tree>
    (make-empty-tree)
    empty-tree?)


  (define make-leaf
    (λ (val)
      (make-tree val
                 (make-empty-tree)
                 (make-empty-tree))))


  (define tree-empty?
    (λ (tree)
      (empty-tree? tree)))


  (define tree-leaf?
    (λ (a-tree)
      (and (tree-empty? (tree-left a-tree))
           (tree-empty? (tree-right a-tree)))))


  ;; tree-member? makes use of a performance trick to reduce the
  ;; number of comparisons needed to find out, whether a value is a
  ;; member or not. The trick is to keep track of a candidate element
  ;; which could be equal to the value that is searched and drawing
  ;; conclusions from comparisons with elements deeper in the tree.
  (define tree-member?
    (λ (a-tree searched-val less)
      (cond
       [(tree-empty? a-tree) #f]
       [else
        (let traverse ([tree° a-tree] [candidate° #f])
          (let ([node-val (tree-value tree°)])
            (cond
             [(less searched-val node-val)
              (let ([left (tree-left tree°)])
                (if (tree-empty? left)
                    ;; Not possible to go deeper left. Compare with
                    ;; candidate.
                    (and candidate°
                         (not (less candidate° searched-val)))
                    ;; Otherwise descent left.
                    (traverse left candidate°)))]
             [else
              (let ([right (tree-right tree°)])
                (cond
                 [(tree-empty? right)
                  ;; Not possible to go deeper right. Compare with
                  ;; candidate.
                  (and node-val
                       (not (less node-val searched-val)))]
                 [else
                  (traverse right node-val)]))])))])))


  ;; The GNU Guile manual recommends to only use
  ;; call-with-current-continuation, when elegance warants it or no
  ;; other simple solution is available. Still putting it here to show
  ;; it.
  (define tree-insert-using-continuation
    (λ (tree insertion-value less)
      (call-with-current-continuation
       (λ (exit-cont)
         (cond
          [(tree-empty? tree) (make-leaf insertion-value)]
          [else
           (let traverse ([tree° tree])
             (let ([node-val (tree-value tree°)])
               (cond
                [(less insertion-value node-val)
                 (set-tree-left tree°
                                (tree-insert-using-continuation (tree-left tree°)
                                                                insertion-value
                                                                less))]
                [(less node-val insertion-value)
                 (set-tree-right tree°
                                 (tree-insert-using-continuation (tree-right tree°)
                                                                 insertion-value
                                                                 less))]
                [else
                 (exit-cont tree)])))])))))


  ;; To use an exception, we define one.
  (define &already-exists (make-exception-type '&already-exists &exception '()))
  (define already-exists? (exception-predicate &already-exists))
  (define make-already-exists-exception
    (λ (irritants)
      (make-exception
       ((record-constructor &already-exists))
       (make-exception-with-message "value already exists in tree")
       (make-exception-with-irritants irritants))))


  (define tree-insert
    (λ (tree insertion-value less)
      (guard (exn [(already-exists? exn) tree])
        (cond
         [(tree-empty? tree) (make-leaf insertion-value)]
         [else
          (let traverse ([tree° tree] [candidate° #f])
            (let ([node-val (tree-value tree°)])
              (cond
               [(less insertion-value node-val)
                ;; Check if left subtree is empty. If it is empty,
                ;; compare with the memorized candidate. If equal to
                ;; the candidate value, raise the exception, otherwise
                ;; insert as a new left subtree.
                (let ([left (tree-left tree°)])
                  (cond
                   [(tree-empty? left)
                    (if (and candidate° (not (less candidate° insertion-value)))
                        (raise-exception
                         (make-already-exists-exception insertion-value))
                        (set-tree-left tree° (make-leaf insertion-value)))]
                   [else
                    (traverse left candidate°)]))]
               [else
                ;; Check if the right subtree is empty. (1) If it is
                ;; empty, compare with the memorized candidate. If the
                ;; candidate is equal to the insertion value, raise
                ;; the exception, otherwise insert the insertion value
                ;; as a new right subtree. (2) If the right subtree is
                ;; not empty, memorize the value at the current node
                ;; and insert into the right subtree.
                (let ([right (tree-right tree°)])
                  (cond
                   [(tree-empty? right)
                    (if (and candidate° (not (less candidate° insertion-value)))
                        (raise-exception
                         (make-already-exists-exception insertion-value))
                        (set-tree-right tree° (make-leaf insertion-value)))]
                   [else
                    (traverse right node-val)]))])))]))))


  (define make-complete-tree
    (λ (fill depth)
      "Build a full binary tree bottom up, enabling to share
already created subtrees for both, left and right, branches
of each next higher level."
      (cond
       [(= depth 0) (make-empty-tree)]
       [else
        (let iter-depth ([tree° (make-leaf fill)]
                         [depth° (- depth 1)])
          (cond
           [(= depth° 0) tree°]
           [else
            (iter-depth (make-tree fill tree° tree°)
                        (- depth° 1))]))])))


  (define tree-depth
    (λ (tree)
      "Calculate the tree depth. That is, how many splits the tree
has in its longest path from the root to any leaf."
      (cond
       [(tree-empty? tree) 0]
       [else
        (+ 1 (max (tree-depth (tree-left tree))
                  (tree-depth (tree-right tree))))])))


  (define create-balanced-trees-pair
    (λ (fill size)
      "Make a pair of balanced trees, one tree of size SIZE and
one tree of SIZE + 1. This is according to the hint in Chris
Okasaki's book 'Purely Functional Data Structures'."
      (simple-format #t "create2 got size: ~a\n" size)
      (values (make-balanced-tree fill (+ size 1))
              (make-balanced-tree fill size))))


  (define make-balanced-tree
    (λ (fill num-nodes)
      "Create a balanced binary tree. Should run in O(log(n)),
where n is the number of nodes."
      (cond
       [(= num-nodes 0)
        (make-empty-tree)]
       [(even? num-nodes)
        (let ([subtree-size (floor (/ (- num-nodes 1) 2))])
          (let-values ([(left-subtree right-subtree)
                        (create-balanced-trees-pair fill subtree-size)])
            (make-tree fill
                       left-subtree
                       right-subtree)))]
       [else
        (let ([subtree-size (/ (- num-nodes 1) 2)])
          (let ([subtree (make-balanced-tree fill subtree-size)])
            (make-tree fill
                       ;; Share equal subtrees, only do half the work.
                       subtree
                       subtree)))])))


  (define tree-size
    (λ (tree)
      (cond
       [(empty-tree? tree) 0]
       [else (+ 1
                (tree-size (tree-left tree))
                (tree-size (tree-right tree)))])))


  (define tree-fold
    (λ (reducing-func neutral-elem tree)
      "Fold operation over a tree. Reduce left branch, then right
branch, then the parent node value."
      (cond
       [(tree-empty? tree) neutral-elem]
       [(tree-leaf? tree)
        (reducing-func (tree-value tree)
                       neutral-elem)]
       [else
        (reducing-func (tree-value tree)
                       (reducing-func
                        (tree-fold reducing-func neutral-elem (tree-left tree))
                        (tree-fold reducing-func neutral-elem (tree-right tree))))])))


  (define display-tree
    (lambda* (tree
              #:optional (port (current-output-port))
              #:key
              (indentation-str "  ")
              (tree-value->string (λ (val) (simple-format #f "~s" val))))
      (define display-value-at-level
        (lambda* (val level)
          (simple-format
           port "~a\n"
           (string-append (string-repeat indentation-str level)
                          (tree-value->string val)))))

      (let iter ([tree° tree] [level 0])
        (display-value-at-level (tree-value tree°) level)
        (cond
         [(tree-leaf? tree°)
          (display-value-at-level 'empty (+ level 1))
          (display-value-at-level 'empty (+ level 1))]

         [(tree-empty? (tree-left tree°))
          (display-value-at-level 'empty (+ level 1))
          (iter (tree-right tree°) (+ level 1))]

         [(tree-empty? (tree-right tree°))
          (iter (tree-left tree°) (+ level 1))
          (display-value-at-level 'empty (+ level 1))]

         [else
          (iter (tree-left tree°) (+ level 1))
          (iter (tree-right tree°) (+ level 1))]))))


  ;; TODO: implement tree-balanced?
  ;; TODO: tree-leaf-count
  )


;; (define tree-leaf-count
;;   (λ (a-tree)
;;     (cond
;;      [(leaf? a-tree) 1]
;;      [(branch-empty? (tree-left a-tree))
;;       (tree-leaf-count (tree-right a-tree))]
;;      [(branch-empty? (tree-right a-tree))
;;       (tree-leaf-count (tree-left a-tree))]
;;      [else (+ (tree-leaf-count (tree-left a-tree))
;;               (tree-leaf-count (tree-right a-tree)))])))