165 lines
5.2 KiB
Racket
165 lines
5.2 KiB
Racket
#lang sicp
|
|
|
|
;; UNORDERED
|
|
|
|
(define (element-of-set? x set)
|
|
(cond ((null? set) false)
|
|
((equal? x (car set)) true)
|
|
(else (element-of-set? x (cdr set)))))
|
|
|
|
(define (adjoin-set x set)
|
|
(if (element-of-set? x set)
|
|
set
|
|
(cons x set)))
|
|
|
|
(define (list->set l)
|
|
(if (null? l) '()
|
|
(adjoin-set (car l) (list->set (cdr l)))))
|
|
|
|
;;;-----------
|
|
;;;from section 3.3.3 for section 2.4.3
|
|
;;; to support operation/type table for data-directed dispatch
|
|
|
|
(define (assoc key records)
|
|
(cond ((null? records) false)
|
|
((equal? key (caar records)) (car records))
|
|
(else (assoc key (cdr records)))))
|
|
|
|
(define (make-table)
|
|
(let ((local-table (list '*table*)))
|
|
(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))
|
|
|
|
(define operation-table (make-table))
|
|
(define get (operation-table 'lookup-proc))
|
|
(define put (operation-table 'insert-proc!))
|
|
|
|
;;;-----------
|
|
(define (attach-tag type-tag contents)
|
|
(cons type-tag contents))
|
|
|
|
(define (type-tag datum)
|
|
(if (pair? datum)
|
|
(car datum)
|
|
(error "Bad tagged datum -- TYPE-TAG" datum)))
|
|
|
|
(define (contents datum)
|
|
(if (pair? datum)
|
|
(cdr datum)
|
|
(error "Bad tagged datum -- CONTENTS" datum)))
|
|
|
|
;;(define (lookup given-key set-of-records)
|
|
;;(cond ((null? set-of-records) false)
|
|
;;((equal? given-key (key (car set-of-records)))
|
|
;;(car set-of-records))
|
|
;;(else (lookup given-key (cdr set-of-records)))))
|
|
|
|
|
|
|
|
|
|
;; Division a
|
|
;; File is a tagged set of records. Because we don't mix record types
|
|
;; within files, there is no need to tag the records as well.
|
|
;;
|
|
;; (tag {record1,...,record2})
|
|
|
|
;;(define (make-file-a records)
|
|
;;(attach-tag 'div-a
|
|
;;(cond ((null? records)
|
|
|
|
(define (lookup key)
|
|
(lambda (given-key set-of-records)
|
|
(cond ((null? set-of-records) false)
|
|
((equal? given-key (key (car set-of-records)))
|
|
(car set-of-records))
|
|
(else ((lookup key) given-key (cdr set-of-records))))))
|
|
|
|
|
|
(define (install-div-a-package)
|
|
(define (key record) (car (contents record)))
|
|
(define (tag x) (attach-tag 'div-a x))
|
|
(define (name record) (car record))
|
|
(define (address record) (cadr record))
|
|
(define (salary record) (caddr record))
|
|
(define (make-record name address salary)
|
|
(tag (list name address salary)))
|
|
|
|
(put 'name 'div-a name)
|
|
(put 'address 'div-a address)
|
|
(put 'salary 'div-a salary)
|
|
(put 'lookup 'div-a (lookup key))
|
|
(put 'make-record 'div-a make-record)
|
|
(put 'make-file 'div-a (lambda (l) (tag (list->set l))))
|
|
(put 'get-record 'div-a (lookup key)))
|
|
|
|
(install-div-a-package)
|
|
(define r1 ((get 'make-record 'div-a) "Bob" "Bob's address" 12345))
|
|
(define r2 ((get 'make-record 'div-a) "Alice" "Alice's address" 54321))
|
|
(define file-a ((get 'make-file 'div-a) (list r1 r2)))
|
|
|
|
(define (install-div-b-package)
|
|
(define (key record) (car (contents record)))
|
|
(define (tag x) (attach-tag 'div-b x))
|
|
(define (name record) (car record))
|
|
(define (address record) (caddr record))
|
|
(define (salary record) (cadr record))
|
|
(define (make-record name address salary)
|
|
(tag (list name salary address)))
|
|
|
|
(put 'name 'div-b name)
|
|
(put 'address 'div-b address)
|
|
(put 'salary 'div-b salary)
|
|
(put 'lookup 'div-b (lookup key))
|
|
(put 'make-record 'div-b make-record)
|
|
(put 'make-file 'div-b (lambda (l) (tag (list->set l))))
|
|
(put 'get-record 'div-b (lookup key)))
|
|
|
|
(install-div-b-package)
|
|
(define r3 ((get 'make-record 'div-b) "Peter" "Peter's address" 1111))
|
|
(define r4 ((get 'make-record 'div-b) "Paul" "Paul's address" 2222))
|
|
(define file-b ((get 'make-file 'div-b) (list r3 r4)))
|
|
|
|
(define (get-record name file)
|
|
((get 'get-record (type-tag file)) name (contents file)))
|
|
|
|
(define (get-salary record)
|
|
((get 'salary (type-tag record)) (contents record)))
|
|
|
|
(define (find-employee-record name files)
|
|
(if (null? files) #f
|
|
(let ((file (car files)))
|
|
(or ((get 'get-record (type-tag file)) name (contents file))
|
|
(find-employee-record name (cdr files))))))
|
|
|
|
;; To add a new division, it is necessary to put the corresponding constructors
|
|
;; and selectors into the table with put, ensuring that each record and file is
|
|
;; tagged.
|
|
|
|
;; Possible improvement: Only tag records in the get-record procedure. Then there
|
|
;; is no need to change the record representation.
|