sicp 2.74

sicp_2_74

;-------------put-get-----------------------------------------
(define global-array '())
 
(define (make-entry k v) (list k v))
(define (key entry) (car entry))
(define (value entry) (cadr entry))
 
(define (put op type item)
  (define (put-helper k array)
    (cond ((null? array) (list(make-entry k item)))
          ((equal? (key (car array)) k) array)
          (else (cons (car array) (put-helper k (cdr array))))))
  (set! global-array (put-helper (list op type) global-array)))
 
(define (get op type)
  (define (get-helper k array)
    (cond ((null? array) #f)
          ((equal? (key (car array)) k) (value (car array)))
          (else (get-helper k (cdr array)))))
  (get-helper (list op type) global-array))
;-------------tag type----------------------------------------
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Íåêîððåêòíûå ïîìå÷åííûå äàííûå -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Íåêîððåêòíûå ïîìå÷åííûå äàííûå -- CONTENTS" datum)))
;-------------------------------------------------------------

(define (install-departament1-package)
;; functions
(define (make-emp name adress salary)
  (list name adress salary)
  )
(define emplist '(("Masha" "Mashin adres" 500)
                 ("Sasha" "Sashin adres" 800)
                 ))
(define (get-name x)(car x))
  (define (salary x)(caddr x))
(define (get-salary name)
  (define (find-emp name1 list)
    (cond ((null? list) "No worker no salary")
          ((equal? (get-name (car list)) name1) (salary (car list)))
          (else (find-emp name1 (cdr list)))))
  (find-emp name emplist)
  )
  (define (find-employee name)
  (define (find-emp name1 list)
    (cond ((null? list) "No worker no salary")
          ((equal? (get-name (car list)) name1) (car list))
          (else (find-emp name1 (cdr list)))))
  (find-emp name emplist)
    )
;; interface
(put 'get-salary 'departament1 get-salary)
(put 'find-employee 'departament1 find-employee)
'done)

(install-departament1-package)

((get 'get-salary 'departament1) "Masha")

(define (install-departament2-package)
;; functions
(define (make-emp name salary)
  (list name salary)
  )
(define emplist '(("Petr"  600)
                 ("Irina"  700)
                 ))
(define (get-name x)(car x))
  (define (salary x)(cadr x))
(define (get-salary name)
  (define (find-emp name1 list)
    (cond ((null? list) "No worker no salary")
          ((equal? (get-name (car list)) name1) (salary (car list)))
          (else (find-emp name1 (cdr list)))))
  (find-emp name emplist)
  )
  (define (find-employee name)
  (define (find-emp name1 list)
    (cond ((null? list) #f)
          ((equal? (get-name (car list)) name1) (car list))
          (else (find-emp name1 (cdr list)))))
  (find-emp name emplist)
    )
;; interface
(put 'get-salary 'departament2 get-salary)
(put 'find-employee 'departament2 find-employee)
'done)

(install-departament2-package)

((get 'get-salary 'departament2) "Irina")

(define deplist '(departament2 departament1))

(define (find-employee-record name deplist)
  (cond ((null? deplist) #f)
        ((eq? ((get 'find-employee (car deplist)) name) #f) 
                                   (find-employee-record name (cdr deplist)))
        (else ((get 'find-employee (car deplist)) name))
  ))

(find-employee-record "Irina" deplist)
(find-employee-record "Masha" deplist)

d. Когда Insatiable поглотит новую компанию, в систему просто нужно будет добавить новый install-departament-package с соответствующей обёрткой внутри