发帖占楼~~~~

由以下文件组成，只做了粗略测试，以后再继续改进。
otherop.rkt 一些公用的操作
rational.rkt 有理数操作
rectangular.rkt 直角坐标复数
polar.rkt 极坐标复数
complex.rkt 复数操作
schemenum.rkt sceme数操作
numsystem.rkt 整合
所有文件在同一目录内
用到了表格操作，另附。

otherop.rkt
;---------------------------
(provide (all-defined-out))
(displayln "@@otherop@@")
;------------------------------------
#|
;;;添加标签的操作
(attach-tag type-tag contents) -> datum
(type-tag datum) -> type-tag
(contents datum) -> contents
|#
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum -- TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum -- CONTENTS" datum)))
;-----------------------------

rational.rkt
;-----------------------------------
(provide (all-defined-out))
(displayln "@@rational@@")
;;;import put,get
(require "../../mod/tablemod.rkt")
(require "otherop.rkt")
;----------------------------------
(define (install-rational-package)
;;internal procedures
(define (make-rat n d)
(cond ((= d 0)
(error "denominator can't zero!" d))
(else
(let ((g (gcd n d)))
(cons (/ n g) (/ d g))))))
(define (numer x) (car x))
(define (denom x) (cdr x))
(define (print-rat x)
(printf "/n~a/~a/n" (numer x) (denom x)))
(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 (equal-rat? x y)
(= (* (numer x) (denom y))
(* (numer y) (denom x))))
;;interface to the rest of the system
(define (tag x) (attach-tag 'rational x))
(put 'numer '(rational) numer)
(put 'denom '(rational) denom)
(put 'print '(rational) print-rat)
(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 'rational
(lambda (n m) (tag (make-rat n m))))
'done-rational)

rectangular.rkt
;---------------------------
(provide (all-defined-out))
(displayln "@@rectangular@@")
;;;import put,get
(require "../../mod/tablemod.rkt")
(require "otherop.rkt")
;----------------------------------
(define (rectangular? z)
(equal? (type-tag z) 'rectangular))
;--------------------------------
(define (install-rectangular-package)
;;internal proedures
(define (make-from-real-imag x y) (cons x y))
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (magnitude z)
(sqrt (+ (sqr (real-part z))
(sqr (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
;;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 '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-rectangular)
;-----------------------------------

polar.rkt
;------------------------
(provide (all-defined-out))
(displayln "@@polar@@")
;;;import put,get
(require "../../mod/tablemod.rkt")
(require "otherop.rkt")
;----------------------------------
(define (polar? z)
(eq? (type-tag z) 'polar))
;--------------------------------
(define (install-polar-package)
;;internal procedures
(define (make-from-mag-ang r a) (cons r a))
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-real-imag x y)
(cons (sqrt (+ (sqr x) (sqr y)))
(atan y x)))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
;;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 '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-polar)
;-------------------------------------

complex.rkt
;------------------
(provide (all-defined-out))
(displayln "@@complex@@")
;;;import put,get
(require "../../mod/tablemod.rkt")
(require "otherop.rkt")
(require "rational.rkt")
(require "rectangular.rkt")
(require "polar.rkt")
;----------------------------------
(define (install-complex-package)
;;imported procedures from rectangular and polar packages
(install-rational-package)
(install-rectangular-package)
(install-polar-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 (real-part z)
(let ((type (list (type-tag z)))
(z (contents z)))
((get 'real-part type) z)))
(define (imag-part z)
(let ((type (list (type-tag z)))
(z (contents z)))
((get 'imag-part type) z)))
(define (magnitude z)
(let ((type (list (type-tag z)))
(z (contents z)))
((get 'magnitude type) z)))
(define (angle z)
(let ((type (list (type-tag z)))
(z (contents z)))
((get 'angle type) z)))
;;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))))
;;interface to rest of the system
(define (tag z) (attach-tag 'complex z))
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(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))))
'done-complex)

schemenum.rkt
;----------------------
(provide (all-defined-out))
(displayln "@@schemenum@@")
;;;import put,get
(require "../../mod/tablemod.rkt")
(require "otherop.rkt")
(require "complex.rkt")
;--------------------------------
(define (install-scheme-number-package)
;;imported procedures from rectangular and polar packages
(install-complex-package)
;;internal procedures
;;interface to the rest of the system
(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)))
'done-scheme-num)

numsystem.rkt
;------------------
;;;2.5 带有通用型操作的系统
;;;import put,get
(require "../../mod/tablemod.rkt")
(require "otherop.rkt")
;(require "rational.rkt")
;(require "complex.rkt")
(require "schemenum.rkt")
;----------------------------
;(install-rational-package)
;(install-complex-package)
(install-scheme-number-package)
;-----------------------------
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(cond (proc
(apply proc (map contents args)))
((= (length args) 2)
(let* ((type1 (car type-tags))
(type2 (cadr type-tags))
(type1level (type-level type1))
(type2level (type-level type2))
(a1 (car args))
(a2 (cadr args)))
(cond ((= type1level type2level)
(apply-generic op
(type2typeup a1)
(type2typeup a2)))
((< type1level type2level)
(apply-generic op
(type2typeup a1)
a2))
((> type1level type2level)
(apply-generic op
a1
(type2typeup a2)))
(else
(error "error type?" type1 type2)))))
; ((> (length args) 2)
; (let ((a1 (car args))
; (a2 (cadr args)))
; (apply-generic
; op
; (cons (apply-generic op a1 a2)
; (cddr args)))))
(else
(error
"No method for these types -- APPLY-GENERIC" (list op type-tags)))))))
;-----------------------------
;;;rational
(define (make-rational n d)
((get 'make-rational 'rational) n d))
(define (numer r)
(apply-generic 'numer r))
(define (denom r)
(apply-generic 'denom r))
(define (print r)
(apply-generic 'print r))
;;;complex
(define (make-from-real-imag r i)
((get 'make-from-real-imag 'complex) r i))
(define (make-from-mag-ang m a)
((get 'make-from-mag-ang 'complex) m 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))
(define (rational->complex r)
(make-from-real-imag
(/ (numer r) (denom r))
0))
(put 'rational 'complex rational->complex)
;;;scheme-number
(define (make-scheme-number n)
((get 'make 'scheme-number) n))
;;;op
(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 (complex->scheme-number z)
(make-scheme-number
(+ (real-part z) (* (imag-part z) 0+i))))
(put 'complex 'scheme-number complex->scheme-number)
;;;Anum->Bnum
(define type-table
(list 'rational 'complex 'scheme-number))
(define (type-level type)
(let loop ((table type-table) (l 0))
(cond ((null? table)
(error "No the type!" type))
((eq? type (car table))
l)
(else
(loop (cdr table) (add1 l))))))
(define (type2typeup num)
(let* ((type (type-tag num))
(t-l (type-level type))
(typeup (list-ref type-table (add1 t-l))))
((get type typeup) num)))
;------------------------------------
;;;test
(add (make-rational 1 3) (make-rational 5 1))
(add (make-from-real-imag 1 2) (make-from-real-imag 5 6))
(add (make-from-real-imag 1 2) (make-from-mag-ang (sqrt 2) (/ pi 4)))
(sub (make-scheme-number 13.56) (make-scheme-number 4.56))
(add (make-rational 1 3) (make-from-real-imag 1 2))
(mul (make-from-mag-ang (sqrt 2) (/ pi 4)) (make-scheme-number 1
+3
i))
(mul (make-scheme-number 1+3i) (make-rational 1 5))

被系统删了一帖。。。。
实现了自动数类提升
系统会自动，比较两个操作数的类型大小，并自动逐级提升直至可执行或没有此操作出错为止。