#lang racket
(require gigls/unsafe)
(require rackunit)
(require rackunit/text-ui)

;;; File:
;;;   exam.rkt
;;; Authors:
;;;   The student currently referred to as 000000
;;;   Charlie Curtsinger
;;;   Samuel A. Rebelsky
;;; Contents:
;;;   Code and solutions for Exam 4 2015F.
;;; Citations:
;;;

; +---------+--------------------------------------------------------
; | Grading |
; +---------+

; This section is for the grader's use.

; Problem 1: 
; Problem 2:
; Problem 3:
; Problem 4:
; Problem 5:
; Problem 6:
; Problem 7:
;           ----
;     Total:

;    Scaled:
;    Errors:
;     Times:
;          :
;          :
;          :
;           ----
;     Total:


; +--------------+---------------------------------------------------
; | Counter Prep |
; +--------------+

; Documentation for counter-new appears later in the exam.
(define counter-new
  (lambda (name)
    (vector name 0)))

; +-----------+------------------------------------------------------
; | Problem 1 |
; +-----------+

; Time Spent: 

; Citations:

; Solution:

;;; Procedure:
;;;   tree-map
;;; Parameters:
;;;   proc, 
;;;   tree, 
;;; Purpose:
;;;  
;;; Produces:
;;; 
;;; Preconditions:
;;;
;;; Postconditions:
;;;
(define tree-map
  (lambda (proc tree)
    tree)) ; STUB

; Examples/Tests:


; +-----------+------------------------------------------------------
; | Problem 2 |
; +-----------+

; Time Spent: 

; Citations:

; Solution:

;;; Procedure:
;;;   read-file
;;; Parameters:
;;;   filename, a string
;;; Purpose:
;;;   Read the contents of the given file and return it as a string.
;;; Produces:
;;;   contents, a string
;;; Preconditions:
;;;   (file-exists? filename)
;;;   filename refers to a file that contains text
;;; Postconditions:
;;;   contents represents the contents of the file (including the
;;;     newline characters).
(define read-file
  (lambda (filename)
    "")) ; STUB

;;; Procedure:
;;;   display-file
;;; Parameters:
;;;   filename, a string
;;; Purpose:
;;;   Read the contents of the given file and display them to the screen.
;;; Produces:
;;;   [Nothing; called for the side effect]
;;; Preconditions:
;;;   (file-exists? filename)
;;;   filename refers to a file that contains text
;;; Postconditions:
;;;   The contents of the given file appear on the screen.
(define display-file
  (lambda (filename)
    (newline))) ; STUB

;;; Procedure:
;;;   next-version
;;; Parameters:
;;;   filename, a string
;;; Purpose:
;;;   Identify a "safe" alternate to filename, one that does not already
;;;     exist.
;;; Produces:
;;;   alternate, a string
;;; Preconditions:
;;;   [No additiona]
;;; Postconditions:
;;;   If filename does not exist, alternate is filename.
;;;   If filename exists and has the form BASE.SUFFIX, then
;;;     alternate has the form BASE-i.SUFFIX, where i is the smallest
;;;     positive integer for which BASE-i.SUFFIX does not exist.
;;;   If filename exists and has the form BASE (no suffix), then
;;;     alternate has the form BASE-i, where i is the smallest
;;;     positive integer for which BASE-i does not exist.
(define next-version
  (lambda (filename)
    filename)) ; STUB

;;; Procedure:
;;;   create-file
;;; Parameters:
;;;   lines, a list of strings
;;;   filename, a string
;;; Purpose:
;;;   Writes each element of lines to the file, with a newline after each
;;;   element.
;;; Produces:
;;;   result, a string
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   The filesystem now contains a new version of filename.
;;;   The name of that new file result.
;;;   The lines of the given file are the lines of lines.
(define create-file
  (lambda (lines filename)
    filename)) ; STUB

; Examples/Tests:


; +-----------+------------------------------------------------------
; | Problem 3 |
; +-----------+

; Time Spent: 

; Citations:

; Solution:

;;; Procedure:
;;;   render-pair-structure!
;;; Parameters:
;;;   image, an image
;;;   structure, a non-null pair structure
;;;   left, an integer
;;;   top, an integer
;;; Purpose:
;;;   Renders a pair structure starting at the given location in the 
;;;     given image
;;; Produces:
;;;   [Nothing; called for the side effect]
;;; Preconditions:
;;;   image contains sufficient space for the pair structure.
;;;   0 <= left < (image-width image)
;;;   0 <= top < (image-height image)
(define render-pair-structure!
  (lambda (image structure left top)
    image)) ; STUB

; Examples/Tests:

; +-----------+------------------------------------------------------
; | Problem 4 |
; +-----------+

; Time Spent: 

; Citations:

; Solution:

;;; Procedure:
;;;   vector-join
;;; Parameters:
;;;   vec1, 
;;;   vec2, 
;;; Purpose:
;;;   
;;; Produces:
;;;   NAME, TYPE
;;; Preconditions:
;;;
;;; Postconditions:
;;;   
(define vector-join
  (lambda (vec1 vec2)
    (vector))) ; STUB

; Examples/Tests:


; +-----------+------------------------------------------------------
; | Problem 5 |
; +-----------+

; Time Spent: 

; Citations:

; Solution:

;;; Procedure:
;;;   nest
;;; Parameters:
;;;   n, a non-negative integer
;;;   fun, a unary function
;;; Purpose:
;;;   Build a function that calls fun n times.
;;; Produces:
;;;   nested, a unary function
;;; Preconditions:
;;;   fun must be applicable to the output of fun.  (E.g., if fun returns
;;;     an integer, fun must take an integer as input.)
;;; Postconditions:
;;;   (nested x) = (fun (fun (fun ... (fun x) ...)))
;;;      Where there are n copies of fun.
;;;   nested takes the same type of input as fun.
(define nest
  (lambda (n fun)
    fun)) ; STUB

; Examples/Tests:

; +-----------+------------------------------------------------------
; | Problem 6 |
; +-----------+

; Time Spent: 

; Citations:

; Solution:

;;; Procedure:
;;;   next-largest
;;; Parameters:
;;;   val, a real number
;;;   vec, a vector of real numbers
;;; Purpose:
;;;   Find the smallest value in vec that is greater than val
;;; Produces:
;;;   result, a real number or #f.
;;; Preconditions:
;;;   vec is a vector of real numbers sorted from smallest to largest
;;; Postconditions:
;;;   If vec contains a number greater than val, then result is the
;;;     smallest such number.
;;;   If vec does not contain a number greater than val, then result is #f.
(define next-largest
  (lambda (val vec)
    #f)) ; STUB

; Examples/Tests:


; +-----------+------------------------------------------------------
; | Problem 7 |
; +-----------+

; Time Spent: 

; Citations:

; Solution:

; a.i. Updated version of many-circles that will now count calls 
; to cons, car, cdr, and null? in all of the hepers.

(define many-circles
  (lambda (n)
    (map vshift-drawing
         (map *
              (make-list n 10)
              (map modulo
                   (iota n)
                   (make-list n 10)))
         (map hshift-drawing
              (map *
                   (make-list n 5)
                   (iota n))
              (map scale-drawing
                   (map increment
                        (map modulo
                             (iota n)
                             (make-list n 7)))
                   (make-list n drawing-unit-circle))))))

; Some useful counters.
(define cons-counter (counter-new "cons"))
(define car-counter (counter-new "car"))
(define cdr-counter (counter-new "cdr"))
(define null?-counter (counter-new "null?"))

; Some standard procedures.
(define my-make-list
  (lambda (len val)
    (if (zero? len)
        null
        (cons val (my-make-list (- len 1) val)))))

(define my-iota
  (lambda (n)
    (let kernel [(i 0)]
      (if (= i n)
          null
          (cons i (kernel (+ i 1)))))))

(define my-map
  (lambda (fun lst)
    (if (null? lst)
        null
        (cons (fun (car lst))
              (my-map fun (cdr lst))))))

; b.
;           cons    car     cdr     null?
;     5
;    10
;    20
;    40

; c.
;           cons    car     cdr     null?
;     n       

; d.
(define new-many-circles
  (lambda (n)
    (list drawing-unit-circle)))

; Examples/Tests:

; +--------------+---------------------------------------------------
; | Extra Credit |
; +--------------+

; Time Spent: 

; Citations:

; Solution:

;;; Procedure:
;;;   mystery
;;; Parameters:
;;; 
;;; Purpose:
;;;   
;;; Produces:
;;;   NAME, TYPE
;;; Preconditions:
;;;
;;; Postconditions:
;;;   
(define mystery (l-s l-s l-s))

; Examples/Tests:

; ===================================================================

; THE CODE BELOW THIS LINE WAS SUPPLIED WITH THE EXAM.  PLEASE LEAVE
; IT IN PLACE IN THE ELECTRONIC VERSION OF THE EXAM!

; +------------------+-----------------------------------------------
; | Fun with Strings |
; +------------------+

;;; Procedure:
;;;   string-index-of
;;; Parameters:
;;;   str, a string
;;;   char, a character
;;; Purpose:
;;;   Find the first index of char in str
;;; Produces:
;;;   index, an integer
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   If char appears in str, 
;;;     (string-ref str index) = char
;;;     For all i < index, (string-ref str i) is not char
;;;   If char does not appear in str,
;;;     index is (string-length str)
;;; Practica:
;;;   > (string-index-of "Hello World" #\o)
;;;   4
;;;   > (string-index-of "Hello World" #\z)
;;;   11
(define string-index-of
  (lambda (str char)
    (let ([len (string-length str)])
      (let kernel ([pos 0])
        (if (or (= pos len) (char=? char (string-ref str pos)))
            pos
            (kernel (+ pos 1)))))))

;;; Procedure:
;;;   string-last-index-of
;;; Parameters:
;;;   str, a string
;;;   char, a character
;;; Purpose:
;;;   Find the last index of char in str
;;; Produces:
;;;   index, an integer
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   If char appears in str, 
;;;     (string-ref str index) = char
;;;     For all i > index, (string-ref str i) is not char
;;;   If char does not appear in str,
;;;     index is (string-length str)
;;; Practica:
;;;   > (string-last-index-of "Hello World" #\o)
;;;   7
;;;   > (string-last-index-of "Hello World" #\z)
;;;   11
;;;   > (string-last-index-of "Hello World" #\H)
;;;   0
(define string-last-index-of
  (lambda (str char)
    (let ([len (string-length str)])
      (let kernel ([pos (- len 1)])
        (cond 
          [(< pos 0)
           len]
          [(char=? char (string-ref str pos))
           pos]
          [else
           (kernel (- pos 1))])))))

; +--------------------------------+----------------------------------
; | Generalized Counter Procedures |
; +--------------------------------+

;;; Procedure:
;;;   counter-new
;;; Parameters:
;;;   name, a string
;;; Purpose:
;;;   Create a counter associated with the given name.
;;; Produces:
;;;   counter, a counter
;;; Preconditions:
;;;   [No additional]
;;; Postconditions:
;;;   counter can be used as a parameter to the various counter
;;;   procedures.
;;; Process:
;;;   Counters are two element vectors.  Element 0 is the name, and
;;;   should not change.  Element 1 is the count, and should change.

;;; Procedure:
;;;   counter-count!
;;; Parameters:
;;;   counter, a counter 
;;; Purpose:
;;;   count the counter
;;; Produces:
;;;   counter, the same counter, now mutated
;;; Preconditions:
;;;   counter was created by counter-new (or something similar) and
;;;   has only been modified by the counter procedures.
;;; Postconditions:
;;;   (counter-get counter) gives a number one higher than it 
;;;   did before.
(define counter-count!
  (lambda (counter)
    (vector-set! counter 1 (+ 1 (vector-ref counter 1)))
    counter))

;;; Procedure:
;;;   counter-get
;;; Parameters:
;;;   counter, a counter
;;; Purpose:
;;;   Get the number of times that counter-count! has been called
;;;   on this counter.
;;; Produces:
;;;   count, a non-negative integer
;;; Preconditions:
;;;   counter was created by counter-new and has only been modified
;;;   by the counter procedures.
;;; Postconditions:
;;;   count is the number of calls to counter-new on this counter since
;;;   the last call to counter-reset! on this counter, or since the
;;;   counter was created, if there have been no calls to counter-reset!
(define counter-get
  (lambda (counter)
    (vector-ref counter 1)))

;;; Procedure:
;;;   counter-reset!
;;; Parameters:
;;;   counter, a counter 
;;; Purpose:
;;;   reset the counter
;;; Produces:
;;;   counter, the same counter, now set to 0
;;; Preconditions:
;;;   counter was created by counter-new (or something similar) and
;;;   has only been modified by the other counter procedures.
;;; Postconditions:
;;;   (counter-get counter) gives 0.
(define counter-reset!
  (lambda (counter)
    (vector-set! counter 1 0)
    counter))

;;; Procedure:
;;;   counter-print!
;;; Parameters:
;;;   counter, a counter
;;; Purpose:
;;;   Print out the information associated with the counter.
;;; Produces:
;;;   counter, the same counter
;;; Preconditions:
;;;   counter was created by counter-new and has only been modified
;;;   by the various counter procedures.
;;; Postconditions:
;;;   counter is unchanged.
;;;   The output port now contains information on counter.
;;; Ponderings:
;;;   Why does counter-print! have a bang, given that it doesn't mutate
;;;   it's parameter?  Because it mutates the broader environment - we
;;;   call counter-print! not to compute a value, but to print something.
(define counter-print!
  (lambda (counter)
    (display (vector-ref counter 0))
    (display ": ")
    (display (vector-ref counter 1))
    (newline)))

; +-------------------------+----------------------------------------
; | Drawing Pair Structures |
; +-------------------------+

;;; Procedure:
;;;   render-pair!
;;; Parameters:
;;;   image, an image
;;;   pair, a pair
;;;   left, an integer
;;;   top, an integer
;;; Purpose:
;;;   Draws a pair with the top and left as specified.
;;; Produces:
;;;   [Nothing; called for the side effect]
;;; Preconditions:
;;;   0 <= left < (image-width image)
;;    0 <= top < (image-height image)
(define render-pair!
  (let ([edge 20])
    (lambda (image pair left top)
      (context-set-brush! "2. Hardness 100" 0.25)
      (context-set-fgcolor! "black")
      (let ([middle (+ left edge)]
            [right (+ left edge edge)]
            [bottom (+ top edge)])
        ; Top edge
        (image-draw-line! image left top right top)
        ; Bottom edge
        (image-draw-line! image left bottom right bottom)
        ; Left edge
        (image-draw-line! image left top left bottom)
        ; Middle edge
        (image-draw-line! image middle top middle bottom)
        ; Right edge
        (image-draw-line! image right top right bottom)
        ; Potential null in left box
        (when (null? (car pair))
          (image-draw-line! image middle top left bottom))
        ; Potential null in top box
        (when (null? (cdr pair))
          (image-draw-line! image right top middle bottom))))))

;;; Procedure:
;;;   render-value!
;;; Parameters:
;;;   image, an image
;;;   value, a Scheme value
;;;   x, an integer
;;;   top, an integer
;;; Purpose:
;;;   Render the given value horizontally centered at x with top at top.
;;; Produces:
;;;   [Nothing; called for the side effect]
;;; Preconditions:
;;;   0 <= x < (image-width image)
;;;   0 <= top < (image-height image)
(define render-value!
  (lambda (image val x top)
    ; Set the font
    (context-set-font-name! "Monospace Bold")
    (context-set-font-size! 12)
    (image-display-text! image
                         (value->string val)
                         x top
                         ALIGN-CENTER ALIGN-TOP)))

;;; Procedure:
;;;   simple-arrow!
;;; Parameters:
;;;   image, an image
;;;   x1, a real number
;;;   y1, a real number
;;;   x2, a real number
;;;   y2, a real number
;;; Purpose:
;;;   Draw an arrow from (x1,y1) to (x2,y2)
;;; Produces:
;;;   [Nothing; called for the side effects]
(define simple-arrow!
  (lambda (image x1 y1 x2 y2)
    (image-draw-arrow! image
                       'filled
                       x1 y1 
                       x2 y2
                       5 5)))

;;; Procedure:
;;;   struct-width
;;; Parameters:
;;;   struct, a pair structure
;;; Purpose:
;;;   Compute the "width" of a pair structure (in cons cells)
;;; Produces:
;;;   width, a non-negative integer
;;; Ponderings:
;;;   Used primarily for computing the appropriate size for an
;;;   image to contain a pair structure.
(define struct-width
  (lambda (struct)
    (if (pair? struct)
        (max (+ 1 (struct-width (cdr struct)))
             (struct-width (car struct)))
        0)))

;;; Procedure:
;;;   struct-height
;;; Parameters:
;;;   struct, a pair structure
;;; Purpose:
;;;   Generate the "height" of a pair structure when using the
;;;   standard rendering.
;;; Produces:
;;;   height, a real number
(define struct-height
  (lambda (struct)
    (cond
      [(null? struct)
       0]
      [(pair? struct)
       (max (+ 1 (struct-height (car struct)))
            (struct-height (cdr struct)))]
      [else
       1/2])))

;;; Procedure:
;;;   illustrate-pair-structure
;;; Parameters:
;;;   struct, a pair structure with at least one pair
;;; Purpose:
;;;   Create an illustration of struct
;;; Produces:
;;;   imag, an image
(define illustrate-pair-structure
  (lambda (struct)
    (let* ([width (struct-width struct)]
           [height (struct-height struct)]
           [image (image-new (+ 20 (* 40 width) (* 20 (- width 1)))
                             (+ 20 (* 20 height) (* 30 (- height 1))))])
      (image-show image)
      (render-pair-structure! image struct 10 10)
      image)))

; +-------------------+----------------------------------------------
; | Tree 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)))

; +----------------+-------------------------------------------------
; | Tree 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)])))

; +-----------------+------------------------------------------------
; | Tree 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))))

; +----------------------+-------------------------------------------
; | Tree Characteristics |
; +----------------------+

;;; 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)))))))

; +--------------------+---------------------------------------------
; | 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)))))