NoSyu의 주저리 주저리

이 문제는 기호식 대수에서 쓰이는 =zero? 프로시저를 만드는 문제입니다.

잘 되는군요.^^

=zero? 프로시저가 쓰이는 곳을 찾아보니 adjoin-term 프로시저입니다.

그 안에서 계수가 0임을 확인하기에 간단히 만들었습니다.

후에 어떻게 바뀌게 될지 모르겠습니다만, 일단 이렇게 하였습니다.

참조

해럴드 애빌슨, 김재우 역, <컴퓨터 프로그램의 구조와 해석>, 인사이트, 2007, pp. 271

(define true (= 0 0))
(define false (= 0 1))
(define (square x) (* x x))
; put/get
; in ch2support.scm - MIT support
(define (assoc key records)
  (cond ((null? records) false)
        ((equal? key (caar records)) (car records))
        (else (assoc key (cdr records)))))
(define (make-table)
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (cdr record)
                  false))
            false)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key-2 value))
                            (cdr local-table)))))
      'ok)   
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))

; polynomial 패키지
(define (install-polynomial-package)
  ; 프로시저
  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  (define (variable? x) (symbol? x))
  (define (same-variable? v1 v2)
    (and (variable? v1) (variable? v2) (eq? v1 v2)))
  (define (adjoin-term term term-list)
    (if (=zero? (coeff term))
        term-list
        (cons term term-list)))
  (define (add-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          (else
           (let ((t1 (first-term L1)) (t2 (first-term L2)))
             (cond ((> (order t1) (order t2))
                    (adjoin-term
                     t1 (add-terms (rest-terms L1) L2)))
                   ((< (order t1) (order t2))
                    (adjoin-term
                     t2 (add-terms L1 (rest-terms L2))))
                   (else
                    (adjoin-term
                     (make-term (order t1)
                                (add (coeff t1) (coeff t2)))
                     (add-terms (rest-terms L1)
                                (rest-terms L2)))))))))
  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (first-term L1) L2)
                   (mul-terms (rest-terms L1) L2))))
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t2 (first-term L)))
          (adjoin-term
           (make-term (+ (order t1) (order t2))
                      (mul (coeff t1) (coeff t2)))
           (mul-term-by-all-terms t1 (rest-terms L))))))
  (define (add-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (add-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- ADD-POLY"
               (list p1 p2))))
  (define (mul-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (mul-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- MUL-POLY"
               (list p1 p2))))
  (define (add a b) (+ a b))
  (define (mul a b) (* a b))
  ; 인터페이스
  (define (tag p) (attach-tag 'polynomial p))
  (put 'add '(polynomial polynomial)
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial polynomial)
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put 'make 'polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  (put 'add-poly '(polynomial polynomial)
       (lambda (a b) (tag (add-poly (cdr a) (cdr b)))))
  'done)

; type-tag
(define (attach-tag type-tag contents)
  (cons type-tag contents))
(define (type-tag datum)
  (cond ((pair? datum) (car datum))
        (else (error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
  (cond ((pair? datum) (cdr datum))
        (else (error "Bad tagged datum -- CONTENTS" datum))))

; apply-generic
(define (apply-generic op . args)
  ; 층수를 반환
  (define (floor p)
    (cond ((equal? p 'integer) 1)
          ((equal? p 'rational) 2)
          ((equal? p 'real) 3)
          ((equal? p 'complex) 4)
          (else (error "No package " p))))
  ; 리스트의 최고층을 반환
  (define (high-floor args-list)
    (define (iter result list)
      (if (null? list)
          result
          (if (< result (floor (type-tag (car list))))
              (iter (floor (type-tag (car list))) (cdr list))
              (iter result (cdr list)))))
    (iter 0 args-list))
  ; 리스트를 살펴 최고층이 아닌 경우 raise
  (define (raise-list high-floor args-list)
    (if (null? args-list)
        null
        (if (< (floor (type-tag (car args-list))) high-floor)
            (cons (raise (car args-list))
                  (raise-list high-floor (cdr args-list)))
            (cons (car args-list)
                  (raise-list high-floor (cdr args-list))))))
  ; 리스트가 모두 같은 층인가?
  (define (same-floor? args-list)
    (define (iter list)
      (let ((high-f (high-floor args-list)))
        (cond ((null? list) true)
              ((< (floor (type-tag (car args-list))) high-f) false)
              (else (iter (cdr list))))))
    (iter args-list))
  ; 같은 층을 만드는 것.
  (define (make-same-floor-list list)
    (if (same-floor? list)
        list
        (make-same-floor-list (raise-list (high-floor list) list))))
  ; 기존의 것
  (define (p-apply-generic args-list)
    (let ((type-tags (map type-tag args-list)))
      (let ((proc (get op type-tags)))
        (if proc
            (apply proc (map contents args-list))
            (p-apply-generic (make-same-floor-list args-list))))))
  ; 실행
  (p-apply-generic args))

(define (the-empty-termlist) '())
(define (first-term term-list) (car term-list))
(define (rest-terms term-list) (cdr term-list))
(define (empty-termlist? term-list) (null? term-list))
(define (make-term order coeff) (list order coeff))
(define (order term) (car term))
(define (coeff term) (cadr term))

(define (make-polynomial var terms)
  ((get 'make 'polynomial) var terms))

(define (add-poly a b)
  ((get 'add-poly '(polynomial polynomial)) a b))

; answer
(define (=zero? x) (= x 0))

; execute
(install-polynomial-package)
(define p1 (make-polynomial 'x
                            (list (list 5 1) (list 2 2) (list 0 1))))
(define p2 (make-polynomial 'x
                            (list (list 5 1) (list 4 2) (list 2 3)
                                  (list 1 -2) (list 0 -5))))
p1 p2
(newline)
(add-poly p1 p2)