ompayne
/
sicp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Add insert! for 3.25 

Could do with some tidying up but seems to work OK.
This commit is contained in:
Oliver Payne 2022-05-12 22:57:59 +01:00
parent 2f2e704cf6
commit 791c601d29
1 changed files with 26 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
3_25.rkt
View File

@ -5,40 +5,44 @@
(define (make-table) (define (make-table)
(list '*table*)) (list '*table*))
;;(define (find-record
(define (assoc key records) (define (assoc key records)
(cond ((null? records) false) (cond ((null? records) false)
((equal? key (caar records)) (car records)) ((equal? key (caar records)) (car records))
(else (assoc key (cdr records))))) (else (assoc key (cdr records)))))
(define (table? l) (define (empty? table)
(pair? (cdr l))) (not (list? (cdr table))))
(trace-define (lookup keys table) (trace-define (lookup keys table)
(cond ((null? keys) (cdr table)) (cond ((null? keys) (cdr table))
((not (table? table)) false) ((empty? table) false)
(else (else
(let ((subtable (assoc (car keys) (cdr table)))) (let ((subtable (assoc (car keys) (cdr table))))
(if subtable (if subtable
(lookup (cdr keys) subtable) (lookup (cdr keys) subtable)
false))))) false)))))
(define (insert! key-1 key-2 value table) (define (insert! keys value table)
(let ((subtable (assoc key-1 (cdr table)))) (trace-define (insert-subtable! keys subtable)
(if subtable (if (and (not (null? keys))
(let ((record (assoc key-2 (cdr subtable)))) (not (null? subtable)))
(if record (let* ((key (car keys))
(set-cdr! record value) (record (assoc (car keys) (cdr subtable))))
(set-cdr! subtable (if record
(cons (cons key-2 value) (if (= (length keys) 1)
(cdr subtable))))) (set-cdr! record value))
(set-cdr! table (set-cdr! subtable
(cons (list key-1 (cons (cons key
(cons key-2 value)) (if (= (length keys) 1)
(cdr table))))) value
'()))
(cdr subtable))))
(let ((next-subtable (assoc key (cdr subtable))))
(insert-subtable! (cdr keys) next-subtable)))))
(insert-subtable! keys table)
'ok) 'ok)
(#%require (only racket/base module+)) (#%require (only racket/base module+))
(module+ test (module+ test
@ -46,7 +50,8 @@
(test-begin (test-begin
(define t (make-table)) (define t (make-table))
(insert! 10 10 'a t) (insert! '(10 10) 'a t)
(check-equal? (lookup '(10 10) t) 'a) (check-equal? (lookup '(10 10) t) 'a)
(check-equal? (lookup '(10 10 10) t) false)) (check-equal? (lookup '(10 10 10) t) false)
) (insert! '(20) 'b t)
(check-equal? (lookup '(20) t) 'b)))