이 문제는 복소수 표현에서 실수부, 허수부, 크기, 각을 나타내는 수를

기본수, 유리수 외 후에 만들 수를 넣을 수 있도록 만드는 문제입니다.

잘 되는군요.^^

여기서는 유리수를 선택하였습니다.

밖에 make-complex-element, selector-complex-element 프로시저를 만들어

복소수를 만들 때 make-complex-element를 부르고,

직각 좌표계에서는 실수부와 허수부, 극좌표계에서는 크기와 각에 접근할 때

selector-complex-element를 부르도록 만들었습니다.

그리고 sine, cosine을 따로 만들어 넣었습니다.

그러니 후에 다른 수를 만들어도 위에서 만든 네 개 프로시저만 신경쓰면 됩니다.

참조

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

(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!))

; put-coercion / get-coercion
(define (put-coercion a b c) (put a b c))
(define (get-coercion a b) (get a b))

; section 2.5.1
(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 (install-integer-package)
  (define (tag x) (attach-tag 'integer x))
  (put 'add '(integer integer)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(integer integer)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(integer integer)
       (lambda (x y) (tag (* x y))))
  (put 'div '(integer integer)
       (lambda (x y) (tag (round (/ x y)))))
  (put 'make 'integer
       (lambda (x) (tag x)))
  ; exercise 2.79 answer
  (put 'equ? '(integer integer)
       (lambda (x y) (= x y)))
  ; exercise 2.80 answer
  (put '=zero? '(integer)
       (lambda (x) (= x 0)))
  ; exercise 2.81
  (put 'exp '(integer integer)
       (lambda (x y) (tag (expt x y))))
  ; exercise 2.83
  (put 'raise '(integer)
       (lambda (x) (make-rational x 1)))
  'done)
(define (make-integer n)
  ((get 'make 'integer) n))

; 유리수
(define (install-rational-package)
  ; 프로시저
  (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))))
  (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 (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 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  ; exercise 2.79 answer
  (put 'equ? '(rational rational)
       (lambda (x y)
         (and (= (numer x) (numer y)) (= (denom x) (denom y)))))
  ; exercise 2.83
  (put 'raise '(rational)
       (lambda (x)
         (make-real (/ (numer x) (denom x)))))
  'done)
(define (make-rational n d)
  ((get 'make 'rational) n d))

; 실수
(define (install-real-package)
  (define (tag x) (attach-tag 'real x))
  (put 'add '(real real)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(real real)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(real real)
       (lambda (x y) (tag (* x y))))
  (put 'div '(real real)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'real
       (lambda (x) (tag x)))
  ; exercise 2.79 answer
  (put 'equ? '(real real)
       (lambda (x y) (= x y)))
  ; exercise 2.80 answer
  (put '=zero? '(real)
       (lambda (x) (= x 0)))
  ; exercise 2.81
  (put 'exp '(real real)
       (lambda (x y) (tag (expt x y))))
  ; exercise 2.83
  (put 'raise '(real)
       (lambda (x) (make-complex-from-real-imag x 0)))
  'done)
(define (make-real n)
  ((get 'make 'real) n))

; 복소수
(define (install-complex-package)
  ; 프로시저
  (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))
  (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))))
  ; exercise 2.81
  (define (scheme-number->scheme-number n) n)
  (define (complex->complex z) z)
  ; 인터페이스
  (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))))
  ; add exercise 2.77
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  ; exercise 2.79 answer
  (put 'equ? '(complex complex)
       (lambda (x y)
         (or (and (= (real-part x) (real-part y))
                  (= (imag-part x) (imag-part y)))
             (and (= (magnitude x) (magnitude y))
                  (= (angle x) (angle y))))))
  ; exercise 2.80 answer
  (put '=zero? '(complex)
       (lambda (x) (or (and (= (real-part x) 0) (= (imag-part x) 0))
                       (and (= (magnitude x) 0) (= (angle x) 0)))))
  ; exercise 2.81
  (put-coercion 'scheme-number 'scheme-number
                scheme-number->scheme-number)
  (put-coercion 'complex 'complex complex->complex)
  '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))

(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))

; exercise 2.78
(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))))

; exercise 2.81
(define (exp x y) (apply-generic 'exp x y))

; exercise 2.83
(define (raise x) (apply-generic 'raise x))

; exercise 2.84
; 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))

; exercise 2.85
; project
(define (project x) (apply-generic 'project x))

; drop
(define (drop x)
  (if (equ? x (raise (project x)))
      (project x)
      x))

; answer
(define (make-complex-element x)
  (make-rational (round x) 1))
(define (selector-complex-element x)
  (cons (/ (cadr (car x)) (cddr (car x)))
        (/ (cadr (cadr x)) (cddr (cadr x)))))
(define (sine x) (round (sin x)))
(define (cosine x) (round (cos x)))
; section 2.4
; 직각 좌표계
(define (install-rectangular-package)
  ; 프로시저
  (define (real-part z) (car (selector-complex-element z)))
  (define (imag-part z) (cdr (selector-complex-element z)))
  (define (make-from-real-imag x y) (list (make-complex-element x)
                                          (make-complex-element 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 (cosine a)) (* r (sine a))))
  ; 인터페이스
  (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 '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 (install-polar-package)
  ; 프로시저
  (define (magnitude z) (car (selector-complex-element z)))
  (define (angle z) (cdr (selector-complex-element z)))
  (define (make-from-mag-ang r a) (list (make-complex-element r)
                                        (make-complex-element a)))
  (define (real-part z)
    (* (magnitude z) (cosine (angle z))))
  (define (imag-part z)
    (* (magnitude z) (sine (angle z))))
  (define (make-from-real-imag x y)
    (cons (sqrt (+ (square x) (square y)))
          (atan y x)))
  ; 인터페이스
  (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 '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)

; execute
(install-integer-package)(install-real-package)(install-rational-package)(install-complex-package)(install-rectangular-package)(install-polar-package)
(newline)
(define z1 (make-complex-from-real-imag 3 4))
(define z2 (make-complex-from-real-imag 1 2))
(define z3 (make-complex-from-mag-ang 3 4))
(define z4 (make-complex-from-mag-ang 1 2))
z1 z2 z3 z4
(newline)(newline)
(add z1 z2) (mul z1 z2)
(add z3 z4) (mul z3 z4)

크리에이티브 커먼즈 라이선스

이 저작물은 크리에이티브 커먼즈 코리아 저작자표시-비영리-변경금지 2.0 대한민국 라이선스에 따라 이용하실 수 있습니다.