#lang racket
(require gigls/unsafe)
(provide (all-defined-out))
;;; File:
;;;   tree-utils.rkt
;;; Authors:
;;;   Charlie Curtsinger
;;;   Titus Klinge
;;;   Samuel A. Rebelsky
;;; Contents:
;;;   A variety of procedures for working with trees.

; +--------------+---------------------------------------------------
; | Constructors |
; +--------------+

;;; Name:
;;;   empty
;;; Type:
;;;   tree
;;; Value:
;;;   The empty tree
(define empty 'empty)

;;; Procedure:
;;;   leaf
;;; Parameters:
;;;   val, a value
;;; Purpose:
;;;   Make a leaf node.
;;; Produces:
;;;   tree, a tree
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   (contents tree) = val
;;;   (left tree) = empty
;;;   (right tree) = empty
(define leaf
  (lambda (val)
    (node val empty empty)))

;;; Procedure:
;;;   node
;;; Parameters:
;;;   val, a value
;;;   left-subtree, a tree
;;;   right-subtree, a tree
;;; Purpose:
;;;   Create a node in a binary tree.
;;; Produces:
;;;   tree, a tree
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   (node? tree) holds.
;;;   (left tree) = left-subtree.
;;;   (right tree) = right-subtree.
;;;   (contents tree) = val.
(define node
  (lambda (val left right)
    (vector 'node val left right)))

; +-----------+------------------------------------------------------
; | Observers |
; +-----------+

;;; Procedure:
;;;   contents
;;; Parameters:
;;;   nod, a binary tree node
;;; Purpose:
;;;   Extract the contents of node.
;;; Produces:
;;;   val, a value
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   (contents (node val l r)) = val
(define contents
  (lambda (nod)
    (cond
      [(not (node? nod))
       (error "contents requires a node, received" nod)]
      [else
       (vector-ref nod 1)])))

;;; Procedure:
;;;   left
;;; Parameters:
;;;   nod, a binary tree node
;;; Purpose:
;;;   Extract the left subtree of nod.
;;; Produces:
;;;   l, a tree
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   (left (node val l r)) = l
(define left
  (lambda (nod)
    (cond
      [(not (node? nod))
       (error "left requires a node, received" nod)]
      [else
       (vector-ref nod 2)])))

;;; Procedure:
;;;   right
;;; Parameters:
;;;   nod, a binary tree node
;;; Purpose:
;;;   Extract the right subtree of nod.
;;; Produces:
;;;   r, a tree
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   (right (node val l r)) = r
(define right
  (lambda (nod)
    (cond
      [(not (node? nod))
       (error "right requires a node, received" nod)]
      [else
       (vector-ref nod 3)])))

; +------------+-----------------------------------------------------
; | Predicates |
; +------------+

;;; Procedure:
;;;   empty?
;;; Parameters:
;;;   val, a Scheme value
;;; Purpose:
;;;   Determine if val represents an empty tree.
;;; Produces:
;;;   is-empty?, a Boolean 
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   is-empty? is true (#t) if and only if val can be interpreted as
;;;   the empty tree.
(define empty? 
  (l-s eq? empty))

;;; Procedure:
;;;   leaf?
;;; Parameters:
;;;   val, a Scheme value
;;; Purpose:
;;;   Determine if val is a tree leaf
;;; Produces:
;;;   is-leaf?, a Boolean
(define leaf?
  (lambda (val)
    (and (node? val)
         (empty? (left val))
         (empty? (right val)))))

;;; Procedure:
;;;   node?
;;; Parameters:
;;;   val, a Scheme value
;;; Purpose:
;;;   Determine if val can be used as a tree node.
;;; Produces:
;;;   is-node?, a Boolean
(define node?
  (lambda (val)
    (and (vector? val)
         (= (vector-length val) 4)
         (eq? (vector-ref val 0) 'node))))

; +----------+-------------------------------------------------------
; | Examples |
; +----------+

;;; Procedure:
;;;   tree-depth
;;; Parameters:
;;;   tree, a tree
;;; Purpose:
;;;   Determine the depth of tree
;;; Produces:
;;;   depth, an integer
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   depth represents the number of nodes on the path from the root to 
;;;   the furthest leaf.
(define tree-depth
  (lambda (tree)
    (if (empty? tree)
        0
        (+ 1 (max (tree-depth (left tree))
                  (tree-depth (right tree)))))))

; +---------------+--------------------------------------------------
; | Visualization |
; +---------------+

;;; Procedure:
;;;   tree->code
;;; Parameters:
;;;   tree, a tree
;;; Purpose:
;;;   Generate Scheme code to make a tree.
;;; Produces:
;;;   code, a Scheme value
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   code, when evaluated, can give something like tree
(define tree->code
  (lambda (tree)
    (if (empty? tree)
        empty
        (list 'node 
              (contents tree) 
              (tree->code (left tree))
              (tree->code (right tree))))))

;;; Procedure:
;;;   visualize-tree
;;; Parameters:
;;;   tree, a binary tree
;;;   width, a positive integer
;;;   height, a positive integer
;;; Purpose:
;;;   Create a simple image to visualize a tree
;;; Produces:
;;;   image, an image
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   image contains an "appropriate" representation of the tree.
;;;   The context may have been updated.
;;; Problems:
;;;   Doesn't do well with especially bushy trees - these may overlap.
(define visualize-tree
  ; Draw the empty tree
  (let ([draw-empty!
         (lambda (image x y)
           (context-set-fgcolor! "grey")
           (image-select-ellipse! image REPLACE (- x 5) (- y 10) 10 10)
           (image-draw-line! image (- x 5) (- y 10) (+ x 5) y)
           (image-stroke! image)
           (image-select-nothing! image))])
    (lambda (tree width height)
      ; Set the font
      (context-set-font-name! "Monospace")
      (context-set-font-size! 12)
      ; Set the brush
      (context-set-brush! "2. Hardness 100" 0.25)
      (let* (; The resulting image
             [result (image-show (image-new width height))]
             ; The depth of the tree
             [depth (tree-depth tree)]
             ; The height of each level
             [level-height (if (= depth 0) 20
                               (/ (- height 20) (tree-depth tree)))])
        (letrec 
            (; Primary work: Procedure to do a subtree
             [visualize-subtree 
              (lambda (subtree left-edge top-edge subwidth)
                (let ([center-x (+ left-edge (/ subwidth 2))]
                      [center-y (+ top-edge 15)])
                  (cond
                    [(empty? subtree)
                     (draw-empty! result center-x center-y)]
                    [else
                     ; Display the node's value
                     (context-set-fgcolor! "black")
                     (image-display-text! result
                                          (value->string (contents subtree))
                                          center-x center-y
                                          ALIGN-CENTER ALIGN-BOTTOM)
                     (let ([left-child (left subtree)]
                           [right-child (right subtree)]
                           [half-width (/ subwidth 2)]
                           [quarter-width (/ subwidth 4)]
                           [next-top (+ top-edge level-height)])
                       ; Display the links
                       (context-set-fgcolor! "grey")
                       (image-draw-arrow! result
                                          'filled
                                          center-x center-y
                                          (- center-x quarter-width) next-top
                                          5 5)
                       (image-draw-arrow! result
                                          'filled
                                          center-x center-y
                                          (+ center-x quarter-width) next-top
                                          5 5)
                       ; Left subtree
                       (visualize-subtree left-child left-edge next-top half-width)
                       ; Right subtree
                       (visualize-subtree right-child center-x next-top half-width))])))])
          ; Do the whole tree
          (visualize-subtree tree 0 0 width)
          (context-update-displays!)
          result)))))