Решение упражнения 2.74 из SICP

22 February, 2008 (11:37) | Решения упражнений

Это упражнение сформулировано довольно обобщенно и допускает достаточно широкий диапазон трактовок. Я предлагаю один из вариантов по мотивам предшествующего раздела книги, который демонстрирует основные идеи.

Итак, пусть в компании Insatiable Enterprises, Inc. есть два отела: разработки (инженерный) и продаж.

В отделе разработки записи о сотрудниках содержат имена, должности и размеры окладов. Запись соединяет поля с помощью операций cons. Сами записи хранятся в списке. Для поиска записи в списке определена специальная процедура поиска.

(define (make-employee name position salary)
  (cons name (cons position salary)))
(define (get-name employee)
  (car employee))
(define (get-position employee)
  (cadr employee))
(define (get-salary employee)
  (cddr employee))
(define employees
  (list (make-employee 'Hugo 'junior 60000)
        (make-employee 'Alyssa 'senior 90000)
        (make-employee 'Eva 'lead 100000)
        (make-employee 'Ben 'senior 110000)))
(define (get-employee name)
  (define (find-employee employees)
    (cond ((null? employees) null)
          ((eq? name (get-name (car employees)))
           (car employees))
          (else (find-employee (cdr employees)))))
    (find-employee employees))

В отделе продаж работают люди опытные и творческие. Поэтому записи о сотрудниках содержат самое главное: имена, размеры окладов и стаж. Запись соединяет поля просто в список. Сами записи задаются в специальная процедуре, возвращающей соответствующую запись по ключу – имени сотрудника.

(define (make-record name salary experience)
  (list 'employee name salary experience))
(define (get-record-name record)
  (cadr employee))
(define (get-record-salary record)
  (caddr employee))
(define (get-record-experience record)
  (cadddr employee))
(define (get-salesman who)
  (cond ((eq? who 'Mike) (make-record 'Mike 200000 5))
        ((eq? who 'Jennifer) (make-record 'Jennifer 180000 3))
        ((eq? who 'Scott) (make-record 'Scott 250000 10))
        (else null)))

Как видим, структуры представления данных в записи и хранения самих записей отличаются друг от друга довольно сильно. Для того, чтобы работать с ними единообразно, мы завернем данные об отделах в пакеты и поместим операции над данными в таблицу типов. В этой таблице тип будет задаваться именем отдела, а операциями будут имена обобщенных операций, например get-record.

(define (install-engineering-department)
  (define (make-employee name position salary)
    (cons name (cons position salary)))
  (define (get-name employee)
    (car employee))
  (define (get-position employee)
    (cadr employee))
  (define (get-salary employee)
    (cddr employee))
  (define employees
    (list (make-employee 'Hugo 'junior 60000)
          (make-employee 'Alyssa 'senior 90000)
          (make-employee 'Eva 'lead 100000)
          (make-employee 'Ben 'senior 110000)))
  (define (get-employee name)
    (define (find-employee employees)
      (cond ((null? employees) null)
            ((eq? name (get-name (car employees)))
             (car employees))
            (else (find-employee (cdr employees)))))
    (find-employee employees))
  (put 'get-record 'engineering get-employee)
  (put 'get-salary 'engineering get-salary)
  'done)

(define (install-sales-department)
  (define (make-record name salary experience)
    (list 'employee name salary experience))
  (define (get-record-name record)
    (cadr employee))
  (define (get-record-salary record)
    (caddr employee))
  (define (get-record-experience record)
    (cadddr employee))
  (define (get-salesman who)
    (cond ((eq? who 'Mike) (make-record 'Mike 200000 5))
          ((eq? who 'Jennifer) (make-record 'Jennifer 180000 3))
          ((eq? who 'Scott) (make-record 'Scott 250000 10))
          (else null)))
  (put 'get-record 'sales get-salesman)
  (put 'get-salary 'sales get-record-salary)
  'done)

а. Теперь мы можем легко написать обобщенную процедуру получения записи сотрудника по его имени и отделу:

(define (get-record name department)
  ((get 'get-record department) name))

б. Для того, чтобы получить зарплату сотрудника, мы сначала добываем из таблицы операцию извлечения информации о зарплате из записи для данного отдела, а затем применяем ее к записи сотрудника, полученной обобщенной процедурой get-record:

(define (get-salary name department)
  ((get 'get-salary department)
   (get-record department name)))

в. Для поиска записи о сотруднике по всем подразделениям будем использовать описанную ниже процедуру, на вход которой достаточно будет передать имя сотрудника и список названий подразделений:

(define (find-employee-record name departments)
  (if (null? departments)
      null
      (let ((record (get-record name (car departments))))
        (if (null? record)
            (find-employee-record name (cdr departments))
            record))))

Здесь при реализации можно было бы использовать библиотечную процедуру findf.

г. Для внесения в систему информации о новых подразделениях достаточно будет установить пакет для соответствующего подразделения, в который включить специфичное для него описание данных о сотрудниках и дополнительно задать новую строку операций в таблице типов, соответствующую этому подразделению, с помощью набора вызовов put:

(define (install-new-department)
  ;; ...
  (put 'get-record 'new get-record-new)
  (put 'get-salary 'new get-salary-new)
  'done)

При этом ничего менять ни в пакетах других подразделений, ни в обобщенных процедурах get-record, get-salary и т.д. не нужно! Именно в этом и заключается наш выигрыш.

Comments

Comment from potters-owl
Date: September 23, 2010, 10:58 am

В этой и других процедурах, определенных для отдела продаж, в аргументах процедуры связана одна переменная, а в теле вместо неё используется другая.
(define (get-record-name record)
(cadr employee))

Comment from potters-owl
Date: September 23, 2010, 12:03 pm

еще несовпадение декларации и использования обобщенной процедуры get-record:
(define (get-record name department)

(get-record department name)

Comment from potters-owl
Date: September 23, 2010, 12:05 pm

А вообще, если читаете комментарии, не подумайте плохого, эти Решения – очень хорошая и объемная работа!

Comment from corund
Date: May 24, 2014, 1:02 am

Чтобы проверить упражнение, используйте реализацию Put и Get из раздела 3.3.3

Comment from Valery
Date: November 8, 2018, 4:46 pm

С момента первого прочтения задания меня не покидало чувство что я чего-то в нём недопонял. Прочитав оригинал задания я понял, что был прав. В русской версии книги неточный перевод пункта б. Вот оригинал этого пункта:
b. Implement for headquarters a get-salary procedure that returns the salary information from a given employee’s record from any division’s personnel file. How should the record be structured in order to make this operation work?
Т.е. процедура get-salary должна принимать на вход запись (RECORD), которая может принадлежать любому сотруднику любого филиала компании и должна возвращать его зарплату. Чтобы функция могла это делать она должна иметь информацию о том какому филиалу принадлежит эта запись. Как извлечь информацию о филиале из записи не храня её в этой записи? Т.е. чтобы функция get-salary могла работать надо ОБЯЗАТЬ ВСЕ ФИЛИАЛЫ включать в записи их сотрудников информацию о том какому филиалу эта запись принадлежит. В книге (даже в русском издании) на это намекается) “Объясните, как должны быть структурированы файлы отдельных подразделений. В частности, какую информацию о типах нужно хранить?”. Для этой цели могут быть использованы функции attach-tag, type-tag, contents и tag из книги.
Так же в задании предполагается, что во всех филиалах (у каждого филиала по своему) каждое поле записи помечено меткой.
Далее привожу мой код полностью. Я его не проверял, т.к. ещё не прочитал п.3.3.3.

;Для создания таблицы можно исп. (это из комментария на http://sicp.sergeykhenkin.com):
(define *op-table* (make-hash))
(define (put op type proc)
(hash-set! *op-table* (list op type) proc))
(define (get op type)
(hash-ref *op-table* (list op type) '()))

;-------------------The functions from the book-----------------------------------------------------
(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-London-division)
(define (tag datum)
(attach-tag 'London datum))
(define (make-employee surname first-name position salary)
(tag (list (cons 'surname surname)
(cons 'first-name first-name)
(cons 'position position)
(cons 'salary salary))))
(define (get-employee-surname employee)
(cdar (contents employee)))
(define (get-employee-first-name employee)
(cdadr (contents employee)))
(define (get-employee-position employee)
(cdaddr (contents employee)))
(define (get-employee-salary employee)
(cdr (cadddr (contents employee))))
(define employees (list (make-employee 'Smith 'Roland 'director 100000)
(make-employee 'Hatson 'Sarah 'accountant 35000)
(make-employee 'Wilson 'Matew 'programmer 55000)))
(define (find-employee surname)
(define (find-employee-iter employees surname)
(cond ((null? employees) null)
((eq? (get-employee-surname (car employees))
surname)
(cons (car employees)
(find-employee-iter (cdr employees) surname)))
(else
(find-employee-iter (cdr employees) surname))))
(find-employee-iter employees surname))
(put 'get-record 'London find-employee)
(put 'get-salary 'London get-employee-salary))

(define (install-Moscow-division)
(define (tag datum)
(attach-tag 'Moscow datum))
(define (make-item key surname salary)
(tag (list (list 'key key)
(list 'surname surname)
(list 'salary salary))))
(define (select-key item)
(cadar (contents item)))
(define (select-surname item)
(cadadr (contents item)))
(define (select-salary item)
(cadr (caddr (contents item))))
(define (make-tree left-tree item right-tree)
(list left-tree item right-tree))
(define (select-left-tree tree)
(car tree))
(define (select-item tree)
(cadr tree))
(define (select-right-tree tree)
(caddr tree))
(define base (make-tree (make-tree null
(make-item 1005 'Petrov 4000)
(make-tree null
(make-tree null
(make-item 1112 'Sidorov 12000)
null)))
(make-item 1210 'Ivanov 5000)
(make-tree (make-tree null
(make-item 1212 'Lutikov 5500)
null)
(make-item 1260 'Vasichkin 7000)
(make-tree null
(make-item 1280 'Glinka 6000)
null))))
(define (find-items surname)
(define (find-items-recur tree)
(if (null? tree)
null
(append (find-items-recur (select-left-tree tree))
(if (eq? (select-surname (select-item tree))
surname)
(select-item tree)
null)
(find-items-recur (select-right-tree tree)))))
(find-items-recur base))
(put 'get-record 'Moscow find-items)
(put 'get-salary 'Moscow select-salary))

(define (get-record surname division)
((get 'get-record division) surname))

(define (get-salary record)
((get 'get-salary (type-tag record)) record))

(define (find-employee-record surname divisions)
(if (null? divisions)
null
(let ((current-division-employees (get-record surname (car divisions)))
(next-division-employees (find-employee-record surname (cdr divisions))))
(if (null? current-division-employees)
next-division-employees
(cons (current-division-employees)
next-division-employees)))))

Write a comment