Решение упражнения 2.84 из SICP
Для простоты я буду рассматривать вариант приведения типов только для бинарных операций, который соответствует рассмотренному в основном тексте книги варианту apply-generic.
Я модифицирую процедуру apply-generic следующим образом: если операции для двух аргументов заданных типов не нашлось, я сравню их типы. Если типы одинаковы, я попытаюсь поднять оба аргумента по башне типов и, если это возможно, выполнить операцию на поднятых таким образом аргументах. Если же один из типов находится выше другого в иерархии, я подниму более низкий на один уровень вверх по иерархии и выполню операцию. Наконец, если типы аргументов несопоставимы, то есть не принадлежат одной башне типов, я немедленно выдам сообщение об ошибке.
Процедура apply-generic, реализующая описанную идею, приведена ниже:
(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)) (if (= (length args) 2) (let ((a1 (car args)) (a2 (cadr args))) (let ((ra1 (raise a1)) (ra2 (raise a2))) (cond ((eq? (type-tag a1) (type-tag a2)) (if (and ra1 ra2) (apply-generic op ra1 ra2) (error "Нет метода для этих типов" (list op type-tags)))) ((higher? a1 a2) (apply-generic op a1 ra2)) ((higher? a2 a1) (apply-generic op ra1 a2)) (else (error "Нет метода для этих типов" (list op type-tags)))))) (error "Нет метода для этих типов" (list op type-tags)))))))
Проверка, находится ли тип одного аргумента выше в башне типов, чем тип другого выполняется просто. Если второй аргумент можно поднять в башне типов и в результате получить тот же тип, что и у первого аргумента, то тип первого аргумента выше в башне. Вариант реализации проверки приведен ниже:
(define (higher? a1 a2) (let ((ra2 (raise a2))) (and ra2 (or (eq? (type-tag a1) (type-tag ra2)) (higher? a1 ra2)))))
Алгоритм приведения типов можно сделать более эффективным, если не останавливаться на каждом шаге при подъеме, а сразу приводить аргумент с более низким типом к типу второго аргумента. Однако при этом теряются промежуточные варианты комбинаций типов, которыми я не хотел жертвовать.
Comments
Comment from thror
Date: May 8, 2009, 7:08 am
raise не простая функция. Если она не определена для некоторого типа, то попытка вызвать ее не должна приводить к исключению. Суть в том, что это специального сорта сигнал для нас- мы добрались до верхушки башни. Эта ситуация не отслеживается в процедуре higher? Корректно работать не будет.
Comment from Максим
Date: December 23, 2014, 1:00 am
Вот работающий вариант с моей реализацией raise (подробнее о ней в комментариях к 2.83):
Для хорошего понимания что я делаю, я беру большой список аргументов, типа (number real number complex rational number complex):
(define (raise obj)
(let ((type-tag (type-tag obj)))
(let ((supertype (get 'raise type-tag)))
(if supertype
((get-coercion type-tag proc) obj)
obj))))
Если метка типа будет complex – процедура попросту не найдёт приведения и вернёт аргумент в том же виде.
Далее нам необходима тривиальная процедура вертикального приведения аргумента к необходимому типу:
(define (raise-to arg type)
(let ((this-tag (type-tag arg)))
(if (eq? this-tag type)
arg
(raise-to (raise arg) type))))
Далее в задаче просят продумать алгоритм выбора “наивысшего” типа из двух (также необходимо заметить что наши решения не должны нарушать общего скелета арифметического пакета и его аддитивность, то есть при добавлении нового класса в данную систему требуемые для его работы изменения должны быть минимальными). Решается эта проблема так: поскольку у нас структура в виде башни, выберем один из двух аргументов и будем его пошагово поднимать. Если до того момента как он упрётся сам в себя (то бишь станет complex) он не станет равным типу второго аргумента, значит второй аргумент изначально находился ниже первого и мы возвращаем (!изначальное) значение первого аргумента. Если же тип первого аргумента изначально равен типу второго – нам не важно какой аргумент возвращать, поскольку на этом этапе мы лишь ищем аргумент с наивысшим типом, чтобы привести к нему потом все остальные. Но если первый аргумент в процессе пошагового поднятия поднялся до уровня второго аргумента, значит по типу выше из них второй (так как вследствие raising’а мы имеем дело с супертипом первого аргумента, что не есть его первоначальным состоянием).
Процедура:
(define (pick-higher arg1 arg2)
(define (find-iter arg1 arg2 result)
(let ((tag1 (type-tag arg1))
(tag2 (type-tag arg2))
(move-a1 (raise arg1))
(next-tag1 (type-tag move-a1)))
(cond ((eq? tag1 tag2) arg2)
((eq? tag1 next-tag1) result)
(else (find-iter move-a1 arg2 result)))))
(find-iter arg1 arg2 arg1))
Далее наша задача – найти аргумент с наивысшим типом во всем списке аргументов. Будем перебирать список, если встречаются два элемента с одинаковым типом – отбрасываем первый и рекурсивно вызываем процедуру для оставшегося списка. Если типы двух рассматриваемых элементов разные – применяем к ним (pick-higher). Процедура завершается, когда в списке остался один элемент (а значит cdr этого списка будет пустым), то есть все остальные отсеялись и остался один с наибольшим типом.
(define (pick-higher arg1 arg2)
(define (find-iter arg1 arg2 result)
(let ((tag1 (type-tag arg1))
(tag2 (type-tag arg2))
(move-a1 (raise arg1))
(next-tag1 (type-tag move-a1)))
(cond ((eq? tag1 tag2) arg2)
((eq? tag1 next-tag1) result)
(else (find-iter move-a1 arg2 result)))))
(find-iter arg1 arg2 arg1))
Теперь, будучи уверенными в том, что выбранный нами элемент наивысший в башне типов, можем привести к нему все аргументы, как по нотам:
(define (raise-all-to-highest args type)
(if (null? args)
null
(let ((a1 (car args))
(rest (cdr args)))
(cons (raise-to a1 type)
(raise-all-to-highest rest type)))))
Всё, задание выполнено. Теперь нам нужно адаптировать apply-generic под эту стратегию. Небольшое отступление – я не понял, как в одном из предыдущих заданий многоуважаемый наш учитель Сергей, большая ему благодарность за этот ресурс, реализовал применение apply-generic к числу аргументов >2, и на мой взгляд, так как все арифметические процедуры в нашем пакете реализованы для двух аргументов – типа (put ‘add ‘(complex complex) … ), а процедура apply-generic ищет процедуру op для ВСЕХ type-tags (так как изначально в коде (map type-tag args)), применять её к числу аргументов больше 2 одновременно не имеет смысла – она не найдёт ничего вызывая (get ‘add ‘(complex complex complex complex)) например. Поэтому:
(define (partition-and-apply op . args)
(if (null? (cdr args))
args
(let ((a1 (car args))
(a2 (cadr args))
(rest-args (cddr args)))
(partition-and-apply op (apply-generic op a1 a2) rest-args))))
Грубо говоря, (partition-and-apply) последовательно применяет исходную операцию к первому и второму элементам, таким образом в первом аргументе у неё будет накапливаться результат, а завершится операция тогда, когда в списке args у нее останется один элемент – в котором уже, собственно, и будет всё посчитано.
Финал:
(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))
(if (> (length args) 1)
(let ((t1 (car type-tags))
(t2 (cadr type-tags))
(rest-args (cddr type-args)))
(if (and (null? rest-args) (eq? t1 t2))
(error "No procedure specified for these types" op)
(let ((highest-type (type-tag (find-highest args))))
(let ((raised-args (raise-all-to-highest args highest-type)))
(partition-and-apply op raised-args))))
(error "No procedure specified for this type" op)))))))
Проверим: (apply-generic ‘blabla ‘rational) даст ошибку, так как не найдена подходящая операция при первом же ее поиске; (apply-generic ‘blabla ‘(complex complex)) даст ошибку, так как процедура работает уже вовсю, а типов два и они одинаковы и к ним до сих пор не найдена операция; (apply-generic ‘add ‘(complex complex)) будет найдено сразу же на входе, а для (apply-generic ‘add ‘(complex rational)) например – будет проделано всё то что я расписал выше.
Comment from Максим
Date: December 23, 2014, 1:02 am
Кто желает вместе решать и разбираться с задачами добавляйте в скайп osom-pchits
Comment from Максим
Date: December 24, 2014, 2:44 pm
Нашёл ошибку:
(define (raise obj)
(let ((type-tag (type-tag obj)))
(let ((supertype (get 'raise type-tag)))
(if supertype
((get-coercion type-tag supertype) obj)
obj))))
Comment from Максим
Date: December 24, 2014, 4:44 pm
Исправленный и работающий на практике вариант:
;basic coercions (global procedures)
(define (integer->rational x)
(make-rational x 1))
(define (rational->real x)
(make-real (/ (numer x) (denom x))))
(define (real->complex x)
(make-complex-from-real-imag (contents x) 0))
(define (install-coercions)
(put-coercion 'integer 'rational (lambda (x) (integer->rational x)))
(put-coercion 'rational 'real (lambda (x) (rational->real x)))
(put-coercion 'real 'complex (lambda (x) (real->complex x))))
(install-coercions)
;raising
(define (raise obj)
(let ((type-tag (type-tag obj)))
(let ((supertype (get 'raise type-tag)))
(if supertype
((get-coercion type-tag supertype) obj)
obj))))
;raising to prespecified type
(define (raise-to arg type)
(let ((this-tag (type-tag arg)))
(if (eq? this-tag type)
arg
(raise-to (raise arg) type))))
;testing 2 arguments which has the highest type
(define (pick-higher arg1 arg2)
(define (find-iter arg1 arg2 result)
(let ((tag1 (type-tag arg1))
(tag2 (type-tag arg2))
(move-a1 (raise arg1)))
(let ((next-tag1 (type-tag move-a1)))
(cond ((eq? tag1 tag2) arg2)
((eq? tag1 next-tag1) result)
(else (find-iter move-a1 arg2 result))))))
(find-iter arg1 arg2 arg1))
;picking the highest type argument from the list
(define (find-highest args)
(if (null? (cdr args))
(car args)
(let ((this (car args))
(next (cadr args))
(rest (cddr args)))
(let ((t1 (type-tag this))
(t2 (type-tag next)))
(if (eq? t1 t2)
(find-highest (cdr args))
(find-highest (cons (pick-higher this next)
rest)))))))
(define (raise-all-to-highest args type)
(if (null? args)
null
(let ((a1 (car args))
(rest (cdr args)))
(cons (raise-to a1 type)
(raise-all-to-highest rest type)))))
(define (partition-and-apply op args)
(if (null? (cdr args))
(car args)
(let ((a1 (car args))
(a2 (cadr args))
(rest-args (cddr args)))
(partition-and-apply op (cons (apply-generic op a1 a2) rest-args)))))
(define (apply-generic1 op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(if (> (length args) 1)
(let ((t1 (car type-tags))
(t2 (cadr type-tags))
(rest-args (cddr args)))
(if (and (null? rest-args) (eq? t1 t2))
(error "No procedure specified for these types" op)
(let ((highest-type (type-tag (find-highest args))))
(let ((raised-args (raise-all-to-highest args highest-type)))
(partition-and-apply op raised-args)))))
(error "No procedure specified for this type" op))))))
(apply-generic1 'add 1 '(rational 11 . 12) 3)
(rational 59 . 12)
Comment from T.C.
Date: January 20, 2016, 3:44 pm
Подсказка для читающих: если вам нужно в форме let связать переменную со значением одной из предыдущих, используйте let*.
Таким образом этот код:
(let ((a 0))
(let ((b a))
...))
может быть заменён этим:
(let* ((a 0)
(b a))
...)
Comment from Denis Larionov
Date: January 30, 2017, 12:07 pm
вариант для apply-generic c произвольным числом аргументов.
в каждый пакет добавлена операция add для трех аргументов. для краткости убраны другие операции и представление комплексных числе в полярной форме.
(define (install-integer-package) (define (tag x) (attach-tag 'integer x)) (put 'make 'integer (lambda (x) (tag x))) (put 'raise '(integer) (lambda (x) (make-rational x 1))) (put 'add '(integer integer) (lambda (x y) (tag (+ x y)))) (put 'add '(integer integer integer) (lambda (x y z) (tag (+ x y z)))) )
(define (install-rational-package) (define (gcd a b) (if (= a 0) b (gcd (remainder b a) a))) (define (make-rat n d) (let ((g (gcd n d))) (cons (/ n g) (/ d g)))) (define numer car) (define denom cdr) (define (add-rat x y) (make-rat (+ (* (numer x) (denom y)) (* (numer y) (denom x))) (* (denom x) (denom y)))) (define (tag x) (attach-tag 'rational x)) (put 'make 'rational (lambda (n d) (tag (make-rat n d)))) (put 'raise '(rational) (lambda (x) (make-number (/ (numer x) (denom x))))) (put 'add '(rational rational) (lambda (x y) (tag (add-rat x y)))) (put 'add '(rational rational rational) (lambda (x y z) (tag (add-rat z (add-rat x y))))) )
(define (install-number-package) (define (tag x) (attach-tag 'number x)) (put 'make 'number (lambda (x) (tag x))) (put 'raise '(number) (lambda (x) (make-complex x 0))) (put 'add '(number number) (lambda (x y) (tag (+ x y)))) (put 'add '(number number number) (lambda (x y z) (tag (+ x y z)))) )
(define (install-complex-package) (define (make-from-real-imag x y) (cons x y)) (define (real-part z) (car z)) (define (imag-part z) (cdr z)) (define (add-complex z1 z2) (make-from-real-imag (+ (real-part z1) (real-part z2)) (+ (imag-part z1) (imag-part z2)))) (define (tag x) (attach-tag 'complex x)) (put 'make 'complex (lambda (x y) (tag (make-from-real-imag x y)))) (put 'add '(complex complex) (lambda (z1 z2) (tag (add-complex z1 z2)))) (put 'add '(complex complex complex) (lambda (z1 z2 z3) (tag (add-complex z3 (add-complex z1 z2))))) )
в глобальном контексте определены конструкторы типов
(install-integer-package) (install-rational-package) (install-number-package) (install-complex-package) (define (make-integer x) ((get 'make 'integer) x)) (define (make-rational n d) ((get 'make 'rational) n d)) (define (make-number x) ((get 'make 'number) x)) (define (make-complex x y) ((get 'make 'complex) x y))
башня определена как пронумерованый список типов + методы для получения номера типа в башне и выбора типа с максимальным номером.
(define tower '((integer 1) (rational 2) (number 3) (complex 4))) (define (tower-index x) (define (iter tail) (if (null? tail) -1 (let ((i (car tail))) (if (eq? (car i) x) (car (cdr i)) (iter (cdr tail)))))) (iter tower)) (define (max-type types) (define (iter guess tail) (if (null? tail) guess (if (> (tower-index guess) (tower-index (car tail))) (iter guess (cdr tail)) (iter (car tail) (cdr tail))))) (iter (car types) (cdr types)))
методы для поднятия списка аргументов и apply-generic
define (raise-to type x) (if (eq? (type-tag x) type) x (raise-to type (raise x)))) (define (raise-args type args) (map (lambda(x) (raise-to type x)) args)) (define (apply-generic op . args) (define (apply-generic-internal local-args) (let ((type-tags (map type-tag local-args))) (let ((proc (get op type-tags))) (if (null? proc) false (apply proc (map contents local-args)))))) (let ((result1 (apply-generic-internal args))) (if result1 result1 (let ((types (remove-duplicates (map type-tag args)))) (if (> (length types) 1) (let ((result2 (apply-generic-internal (raise-args (max-type types) args)))) (if result2 result2 (error "No method for these types"))) (error "No method for these types")))))) (define (raise z) (apply-generic 'raise z)) (apply-generic 'add (make-integer 1) (make-complex 1 3) (make-rational 1 3))
Write a comment