sicp-3-3-3-representing-tables

#lang racket
(require racket/mpair)

;;;;;;;;;;
;; 3.24 ;;
;;;;;;;;;;

(define (make-key-test-table same-key?)
  ;; Create a procedural table that tests equality of keys using same-key?.
  (define local-table (mlist '*table*))
  (define (my-assoc key records)
    (cond [(empty? records) false]
          [else
            (define record (mcar records))
            (if (same-key? key (mcar record))
              record
              (my-assoc key (mcdr records)))]))
  (define (lookup key)
    (define record (my-assoc key (mcdr local-table)))
    (if record
      (mcdr record)
      false))
  (define (insert! key value)
    (define record (my-assoc key (mcdr local-table)))
    (if record
      (set-mcdr! record value)
      (set-mcdr! local-table
                 (mcons (mcons key value)
                        (mcdr local-table))))
    'ok)
  (define (dispatch m)
    (cond [(eq? m 'lookup-proc) lookup]
          [(eq? m 'insert-proc!) insert!]
          [else (error "Unknown operation -- TABLE" m)]))
  dispatch)

;; tests

(define (same-num? x y) (< (abs (- x y)) 0.1))
(define t1 (make-key-test-table same-num?))
((t1 'insert-proc!) 1.032 'abc)
;; 'ok
((t1 'lookup-proc) 0.998)
;; 'abc

;;;;;;;;;;
;; 3.25 ;;
;;;;;;;;;;

(define (make-flexible-table)
  ;; Create a procedural table of flexible dimension.
  (define local-table (mlist '*table*))
  (define (my-assoc key records)
    (cond [(empty? records) false]
          [else
            (define record (mcar records))
            (if (equal? key (mcar record))
              record
              (my-assoc key (mcdr records)))]))
  (define (lookup key . rest-of-keys)
    (define (lookup-loop k ks tbl)
      (cond [(empty? ks) ; search for record in current table
             (define record (my-assoc k (mcdr tbl)))
             (if record
               (mcdr record)
               false)]
            [else ; recurse through next table or false if none
              (define next-tbl (my-assoc k (mcdr tbl)))
              (if next-tbl
                (lookup-loop (first ks) (rest ks) next-tbl) ; ks is a regular list
                false)]))
    (lookup-loop key rest-of-keys local-table))
  (define (insert! key . args)
    (when (zero? (length args)) (error "No value given -- INSERT!"))
    (define value (last args))
    (define rest-of-keys (drop-right args 1))
    (define (insert-loop! k ks tbl)
      (cond [(empty? ks) ; insert in current table
             (define record (my-assoc k (mcdr tbl)))
             (if record
               (set-mcdr! record value)
               (set-mcdr! tbl
                          (mcons (mcons k value)
                                 (mcdr tbl))))]
            [else ; recurse, creating next table if necessary
              (define next-tbl (my-assoc k (mcdr tbl)))
              (cond [next-tbl
                      (insert-loop! (first ks) (rest ks) next-tbl)]
                    [else
                      (set-mcdr! tbl
                                 (mcons (mlist k)
                                        (mcdr tbl)))
                      (insert-loop! (first ks)
                                    (rest ks)
                                    (mcar (mcdr tbl)))])]))
    (insert-loop! key rest-of-keys local-table)
    'ok)
  (define (dispatch m)
    (cond [(eq? m 'lookup-proc) lookup]
          [(eq? m 'insert-proc!) insert!]
          [else (error "Unknown operation -- TABLE:" m)]))
  dispatch)

;; tests

(define t2 (make-flexible-table))
((t2 'insert-proc!) 1 'a)
;; 'ok
((t2 'insert-proc!) 2 3 'bc)
;; 'ok
((t2 'insert-proc!) 4 5 6 7 'defg)
;; 'ok
((t2 'lookup-proc) 1)
;; 'a
((t2 'lookup-proc) 2 3)
;; 'bc
((t2 'lookup-proc) 4 5 6 7)
;; 'defg

;;;;;;;;;;
;; 3.26 ;;
;;;;;;;;;;

;; Implement one-dimensional tables.  Use the binary search tree representation of
;; sets from section 2.3.3 to organize the list of key-value pairs.

;; Assume keys are integers.

;; mutable binary trees

(define mfirst mcar)
(define (msecond mutable-list) (mcar (mcdr mutable-list)))
(define (mthird mutable-list) (mcar (mcdr (mcdr mutable-list))))

(define (entry tree) (mfirst tree))
(define (left-branch tree) (msecond tree))
(define (right-branch tree) (mthird tree))
(define (make-tree entry left right) (mlist entry left right))

(define (tree-lookup key st) ; searches in log time if tree balanced
  (cond [(empty? st) false]
        [(= key (mcar (entry st))) (entry st)]
        [(< key (mcar (entry st)))
         (tree-lookup key (left-branch st))]
        [else (tree-lookup key (right-branch st))]))

(define (tree-adjoin-set record st)
  (cond [(empty? st) (make-tree record empty empty)]
        [(= (mcar record) (mcar (entry st))) st]
        [(< (mcar record) (mcar (entry st)))
         (make-tree (entry st)
                    (tree-adjoin-set record (left-branch st))
                    (right-branch st))]
        [else (make-tree (entry st)
                         (left-branch st)
                         (tree-adjoin-set record (right-branch st)))]))

;; bst table

(define (make-bst-table)
  ;; Create a procedural table that uses a bst to store records.
  (define local-table (mlist '*table*))
  (define (lookup key)
    (define record (tree-lookup key (mcdr local-table)))
    (if record
      (msecond record)
      false))
  (define (insert! key value)
    (define record (tree-lookup key (mcdr local-table)))
    (if record
      (set-mcdr! record value)
      (set-mcdr! local-table
                 (tree-adjoin-set (mlist key value)
                                  (mcdr local-table))))
    'ok)
  (define (dispatch m)
    (cond [(eq? m 'lookup-bst-proc) lookup]
          [(eq? m 'insert-bst-proc!) insert!]
          [else (error "Unknown message -- DISPATCH" m)]))
  dispatch)

;; test

(define t3 (make-bst-table))
((t3 'insert-bst-proc!) 1 'a)
;; 'ok
((t3 'insert-bst-proc!) 2 'b)
;; 'ok
((t3 'insert-bst-proc!) 3 'c)
;; 'ok
((t3 'lookup-bst-proc) 1)
;; 'a
((t3 'lookup-bst-proc) 2)
;; 'b
((t3 'lookup-bst-proc) 3)
;; 'c

;; I compared the bst table lookup times to regular unordered-list table lookup
;; times using the same set of 100,000 randomized key-value pairs.  About half the
;; uol-table lookup times were 15 ms while all the bst-table lookup times were 0
;; ms.  So I think we are getting log lookup times for the bst table when the keys
;; have been inserted randomly as expected.

;;;;;;;;;;
;; 3.27 ;;
;;;;;;;;;;

(define (fib n)
  (cond [(zero? n) 0]
        [(= n 1) 1]
        [else (+ (fib (sub1 n))
                 (fib (- n 2)))]))

(define (memoize f)
  (define table (make-bst-table))
  (lambda (x)
    (define previously-computed-result ((table 'lookup-bst-proc) x))
    (cond [previously-computed-result
            previously-computed-result]
          [else
            (define result (f x))
            ((table 'insert-bst-proc!) x result)
            result])))

(define memo-fib
  (memoize (lambda (n)
             (cond [(zero? n) 0]
                   [(= n 1) 1]
                   [else (+ (memo-fib (sub1 n))
                            (memo-fib (- n 2)))]))))

;; test

(for ([n (in-range 25 45 5)])
  (printf "n = ~a ~n" n)
  (time (displayln (fib n)))
  (time (displayln (memo-fib n))))
;; n = 25
;; 75025
;; cpu time: 31 real time: 22 gc time: 0
;; 75025
;; cpu time: 0 real time: 0 gc time: 0
;; n = 30
;; 832040
;; cpu time: 125 real time: 132 gc time: 0
;; 832040
;; cpu time: 0 real time: 0 gc time: 0
;; n = 35
;; 9227465
;; cpu time: 1437 real time: 1434 gc time: 0
;; 9227465
;; cpu time: 0 real time: 0 gc time: 0
;; n = 40
;; 102334155
;; cpu time: 15594 real time: 16477 gc time: 32
;; 102334155
;; cpu time: 0 real time: 0 gc time: 0

;; Describe the environment structure created by (memo-fib 3).

;; The lambda of n in the definition of memo-fib will be called the memo-fib
;; lambda.  The lambda of x in the definition of memoize will be called the
;; memoize lambda.

;; memo-fib and memoize are variable names in the global environment.  memo-fib is
;; bound to the result of calling memoize on the memo-fib lambda.  Calling memoize
;; on the memo-fib lambda creates a binding frame E1 below the global environment
;; where the formal parameter f of memoize is bound to the memo-fib lambda, the
;; table is created, and the body of memoize is evaluated.  Evaluating the body of
;; memoize in E1 returns a function object whose defining environment is E1.
;; memo-fib is bound to this function.  This memo-fib function is not the same as
;; the memo-fib lambda.  For example, the memo-fib function has formal parameter
;; x, while the memo-fib lambda has formal parameter n.

;; It might seem weird that memo-fib, a variable bound in the global environment,
;; is bound to a function whose defining environment is not the global
;; environment, but that's what happens when you have local data like table.

;; Calling the memo-fib function on 3 creates a binding frame E2 below E1 where x
;; is bound to 3 and the body of memo-fib is evaluated.  Evaluating the body of
;; memo-fib looks up 3 in the table, does not find it, and so computes (f 3).

;; f is bound to the memo-fib lambda.  So this call creates another binding frame
;; E3 below E1 where n is bound to 3, and the body of the memo-fib lambda is
;; evaluated.  This is where we get the recursive calls to memo-fib(2) and
;; memo-fib(1), and the whole process repeats itself.

;; Explain why memo-fib runs in linear time.

;; memo-fib creates a tree of recursive calls n deep.  Once the function reaches
;; the leaves of the tree and begins to return, it doesn't need to keep returning
;; to the leaves to compute each intermediate fib(k), it just looks up the values
;; of fib(k - 1) and fib(k - 2) in the table and adds them.  So memo-fib only does
;; constant work at each level.

;; Note that defining memo-fib as (memoize fib) would not work because the
;; recursive calls would not be memoized, just the outermost call.