learning-sicp

My embarrassing half assed SICP run.
git clone https://kaka.farm/~git/learning-sicp
Log | Files | Refs

exercise-25.scm (3955B)

      1 (define-library (sicp solutions chapter-3 exercise-25)
      2   (import (scheme base))
      3   (import (scheme write))
      4 
      5   (export
      6    make-table
      7    )
      8 
      9   (begin
     10     (define (make-table)
     11       "Returns a dispatch procedure which accepts a symbol and returns the
     12 procedure associated with that symbol, if there is no procedure
     13 associated with that symbol, raise an error."
     14       (let ((local-table (list '*table*)))
     15         ;; A table is a cons whose car is the symbol '*table* and its
     16         ;; cdr is an inner-table.  An inner-table is a list whose
     17         ;; members are conses whose cars are symbols, the keys of the
     18         ;; values, and its cdrs are either inner-table or the value of
     19         ;; the sequence of symbols (keys) leading to the value.
     20         (define (lookup keys)
     21           "Accept KEYS, a list of symbols.
     22 
     23 Returns the value associated with KEYS.
     24 
     25 If KEYS is empty, raise an error."
     26 
     27           (display `(lookup keys ,keys local-table ,local-table)) (newline)
     28 
     29           (when (null? keys)
     30             (error "KEYS must not be an empty list."))
     31 
     32           (define (lookup' current-keys current-inner-table-or-value)
     33             "Accept CURRENT-KEYS, a list of symbols, and
     34 CURRENT-INNER-TABLE-OR-VALUE, which may be an inner-table or a value
     35 if CURRENT-KEYS is empty.
     36 
     37 Returns the value associated with the topmost CURRENT-KEYS if at each
     38 level there is a key associated with an inner-table / value.
     39 
     40 Returns #f if one of the keys are not found.
     41 
     42 XXX: Not actually what it does. Update ``in the future''."
     43 
     44             (display `(lookup' current-keys ,current-keys
     45                                current-inner-table-or-value ,current-inner-table-or-value)) (newline)
     46 
     47             (if (null? current-keys)
     48                 (list current-inner-table-or-value)
     49                 (let ([record (assq (car current-keys)
     50                                     current-inner-table-or-value)])
     51                   (if record
     52                       (let* ([result (lookup' (cdr current-keys)
     53                                               record)]
     54                              [result-value (cdr result)])
     55                         (list result-value))
     56                       #f))))
     57 
     58 
     59 
     60           (let ([result (lookup' keys
     61                                  (cdr local-table))])
     62             ;; RESULT is either a (list value) if all keys match, else
     63             ;; an #f.
     64             (if result
     65                 (car result)
     66                 #f)))
     67 
     68         (define (build-table keys value)
     69           (if (null? keys)
     70               value
     71               (list (cons (car keys)
     72                           (build-table (cdr keys)
     73                                        value)))))
     74 
     75         (define (insert! keys value)
     76           (define (insert!' current-keys current-table)
     77             "CURRENT-KEYS is a list of symbols. CURRENT-TABLE is a cons of (symbol . alist)."
     78 
     79             (let ([record (assq (car current-keys)
     80                                 (cdr current-table))])
     81               (display `(insert! record ,record)) (newline)
     82               (if record
     83                   (if (null? (cdr current-keys))
     84                       (set-cdr! record value)
     85                       (insert!' (cdr current-keys)
     86                                 record))
     87                   (begin
     88                     (set-cdr! current-table
     89                               (cons (build-table current-keys
     90                                                  value)
     91                                     (cdr current-table)))))))
     92 
     93           (insert!' keys local-table)
     94 
     95           'ok)
     96 
     97         (define (dispatch m)
     98           "Accepts M which is a symbol. Either M is 'lookup, 'insert!, or an
     99 unrecognised symbol - resulting with an error."
    100           (cond
    101            ((eq? m 'lookup) lookup)
    102            ((eq? m 'insert!) insert!)
    103            ((eq? m 'local-table) local-table)
    104            ((eq? m 'build-table) build-table)
    105            (else (error (format #f "Unknown TABLE method: ~a" m)))))
    106 
    107         dispatch))))