Add exercise 3.24

This commit is contained in:
Oliver Payne 2022-05-10 17:48:42 +01:00
parent 5287954c87
commit d1ffdff403
1 changed files with 55 additions and 0 deletions

55
3_24.rkt Normal file
View File

@ -0,0 +1,55 @@
#lang sicp
(define (make-table same-key?)
(let ((local-table (list '*table*)))
(define (assoc key records)
(cond ((null? records) false)
((same-key? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
false))
false)))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(#%require (only racket/base module+))
(module+ test
(#%require rackunit)
(define (same-key? k1 k2)
(let ((d (abs (- k1 k2))))
(< d 10)))
(test-begin
(define t (make-table same-key?))
((t 'insert-proc!) 10 10 'a)
((t 'insert-proc!) 100 100 'b)
(check-equal? ((t 'lookup-proc) 10 10) 'a)
(check-equal? ((t 'lookup-proc) 11 11) 'a)
(check-equal? ((t 'lookup-proc) 21 21) #f)
(check-equal? ((t 'lookup-proc) 100 100) 'b))
)