#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.