Принуждение с несколькими аргументами


Из SICP:

Упражнение 2.82

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

Я написал эту часть раньше:

(define fn-registry '())
(define (get op param-types)
  (define (rec entry . rest)
    (define (all-equal a b)
      (if (symbol? a)
          (eq? a b)
          (and (= (length a) (length b))
               (let loop ((x a) (y b))
                 (or (null? x)
                     (and (eq? (car x) (car y))
                          (loop (cdr x) (cdr y))))))))
    (let ((op-entry (car entry))
          (param-types-entry (cadr entry))
          (function-entry (caddr entry)))
      (if (and (eq? op-entry op)
               (all-equal param-types-entry param-types))
          function-entry
          (if (null? rest)
              false
              (apply rec rest)))))
  (apply rec fn-registry))

(define (put op param-types fn)
  (set! fn-registry (cons (list op param-types fn) fn-registry)))

Я написал это принуждение-регистрационный код для этого упражнения:

(define coercion-registry '())
(define (put-coercion t1 t2 fn) (set! coercion-registry (cons (list t1 t2 fn) coercion-registry)))
(define (get-coercion t1 t2)
  (define (rec entry . reg)
    (define t1-entry car)
    (define t2-entry cadr)
    (define fn-entry caddr)
    (cond ((and (eq? t1 (t1-entry entry))
                (eq? t2 (t2-entry entry))) (fn-entry entry))
          ((null? reg) false)
          (else (apply rec reg))))
  (apply rec coercion-registry))

Эта функция принимает любой набор аргументов и принуждает их к тому же типу:

(define (make-set . args)
  (define (rec tested current remains)
    (define (coerce-all to-type result items)
      (if (null? items) 
          result
          (let ((t1->t2 (get-coercion (type-tag (car items)) to-type)))
            (cond ((eq? (type-tag (car items)) to-type) 
                   (coerce-all to-type (cons (car items) result) (cdr items)))
                  ((not t1->t2) false)
                  (else
                   (coerce-all to-type (append result (list (t1->t2 (car items)))) (cdr items)))))))
    (let ((coerced-all (coerce-all (type-tag current)
                                   '()
                                   (append tested (cons current remains)))))
      (cond (coerced-all coerced-all)
            ((null? remains) false)
            (else (rec (append tested (list current)) (car remains) (cdr remains))))))
  (rec '() (car args) (cdr 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))
          (let ((coerced-args (apply make-set args)))
            (if coerced-args
                (apply apply-generic (cons op coerced-args))
                (error "No method found for these types" (list op type-tags))))))))

Это пришло от предыдущей операции:

(define (square x) (* x x))

(define (attach-tag type-tag contents)
  (if (or (symbol? contents) (number? contents))
      contents
      (cons type-tag contents)))

(define (type-tag datum)
  (cond ((pair? datum) (car datum))
        ((number? datum) 'scheme-number)
        ((symbol? datum) 'scheme-symbol)
        (else (error "Bad tagged datum -- TYPE-TAG" datum))))

(define (contents datum)
  (cond ((pair? datum) (cdr datum))
        ((or (number? datum)
             (symbol? datum)) datum)
        (else (error "Bad tagged datum -- CONTENTS" datum))))


(define (add x y) (apply-generic 'add x y))
(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 (equ? x y) (apply-generic 'equ? x y))
(define (=zero? x) (apply-generic '=zero? x))

(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 '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)))
  (put 'equ? '(scheme-number scheme-number) =)
  (put '=zero? '(scheme-number) zero?)
  'done)

(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))

(define (install-rational-package)
  ;; internal procedures
  (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))))

Я добавил только одну эту функцию как часть того, что мне нужно для того, чтобы проверить применения-универсальный:

(put 'add-em '(rational rational rational rational) (lambda (a b c d) (add-rat a (add-rat b (add-rat c d)))))

Больше кода из предыдущего действия:

  (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 (equ?-rat x y)
    (and (= (numer x) (numer y))
         (= (denom x) (denom y))))
  (define (=zero?-rat x) (zero? (numer x)))
  ;; interface to rest of the system
  (define (tag x) (attach-tag 'rational x))
  (put 'add '(rational rational)
       (lambda (x y) (tag (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 'equ? '(rational rational) equ?-rat)
  (put '=zero? '(rational) =zero?-rat)

  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  'done)
(define (make-rational n d)
  ((get 'make 'rational) n d))

(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-complex-package)
  ;; imported procedures from rectangular and polar packages
  (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))
  ;; internal procedures
  (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 (equ?-complex z1 z2)
    (and (= (real-part z1) (real-part z2))
         (= (imag-part z1) (imag-part z2))))
  (define (=zero?-complex z) (and (zero? (real-part z))
                                  (zero? (imag-part z))))
  ;; interface to rest of the system
  (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))))
  (put 'equ? '(complex complex) equ?-complex)
  (put '=zero? '(complex) =zero?-complex)
  'done)

(define (install-polar-package)
  ;; internal procedures
  (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 (equ? x y)
    (and (= (magnitude x) (magnitude y))
         (= (angle x) (angle y))))
  (define (=zero? x) (zero? (magnitude x)))
  ;; interface to the rest of the system
  (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 'equ? '(polar polar) equ?)
  (put '=zero? '(polar) =zero?)
  (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)

(define (install-rectangular-package)
  ;; internal procedures
  (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 (equ? x y)
    (and (= (real-part x) (real-part y))
         (= (imag-part x) (imag-part y))))
  (define (=zero? x) (and (zero? (real-part x))
                          (zero? (imag-part x))))
  ;; interface to the rest of the system
  (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 'equ? '(rectangular rectangular) equ?)
  (put '=zero? '(rectangular) =zero?)
  (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 (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
  ((get 'make-from-mag-ang 'complex) r a))

(install-rational-package)
(install-scheme-number-package)
(install-complex-package)
(install-polar-package)
(install-rectangular-package)

Зарегистрировать принуждения:

(put-coercion 'scheme-number 'rational (lambda (a) (make-rational a 1)))

И, наконец, проверить:

(apply-generic 'add-em (make-rational 3 4) 2 3 4)

Там больше кода, чем необходимо только для тестирования новой функциональности. Я нашел его проще тестировать новые применения-универсальные за счет включения кода из предыдущего примера. Мне жаль, что это может сделать его немного труднее следить за именно то, что я спрашиваю здесь, но, пожалуйста, сделайте все возможное, чтобы дать мне обратную связь.

Как я могу улучшить этот код?



477
2
задан 27 апреля 2011 в 12:04 Источник Поделиться
Комментарии