2.79

练习 2.79 请定义一个通用型相等谓词 equ?，它能检查两个数是否相等。请将它安装到通用算术包里。这一操作应该能处理常规的数、有理数和复数。

 
(define helper (js-eval "const table = {}; function get (op, type) {console.log('getting ', op, type);    const res = table[op][JSON.stringify(type)]; console.log('res = ', res); return res;} function put (op,type, proc) { console.log('putting ', op, type, proc);   table[op] = table[op] || {};    table[op][JSON.stringify(type)] = proc; } const exports = {get, put, table}; window.theTable = table; exports;"))
​
(define JSON (js-eval "JSON"))
​x
 
#<undef>

 
(define (get op type)
  (js-invoke helper 'get op (js-invoke JSON 'stringify type))
  )
​
(define (put op type proc)
  (js-invoke helper 'put op (js-invoke JSON 'stringify type) proc)
  )
 
#<undef>

 
(define (error msg v)
  msg
  )
 
#<undef>

 
(define (attach-tag type-tag contents)
  (cons type-tag contents)
  )
​
(define (type-tag datum)
  (if (pair? datum)
      (car datum)
      'scheme-number
      )
  )
​
(define (contents datum)
  (if (pair? datum)
      (cdr datum)
      datum
      )
  )
​
(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))
          (error
           "No method for these types -- APPLY-GENERIC"
           (list op type-tags)
           )
          )
      )
    )
  )
​
(define (equ? x y) (apply-generic 'equ? x y))
​
(define (install-scheme-number-package)
  (define (tag x) (attach-tag 'scheme-number x))
​
  (put 'equ? '(scheme-number scheme-number) (lambda (x y) (tag (eq? x y))))
  (put 'make 'scheme-number (lambda (x) (tag x)))
​
  'done
  )
​
(install-scheme-number-package)
 
'done

 
(define (make-scheme-number n)
  ((get 'make 'scheme-number) n)
  )
​
(define a (make-scheme-number 1))
(define b (make-scheme-number 2))
​
(equ? a b)
 
('scheme-number . #f)

 
(equ? a a)
 
('scheme-number . #t)

现在已经支持了 scheme-number。

看一下常规的数：

 
(equ? 1 1)
 
('scheme-number . #t)

 
(equ? 1 2)
 
('scheme-number . #f)

也支持了。再安装一下有理数：

 
(define (install-rational-package)
  ;; internal procedures
  (define (number 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))
              )
    )
​
  ;; interface to rest of the system
  (define (tag x) (attach-tag 'rational x))
  (put 'equ? '(rational rational) (lambda (x y) (tag (= (numer x) (numer y)))))
  (put 'make 'rational (lambda (n d) (tag (make-rat n d))))
  (put 'numer 'rational (lambda (x) (numer (contents x))))
  (put 'denom 'rational (lambda (x) (denom (contents 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))))
​
  'done
  )
​
(define (make-rational n d)
  ((get 'make 'rational) n d)
  )
​
(install-rational-package)
​
(equ? (make-rational 1 2) (make-rational 1 2))
 
Error: execute: unbound symbol: "gcd" [make-rational, js-invoke, (anon)]true

再测试一下对有理数的支持。

接着，再安装一下复数：

 
```
​
最后，测试一下对复数的支持：
​
```eval-scheme
 
(#<Syntax quasiquote> (#<Syntax quasiquote> 'eval-scheme))