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

29 February, 2008 (21:04) | Решения упражнений

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

Реализация этой идеи в виде процедур приводится ниже:
(define (coerce arg type)
  (if (eq? (type-tag arg) type)
      arg
      (let ((arg->type (get-coercion (type-tag arg) type)))
        (if arg->type
            (arg->type arg)
            false))))

(define (coerce-all args type)
  (if (null? args)
      '()
      (let ((first (coerce (car args) type))
            (rest (coerce-all (cdr args) type)))
        (if (and first rest)
            (cons first rest)
            false))))

(define (apply-with-coercion op args types)
  (if (null? types)
      (error "Нет метода для этих типов"
             (list op types))
      (let ((type (car types)))
        (let ((coerced-args (coerce-all args type)))
          (if coerced-args
              (apply apply-generic (cons op coerced-args))
              (apply-with-coercion op args (cdr types)))))))

(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (apply-with-coercion op args type-tags)))))

Процедура apply-generic использует процедуру apply-with-coercion, которая  пытается найти подходящую операцию для аргументов, приведенных к одному типу из набора. Та в свою очередь использует coerce-all, которая приводит все аргументы к заданному типу (либо возвращает ложь, если это невозможно). coerce-all использует процедуру coerce для приведения одного аргумента к заданному типу.

Однако и разработанная обобщенная процедура приведения типов не всесильна. Если у нас в системе возможны операции со смешанными типами, то мы можем не найти подходящий набор приведений, хотя он и существует. Рассмотрим пример с целыми числами, рациональными и комплексными. Предположим, что операция возведения в степень задана для комплексного и рационального числа (то есть мы умеем возводить комплексное число в рациональную степень). Мы также умеем приводить целые числа к рациональным, а рациональные к комплексным. Тем не менее, если мы вызовем обобщенную операцию возведения в степень для комплексного числа и целого, мы не получим ожидаемого результата.

Почему так происходит? Потому что apply-generic сначала попытается найти процедуру возведения в степень, заданную для комплексного и целого аргументов. Такой операции в таблице типов нет, поэтому будут предприняты попытки приведения типов. Сначала попытаемся привести тип второго аргумента к типу первого. Предположим, это удается, так как целое в принципе можно привести к комплексному. Однако операции возведения в степень для двух комплексных чисел у нас в системе нет. Теперь попытаемся привести первый аргумент к типу второго. Это не получается, так как комплексное число в общем случае не приводится к целому.

В то же время, мы могли бы привести второй целочисленный аргумент к рациональному типу и найти имеющуюся операцию.

Comments

Comment from Sergey Khenkin
Date: February 29, 2008, 11:12 pm

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

Comment from gorilych
Date: August 17, 2008, 11:14 am


(if (null? types)
(error "Нет метода для этих типов"
(list op types))

список типов всегда пуст в ошибке. ошибка в выведении ошибки….

Comment from thror
Date: May 1, 2009, 10:05 pm

уважаемый горилыч:) ошибка к сожалению не только в выводе ошибки. Дело в том, что данная реализация apply-generic так же подвержена проблеме из упражнения 2.81. Когда типы аргументов одинаковы, но операция для этих типов не определена-программа войдет в бесконечный цикл. В то же время ее легко исправить, чтоб такого не происходило. Вот код.

Comment from thror
Date: May 3, 2009, 11:12 am


(define (coercion arg type)
(if (eq? (type-tag arg) type)
(cons 'skip arg)
(let ((arg->type (get-coercion (type-tag arg) type)))
ç(if arg->type
ç (cons 'done (arg->type arg))
ç (cons 'fail '())))))

(define (coercion-all args type)
(if (null? args)
(cons 'skip '())
(let ((hd (coercion (car args) type))
ç (tl (coercion-all (cdr args) type)))
ç(let ((hd-stat (car hd))
ç (hd-info (cdr hd))
ç (tl-stat (car tl))
ç (tl-info (cdr tl)))
ç (cond ((and (eq? hd-stat 'skip) (eq? tl-stat 'skip))
çç (cons 'skip (cons hd-info tl-info)))
çç((or (eq? hd-stat 'fail) (eq? tl-stat 'fail))
çç (cons 'fail '()))
çç(else (cons 'done (cons hd-info tl-info))))))))

(define (apply-with-coercion op args types)
(if (null? types)
(error "No method for these types -- APPLY-WITH-COERCION"
ç (list op (map type-tag args)))
(let ((coerced-args (coercion-all args (car types))))
ç(if (eq? (car coerced-args) 'done)
ç (apply apply-generic (cons op (cdr coerced-args)))
ç (apply-with-coercion op args (cdr types))))))

(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
ç (apply proc (map contents args))
ç (apply-with-coercion op args type-tags)))))

Comment from thror
Date: May 3, 2009, 11:25 am

И кроме того, каждый кто читал книгу, обращал внимание на сноску 51:) ответ-да, нам не страшно внести в нашу систему требуемый уровень изощренности. Приведу определение новой функции search-coercion производящей поиск по “графу” зависимости типов (граф задается таблицей приведения типов, выполняющей роль матрицы смежности. К таблице добавляется функция get-coercion-row, возвращающая строку таблицы как список пар , реализовать которую вы можете самостоятельно, или смотрите пост ниже)

;;; SICP: ch2-generic/coercion-search/search/problem

(define (make-step action result)
(cons action result))

(define (step-action step)
(car step))

(define (step-result step)
(cdr step))

;;

(define (make-problem initial-state successor-fn goal-test step-cost)
(cons (cons '() '())
ç(cons (cons initial-state successor-fn)
ç (cons goal-test step-cost))))

(define (problem-state=? problem)
(caar problem))

(define (problem-state<? problem)
(cdar problem))

(define (problem-initial-state problem)
(caadr problem))

(define (problem-successor-fn problem)
(cdadr problem))

(define (problem-goal-test problem)
(caddr problem))

(define (problem-step-cost problem)
(cdddr problem))

(define (set-problem-state=? problem state=?)
(set-car! (car problem) state=?))

(define (set-problem-state<? problem state<?)
(set-cdr! (car problem) statetype (search-coercion (type-tag arg) type)))
ç(if arg->type
ç (cons 'done (arg->type arg))
ç (cons 'fail '())))))

(define (coercion-all args type)
(if (null? args)
(cons 'skip '())
(let ((hd (coercion (car args) type))
ç (tl (coercion-all (cdr args) type)))
ç(let ((hd-stat (car hd))
ç (hd-info (cdr hd))
ç (tl-stat (car tl))
ç (tl-info (cdr tl)))
ç (cond ((and (eq? hd-stat 'skip) (eq? tl-stat 'skip))
çç (cons 'skip (cons hd-info tl-info)))
çç((or (eq? hd-stat 'fail) (eq? tl-stat 'fail))
çç (cons 'fail '()))
çç(else (cons 'done (cons hd-info tl-info))))))))

(define (apply-with-coercion op args types)
(if (null? types)
(error "No method for these types -- APPLY-WITH-COERCION"
ç (list op (map type-tag args)))
(let ((coerced-args (coercion-all args (car types))))
ç(if (eq? (car coerced-args) 'done)
ç (apply apply-generic (cons op (cdr coerced-args)))
ç (apply-with-coercion op args (cdr types))))))

(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
ç (apply proc (map contents args))
ç (apply-with-coercion op args type-tags)))))

Comment from thror
Date: May 3, 2009, 11:29 am

ррр… Че то обрезалось все. Ладно, все равно-полный код всей системы, а так же кучу всего нового дополнительно к списку упражнений сикп вы можете найти но адресу http://www.uic.nnov.ru/~kuaa29

Comment from thror
Date: May 4, 2009, 5:00 pm

в частности для данного упражнения:
– реализация автоматического поиска по графу зависимости типов и автоматическое формирование функции приведения
– улучшенная стратегия для apply-generic позволяющая в некотором смысле оптимально и главное гарантированно, если это возможно, привести типы аргументов функции к таким, для которых функция определена
– и многое многое другое (список расширений стандартного набора упражнений будет опубликован на странице)

Comment from thror
Date: May 4, 2009, 5:01 pm

а этот прожект в целом слишком слабый и поверхностный на мой взгляд

Comment from anonymous
Date: December 14, 2010, 11:49 am

Однако этот прожект всё ещё онлайн, а http://www.uic.nnov.ru/~kuaa29 уже нет…

Comment from anonymous
Date: December 14, 2010, 12:27 pm

(define (apply-generic op . args)
(let*([type-tags (map type-tag args)]
[proc (get op type-tags)])
(cond [proc
(apply proc (map contents args))]
[else
(define (exhaustion rest)
(if (null? rest)
(error "Нет метода для этих типов"
(list op type-tags))
(let*([this-type (type-tag (car rest))]
[this-proc (get op this-type)])
(if this-proc
(let ([newargs (coercion2type this-type args type-tags)])
(if newargs
(apply this-proc (map contents newargs))
(exhaustion (cdr rest))))
(exhaustion (cdr rest))))))
(exhaustion args)])))

(define (coercion2type type args args-types)
(if (null? args)
null
(let*([t (car args-types)]
[coercion-proc
(if (eq? t type)
(λ(a)a)
(get-coercion t type))])
(if coercion-proc
(let ([rest-args (coercion2type type (cdr args) (cdr args-types))])
(if rest-args
(cons (coercion-proc (car args)) rest-args)
#f))
#f))))

Comment from Максим
Date: December 22, 2014, 1:50 am

Хорошо, а если у нас получается (apply-generic ‘add *10 комплексных чисел допустим, не имеет значения*) – процедура (get ‘add ‘(complex complex complex complex … )) вернёт что то адекватное? У вас при первой итерации apply-with-coercion, безусловно, всё приведется к самому “высокому” супертипу (если рассматривать наши типы в виде tower), но я в упор не вижу что главная процедура apply-generic будет делать с операцией для 10 типов, ведь записи в таблице приведения имеют лишь два типа. Либо я херово читал ваш код, либо херово разобрался в спецификации процедуры get.

Comment from hi_artem
Date: April 2, 2015, 11:48 am

У любого кто приступил к этому заданию будет проблема, так как процедуры get и put пока не реализованы.
Я их нагуглил.
На всякий случай я привожу полностью рабочий пример. В него собраны все пакеты.
Для проверки работы операций с несколькими аргументами я добавил процедуру add3

Ну и собственно реализация apply-generic получилась очень простенькой (собственно ровно с тем как ставилась задача). Я повзаимствовал идею о том, что если нет правильной процедуры приведения, то оставляем аргумент как есть. Это не приводит к проблемам.
По крайне мере на всех моих тестовых данных все ОК

;;=========== put/get procedures====================================
;;
(define *op-table* (make-hash-table))

(define (put op type proc)
  (hash-table/put! *op-table* (list op type) proc))

(define (get op type)
  (hash-table/get *op-table* (list op type) #f))

;;============ put/get coercion procedures =========================

 (define *coercion-table* (make-equal-hash-table))

 (define (put-coercion type1 type2 proc)
   (hash-table/put! *coercion-table* (list type1 type2) proc))

 (define (get-coercion type1 type2)
   (hash-table/get *coercion-table* (list type1 type2) #f))

;;====== Installing coercions========================================
 (define (install-coercion-package)
   (define (scheme-number->complex n)
     (make-complex-from-real-imag (contents n) 0))

   (define (scheme-number->rational n)
       (make-rational (contents n) 1))

   (define (complex->rational  n )  ;;в моем мире все комплексные числа приводятся к рациональной 1/2
       (make-rational 1 2))         ;;для тестирования это ОК


    (put-coercion 'scheme-number 'rational scheme-number->rational)
    (put-coercion 'scheme-number 'complex scheme-number->complex)
    (put-coercion 'complex 'rational complex->rational)
    'done)

;;======================================================================
(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 (add x y) (apply-generic 'add x y))
(define (add3 x y z) (apply-generic 'add3 x y z))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))

(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))


;;======== Начнем с установки пакета для работы с обычными числами
(define (install-scheme-number-package)
  (define (tag x)
    (attach-tag 'scheme-number x))
  (put 'add '(scheme-number scheme-number)
      (lambda (x y) (tag (+ x y))))

  (put 'add3 '(scheme-number  scheme-number scheme-number)
      (lambda (x y z) (tag (+ x y z))))


  (put 'sub '(scheme-number scheme-number)
      (lambda (x y) (tag (- x y))))

  (put 'mul '(scheme-number scheme-number)
    (lambda (x y) (tag (* x y))))

  (put 'div '(scheme-number scheme-number)
    (lambda (x y) (tag (/ x y))))

  (put 'make 'scheme-number
    (lambda (x) (tag x)))
'done)

;;======= Rational package
(define (install-rational-package)
  ; внутренние процедуры
  (define (numer x) (car x))
  (define (denom x) (cdr x))

  (define (make-rat n d)
      (let ((g (gcd n d)))
            (cons (/ n g) (/ d g))))

  (define (add-rat x y)
      (make-rat (+  (* (numer x) (denom y))
                    (* (numer y) (denom x)))
                (* (denom x) (denom y))))
  (define (sub-rat x y)
      (make-rat (-  (* (numer x) (denom y))
                    (* (numer y) (denom x)))
                (* (denom x) (denom y))))

  (define (mul-rat x y)
        (make-rat (* (numer x) (numer y))
                  (* (denom x) (denom y))))
  (define (div-rat x y)
        (make-rat (* (numer x) (denom y))
                  (* (denom x) (numer y))))

  ;; интерфейс к остальной системе
  (define (tag x) (attach-tag 'rational x))

  (put 'add '(rational rational) (lambda (x y) (tag (add-rat x y))))


  (put 'add3 '(rational rational rational)
     (lambda (x y z) (tag  (add-rat z (add-rat x y)))))

  (put 'sub '(rational rational) (lambda (x y) (tag (sub-rat x y))))
  (put 'mul '(rational rational) (lambda (x y) (tag (mul-rat x y))))
  (put 'div '(rational rational) (lambda (x y) (tag (div-rat x y))))
  (put 'make 'rational (lambda (n d) (tag (make-rat n d))))
'done)

(define (make-rational n d)
    ((get 'make 'rational) n d))



;;======= Rect and Polar packages
(define (install-rectangular-package)
  ;; внутренние процедуры
  (define (real-part z) (car z))
  (define (imag-part z) (cdr z))
  (define (make-from-real-imag x y) (cons x y))
  (define (magnitude z)
      (sqrt (+  (square (real-part z))
                (square (imag-part z)))))
  (define (angle z)
    (atan (imag-part z) (real-part z)))

  (define (make-from-mag-ang r a)
        (cons (* r (cos a)) (* r (sin a))))

  ;; интерфейс к остальной системе
  (define (tag x) (attach-tag 'rectangular x))
  (put 'real-part '(rectangular) real-part)
  (put 'imag-part '(rectangular) imag-part)
  (put 'magnitude '(rectangular) magnitude)
  (put 'angle '(rectangular) angle)
  (put 'make-from-real-imag 'rectangular
          (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'rectangular
          (lambda (r a) (tag (make-from-mag-ang r a))))
'done)

(define (install-polar-package)
  ; внутренние процедуры
  (define (magnitude z) (car z))
  (define (angle z) (cdr z))
  (define (make-from-mag-ang r a) (cons r a))
  (define (real-part z)
      (* (magnitude z) (cos (angle z))))
  (define (imag-part z)
      (* (magnitude z) (sin (angle z))))
  (define (make-from-real-imag x y)
            (cons (sqrt (+ (square x) (square y)))
                  (atan y x)))

  ;; интерфейс к остальной системе
  (define (tag x) (attach-tag 'polar x))
  (put 'real-part '(polar) real-part)
  (put 'imag-part '(polar) imag-part)
  (put 'magnitude '(polar) magnitude)
  (put 'angle '(polar) angle)
  (put 'make-from-real-imag 'polar
      (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'polar
      (lambda (r a) (tag (make-from-mag-ang r a))))
'done)


;;========  Complex package ====================
(define (install-complex-package)
  ;; процедуры, импортируемые из декартова
  ;; и полярного пакетов
  (install-rectangular-package)
  install-polar-package)

  (define (make-from-real-imag x y)
          ((get 'make-from-real-imag 'rectangular) x y))

  (define (make-from-mag-ang r a)
        ((get 'make-from-mag-ang 'polar) r a))

  ;; внутренние процедуры
  (define (add-complex z1 z2)
          (make-from-real-imag  (+ (real-part z1) (real-part z2))
                                (+ (imag-part z1) (imag-part z2))))

  (define (sub-complex z1 z2)
          (make-from-real-imag  (- (real-part z1) (real-part z2))
                                (- (imag-part z1) (imag-part z2))))

  (define (mul-complex z1 z2)
          (make-from-mag-ang (* (magnitude z1) (magnitude z2))
                              (+ (angle z1) (angle z2))))

  (define (div-complex z1 z2)
          (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
                              (- (angle z1) (angle z2))))

  ;; интерфейс к остальной системе
    (define (tag z) (attach-tag 'complex z))
    (put 'add '(complex complex)
        (lambda (z1 z2) (tag (add-complex z1 z2))))
    (put 'sub '(complex complex)
        (lambda (z1 z2) (tag (sub-complex z1 z2))))
    (put 'mul '(complex complex)
        (lambda (z1 z2) (tag (mul-complex z1 z2))))
    (put 'div '(complex complex)
        (lambda (z1 z2) (tag (div-complex z1 z2))))
    (put 'make-from-real-imag 'complex
        (lambda (x y) (tag (make-from-real-imag x y))))
    (put 'make-from-mag-ang 'complex
        (lambda (r a) (tag (make-from-mag-ang r a))))
'done)

(define (make-from-real-imag x y)
    ((get 'make-from-real-imag 'rectangular) x y))
(define (make-from-mag-ang r a)
    ((get 'make-from-mag-ang 'polar) r a))

(define (make-complex-from-real-imag x y)
    ((get 'make-from-real-imag 'complex) x y))


(define (make-scheme-number d)
    ((get 'make 'scheme-number) d))
(install-coercion-package)
(install-complex-package)
(install-rational-package)
(install-scheme-number-package)



;;====Ну и собственно apply-generic =====================================================================
;;
(define (apply-generic op . args)
  (define (app-recur op tagList coerced_args) ;; tagList - список тагов. Уменьшаеся с каждой итерацией.
                                              ;; Все аргументы приводим к типу (car tagList)
    (let ((type-tags (map type-tag coerced_args)))
      (let ((proc (get op type-tags)))
        (if proc
          (apply proc (map contents coerced_args))
          (if (not (null? tagList))
              (let ((type1 (car tagList)))
                  (app-recur op (cdr tagList)
                                (map (lambda (el)
                                      (let ((coercion (get-coercion (type-tag el) type1 )))
                                          (if coercion     ;;если операции приведения нет, то оставляем эл.  изменений
                                              (coercion el)
                                              el)))
                                       args))
              )
              (error "Нет метода для этих типов"  (list op type-tags))
          )
        );end if proc
      )
    )
 ) ;app-recur

 (app-recur op (map type-tag args) args)
)
;;===========================

(define r1
     (add   (make-rational 4 8)
            (make-rational 2 3)))
;; r1 == 7/6

(define c1
  (add  (make-complex-from-real-imag 4 8)
        (make-complex-from-real-imag 4 8)))

;; c1 == 8 + i*16
(define n1 (make-scheme-number 45))
(define n2 (make-scheme-number 8))


(add3 r1 n2 n1)
(add3 n1 n2 r1)
(add3 n2 n1 r1)
(add3 n2 r1 n1)
(add3 c1 r1 n1)

Comment from Denis Larionov
Date: January 26, 2017, 12:25 pm

(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) '()))

(define *coercion-table* (make-hash))
(define (put-coerciont type1 type2 proc) (hash-set! *coercion-table* (list type1 type2) proc))
(define (get-coercion type1 type2) (hash-ref *coercion-table* (list type1 type2) '()))

(define (attach-tag type-tag contents) (cons type-tag contents))
(define (type-tag datum) (car datum))
(define (contents datum) (cdr datum))

метод, который приводит список аргументов к заданному типу, если приведение невозможно возвращает null

(define (cast-args type1 args)
  (define (iter head tail)
    (if (null? tail)
        (reverse head)
        (let ((type2 (type-tag (car tail))))
          (if (eq? type2 type1)
              (iter (cons (car tail) head) (cdr tail))
              (let ((t2->t1 (get-coercion type2 type1)))
                (if (null? t2->t1)
                    '()
                    (iter (cons (t2->t1 (car tail)) head) (cdr tail)))))
          )))    
  (iter '() args))

в apply-generic логикапо поиску и вызову процедуры вынесена в отдельный метод apply-generic-internal, который возвращает false, если процедуры не нашел.
получая список типов аргументов, пытаемся выполнить apply-generic-internal для каждого типа с приведенным списком аргументов

(define (apply-generic op . args)
  (define (apply-generic-internal local-args)
    (print local-args)
    (newline)
    (let ((type-tags (map type-tag local-args)))
      (let ((proc (get op type-tags)))
        (if (null? proc)
            false
            (apply proc (map contents local-args))))))
  (define (apply-generic-iter set)
    (if (null? set)
        (error "No method for these types")
        (let ((result (apply-generic-internal (car set))))
          (if result
              result
              (apply-generic-iter (cdr set))))))  
  (let ((result (apply-generic-internal args)))
    (if result
        result
        (let ((types (remove-duplicates (map type-tag args))))
          (if (> (length types) 1)              
              (let ((set (filter
                          (lambda(i)(not (null? i)))
                          (map
                           (lambda(i) (cast-args i args))
                           types))))
                (apply-generic-iter set))
              (error "No method for these types"))))))

данные для проверки

(put-coerciont 't2 't1 (lambda(x) (cons 't1 (cdr x))))
(put-coerciont 't1 't2 (lambda(x) (cons 't2 (cdr x))))
(put-coerciont 't3 't2 (lambda(x) (cons 't2 (cdr x))))
(cast-args 't2 (list (cons 't1 1) (cons 't2 2) (cons 't3 3) (cons 't1 42)))

(put 'add '(t2 t2 t2 t2) (lambda(a b c d) (+ a b c d)))
(apply-generic 'add (cons 't1 1) (cons 't2 2) (cons 't3 3) (cons 't1 42))

Write a comment