src/sicp/ex2_88.rkt

   1 #lang racket
   2
   3 (define (negate x) (- x))
   4
   5 (put 'negate '(scheme-number)
   6      (lambda (r) (tag (negate r))))
   7
   8 (put 'negate '(rational)
   9      (lambda (r) (tag (negate r))))
  10
  11 (put 'negate '(real)
  12      (lambda (r) (tag (negate r))))
  13
  14 (put 'negate '(complex)
  15      (lambda (c) (tag ((get 'make 'complex) (negate (real c))
  16                                             (negate (imag c))))))
  17
  18 (put 'negate '(polynomial)
  19      (lambda (p) (tag (negate-poly p))))
  20
  21 (define (negate-terms terms)
  22   (if (empty-termlist? terms)
  23       the-empty-termlist
  24       (let ((t1 (first-term terms)))
  25         (let ((o (order t1))
  26               (c (coeff t1)))
  27           (adjoin-term (make-term o (negate c))
  28                        (negate-terms (rest-terms terms)))))))
  29
  30 (define (negate-poly p)
  31   (let ((terms (term-list p)))
  32     (make-poly (variable p) (negate-terms terms))))
  33
  34 (put 'negate '(polynomial)
  35      (lambda (p) (tag (negate-poly p))))
  36
  37 (define (negate p) (apply-generic 'negate p))
  38
  39 (define (sub-poly p1 p2)
  40   (add-poly p1 (negate p2)))
  41
  42 (put 'sub '(polynomial polynomial)
  43      (lambda (p1 p2) (tag (sub-poly p1 p2))))