solutions to 3.24 and 3.25. Please review, particularly 3.25

diff --git a/src/sicp/ex3_24.rkt b/src/sicp/ex3_24.rkt
new file mode 100644 (file)
index 0000000..14d25ca
--- /dev/null
+++ b/src/sicp/ex3_24.rkt
@@ -0,0 +1,60 @@
+#lang r5rs
+
+(define error display)
+
+(define (make-table same-key?)
+  (let ((local-table (list '*table*)))
+    (define (assoc key records)
+      (cond 
+        ((null? records) #f)
+        ((same-key? key (car (car 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)
+                  #f))
+            #f)))
+    (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"))))
+    dispatch))
+
+;(define operation-table (make-table equal?))
+;(define get (operation-table 'lookup-proc))
+;(define put (operation-table 'insert-proc!))
+
+#|
+> (define numeric-table 
+    (make-table (lambda (key-1 key-2) (< (abs (- key-2 key-1)) 2))))
+> (define get-val (numeric-table 'lookup-proc))
+> (define put-val (numeric-table 'insert-proc!))
+> (put-val '1 1 1)
+'ok
+> (put-val '4 4 16)
+'ok
+> (get-val '4 4)
+16
+> (get-val '5 4)
+16
+> 
+|#
\ No newline at end of file

diff --git a/src/sicp/ex3_25.rkt b/src/sicp/ex3_25.rkt
new file mode 100644 (file)
index 0000000..2481d26
--- /dev/null
+++ b/src/sicp/ex3_25.rkt
@@ -0,0 +1,83 @@
+#lang r5rs
+
+(define (lookup key table)
+  (let ((record (assoc key (cdr table))))
+    (if record
+        (cdr record)
+        #f)))
+
+(define (assoc key records)
+  (cond ((null? records) #f)
+        ((equal? key (caar records)) (car records))
+        (else (assoc key (cdr records)))))
+
+(define (insert! key value table)
+  (let ((record (assoc key (cdr table))))
+    (if record
+        (set-cdr! record value)
+        (set-cdr! table
+                  (cons (cons key value) (cdr table)))))
+  'ok)
+
+(define (assoc-in key-list records)
+  (if (not (null? key-list))
+      (if (not (null? (cdr key-list)))
+          (assoc-in (cdr key-list) 
+                    (assoc (car key-list) (cdr records)))
+          (assoc (car key-list) (cdr records)))
+      #f))
+
+(define (lookup-in key-list records)
+  (let ((record (assoc-in key-list records)))
+    (if record
+        (cdr record)
+        #f)))
+
+(define (form-table keys value)
+  (cond 
+    ((null? (cdr keys)) (cons (car keys) value))
+    (else (list (car keys)
+                (form-table (cdr keys) value)))))
+
+(define (insert-in! key-list value records)
+  (let loop ((k (car key-list))
+             (ks (cdr key-list))
+             (table (cdr records)))
+    (let ((record (assoc k table)))
+      (if record
+          (if (null? ks)
+              (set-cdr! record value)
+              (loop (car ks) (cdr ks) (cdr record)))
+          (if (null? ks)
+              (set-cdr! table 
+                        (cons (cons k value)
+                              (cdr table)))
+              (set-cdr! records 
+                        (cons (list k
+                                    (form-table ks value))
+                              (cdr records))))))))
+                          
+        
+          
+        
+
+#|
+> (define t (list '*table*
+                  (list 'math
+                        (cons '+ 43)
+                        (cons '- 45)
+                        (cons '* 42))
+                  (list 'letters
+                        (cons 'a 97)
+                        (cons 'b 98))))
+                         
+> (lookup-in '(math +) t)
+43
+> (lookup-in '(math /) t)
+#f
+> (lookup-in '(letters /) t)
+#f
+> (lookup-in '(letters a) t)
+97
+> 
+|#