src/sicp/ex3_26.rkt

   1 #lang r5rs
   2
   3 (define (make-entry k v) (cons k v))
   4 (define (key entry) (car entry))
   5 (define (value entry) (cdr entry))
   6 (define (set-key! entry k) (set-car! entry k))
   7 (define (set-value! entry v) (set-cdr! entry v))
   8 (define (null-entry? e)
   9   (if (null? e)
  10       #t
  11       (or (null? (key e))
  12           (null? (value e)))))
  13
  14 ;(define (set-entry! k v e)
  15 ;  (set-key! k e)
  16 ;  (set-value! v e))
  17
  18 (define (make-node entry left right)
  19   (cons entry (cons left (cons right '()))))
  20
  21 (define (entry-node node) (car node))
  22 (define (left-node node) (car (cdr node)))
  23 (define (right-node node) (car (cdr (cdr node))))
  24
  25 (define (make-tree)
  26   (make-node (make-entry '() '()) '() '()))
  27
  28 (define (entry-tree tree)
  29   (entry-node tree))
  30
  31 (define (left-branch tree)
  32   (left-node tree))
  33
  34 (define (right-branch tree)
  35   (right-node tree))
  36
  37 (define (set-left-branch! tree val)
  38   (set-car! (cdr tree) val))
  39
  40 (define (set-right-branch! tree val)
  41   (set-car! (cdr (cdr tree)) val))
  42
  43 (define (set-entry! tree entry)
  44   (set-car! tree entry))
  45
  46 (define (make-tree-node k v)
  47   (make-node (make-entry k v) '() '()))
  48
  49 (define (lookup k table)
  50   (let ((e (entry-tree table)))
  51     (cond
  52       ((null-entry? e) #f)
  53       ((= k (key e)) (value e))
  54       ((< k (key e)) (lookup k (left-branch table)))
  55       ((> k (key e)) (lookup k (right-branch table))))))
  56
  57 (define (insert! k v table)
  58   (cond
  59     ((null-entry? (entry-tree table)) (set-entry! table (make-entry k v)))
  60     ((= k (key (entry-tree table))) (set-value! (entry-tree table) v))
  61     ((< k (key (entry-tree table)))
  62      (if (null? (left-branch table))
  63          (set-left-branch! table (make-tree-node k v))
  64          (insert! k v (left-branch table))))
  65     ((> k (key (entry-tree table)))
  66      (if (null? (right-branch table))
  67          (set-right-branch! table (make-tree-node k v))
  68          (insert! k v (right-branch table)))))
  69 'ok)