SICP Exercise 3.26, nth depth table as a tree

tree-table.scm

(define (make-table . args)
  ;; there is an optional parameter for a function 
  ;; which can check the equality of keys
  (define (default-comp l r)
    (cond ((eq? l r) 'eq)
          ((> l r) 'gt)
          ((< l r) 'lt)))
  
  (define compare-key
    (if (null? args)
        default-comp
        (car args)))
      
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; TABLE HELPERS
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  (define (make-local-table) (cons '*table* '()))
  (define (table-empty? table) (null? (cdr table)))
  
  (define (assoc path table)
    (define (find-or-insert key node)
      (define comp (compare-key (node-key node) key))
      (define (force-exist getter setter)
        (define branch (getter node))
        (if (not (null? branch))
            branch
            ;; if null lets create it and then set it in place of where it was being retrieved
            (let ((new-branch (make-node key '())))
              (setter node new-branch)
              new-branch)))
      (cond ((eq? comp 'eq) node)
            ((eq? comp 'lt) (force-exist node-left set-node-left!))
            ((eq? comp 'gt) (force-exist node-right set-node-right!))))
    
    (define (loop path table)
      (let ((key-head (car path))
            (key-tail (cdr path)))
        (if (null? (cdr table))
          ;; in the event the tree has not been defined we'll create a new node with the
          ;; current key and we'll set that as the tree.
          (let ((new-node (make-node key-head '())))
            (set-cdr! table new-node)))
          
        (let ((sub-node (find-or-insert key-head (cdr table))))
          (if (null? key-tail)
            ;; if the tail is null this means there are no more
            ;; nodes to look up so we'll just return this node.
            sub-node
              
            ;; otherwise we'll continue recursing down the paths of keys
            (loop key-tail (node-table sub-node))))))
    
    (if (null? path)
      "path cannot be null!!!"
      (loop path table)))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; NODE HELPERS
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      
  (define (make-node key value)
    (cons key (cons (cons value '()) (cons '() '()))))
  
  (define node-key car)
  (define node-val caadr)
  (define node-left caddr)
  (define node-right cdddr)
  
  (define (node-table node)
    (define sub-table (cdadr node))
    (if (not (null? sub-table))
      sub-table
      
      ;; if the table does not exist created it and then return it!
      (let ((table (make-local-table)))
        (set-cdr! (cadr node) table)
        table)))
  
  (define (set-node-val! node value) (set-car! (cadr node) value))
  (define (set-node-left! node left) (set-car! (cddr node) left))
  (define (set-node-right! node right) (set-cdr! (cddr node) right))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; MAIN IMPLEMENTATION
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
  ;; local-table will be internal state
  ;; for the procedural object
  (let ((local-table (make-local-table)))
       
    ;; implementation for the lookup method
    (define (lookup-impl path)
      (node-val (assoc path local-table)))
          
    ;; implementation for the insert! method
    (define (insert-impl path value)
      (let ((node (assoc path local-table)))
        (set-node-val! node value)
        'ok))
    
    (define (display-impl)
      (define (display-all . args)
        (map display args))
      
      (define (display-node node padding)
        (if (not (null? node))
            (begin
              (display-node (node-left node) padding)
              (map display padding)
              (display-all "node(" (node-key node) ") = " (node-val node))
              (newline)
              (table-impl (node-table node) (cons "  " padding))
              (display-node (node-right node) padding))))
            
      (define (table-impl table padding)  
        (if (not (table-empty? table))
            (begin
              (map display padding)
              (display "Table:")
              (newline)
              (display-node (cdr table) (cons "  " padding)))))
      
      (table-impl local-table '())
      (newline))
  
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; DISPATCHER
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
    (define (dispatch message . arguments)
      (cond ((eq? message 'lookup)
             (apply lookup-impl arguments))
            
            ((eq? message 'insert)
             (apply insert-impl arguments))
            
            ((eq? message 'display)
             (apply display-impl arguments))
           
            ((eq? message 'empty)
             (table-empty? local-table))
           
            ((eq? message 'debug)
             local-table)
            
            (else (error "Unknown message"))))
    
    dispatch))