(define (square x) (* x x))

(define nil '())


; Prozeduren fuer Tabellen
(define (atom? x) (not (pair? x)))

(define (assq key alist)
  (cond
    ( (null? alist) () )
    ( (atom? (car alist)) (assq key (cdr alist)) )
    ( (eq? key (caar alist)) (car alist) )
    ( else (assq key (cdr alist)) )) )

(define (lookup key table)
  (let  ((record (assq key table)))
    (cond
      ( (null? record) () )
      ( else (cdr record) ))) )

 (define (insert! key value table)
  (let  ((record (assq key table)))
    (cond
      ( (null? record) 
          (set-cdr! table (cons (cons key value) (cdr table))) )
      ( else
          (set-cdr! record (list value)) ))) 
   "ok")

(define (make-table) (list '*table*))  
 
; Zweidimensionale Tabellen:

(define (lookup key-1 key-2 table)
  (let ((subtable (assq key-1 table)))
    (cond
      ( (null? subtable) () )
      ( else 
         (let ((record (assq key-2  subtable)))
           (cond
             ( (null? record) () )
             ( else (cdr record) ))) ))) )
 
(define (insert! key-1 key-2 value table)
  (let ((subtable (assq key-1   table)))
    (cond
      ( (null? subtable) 
          (set-cdr! table 
                    (cons 
                      (list key-1 (cons key-2 value)) 
                      (cdr table))) )
      ( else
         (let  ((record (assq key-2 subtable)))
           (cond
             ( (null? record) 
                 (set-cdr! subtable 
                           (cons (cons key-2 value) (cdr subtable))) )
             ( else
                 (set-cdr! record value) ))) )))
   "ok")


(define (pairlis varlist valuelist alist)
  (cond
    ( (null? varlist) alist )
    ( else   (cons
                (list (car varlist) (car valuelist))
                (pairlis (cdr varlist) (cdr valuelist) alist)) )) )


; Typzuweisungen: 

(define (attach-type type contents) 
  (cons type contents)) 

(define (type datum) 
  (cond  ((pair? datum) (car datum))
         ((integer? datum) 'integer) 
         ((real? datum) 'real)
         ((rational? datum) 'rational)
         ((complex? datum) 'complex)
         ((error "Bad typed datum -- TYPE" datum)))) 

(define (contents datum) 
  (cond  ((pair? datum) (cdr datum)) 
         ((number? datum) datum)                  
         ((error "Bad typed datum -- CONTENTS" datum)))) 
 

; Polarkoordinaten:

(define (polar? z) 
  (eq? (type z) 'polar)) 
 
(define (make-polar r a) 
  (attach-type 'polar (cons r a))) 

; Gauss-Zahlen:

(define (gaussian? z) 
  (eq? (type z) 'gaussian))
 
(define (make-gaussian x y) 
  (attach-type 'gaussian (cons x y))) 
   
;Restklassen:

(define (residue? x) 
  (eq? (type x) 'residue)) 

(define (make-residue m a) 
  (attach-type 'residue (cons m a))) 

; Nullstellige Operationen:

(define (zero-integer x) '0)

(define (identity-integer x) '1) 

(define (zero-real x) '0.0)
 
(define (identity-real x) '1.0) 
 
(define (zero-rational x) '0.0)
 
(define (identity-rational x) '1.0) 
 
(define (zero-complex x) '0.0)
 
(define (identity-complex x) '1.0) 
 
(define (zero-polar x) (make-polar '0 '0)) 

(define (identity-polar x) (make-polar '1 '0))

(define (zero-gaussian x) (make-gaussian '0 '0)) 

(define (identity-gaussian x) (make-gaussian '1 '0))

(define (zero-residue m) (make-residue m '0)) 

(define (identity-residue m) (make-residue m '1))

; Einstellige Operationen:


; Typ integer:
 
(define (zero-integer? n) (zero? n) )

(define (unit-integer? n) (or (= n 1) ( = n (- 1))) ) 

(define (positive-integer? n) (positive? n) )

(define (negative-integer? n) (negative? n) )

(define (minus-integer n) (- n) )

(define (inverse-integer n)
  (cond
    ((unit-integer? n) n)
    ((error "Inverse does not exist -- INVERSE-INTEGER" n))) )

(define (deg-euclid-integer n) (abs n))

(define (normform-most-types x)
  x)
 
; Typ real:
 
(define (zero-real? x) (zero? x) )

(define (unit-real? x) (not (zero? x)) ) 

(define (positive-real? x) (positive? x))

(define (negative-real? x) (negative? x))

(define (minus-real x) (- x) )

(define (inverse-real x)
  (cond
    ((unit-real? x) (/ 1 x))
    ((error "Inverse does not exist -- INVERSE-REAL" x))) )



; Typ rational:
 
(define (numerator-rational x) (numerator x) )

(define (denominator-rational x) (denominator x) )

(define (zero-rational? x) (zero? x) )

(define (unit-rational? x) (not (zero? x)) ) 

(define (positive-rational? x) (positive? x))

(define (negative-rational? x) (negative? x))

(define (minus-rational x) (- x) )

(define (inverse-rational x)
  (cond
    ((unit-rational? x) (/ 1 x))
    ((error "Inverse does not exist -- INVERSE-REAL" x))) )


; Typ complex:
 
(define (real-part-complex x) (real-part x) )

(define (imag-part-complex x) (imag-part x) )

(define (zero-complex? x) (zero? x) )

(define (unit-complex? x) (not (zero? x)) ) 

(define (magnitude-complex x) (magnitude x) ) 
   
(define (angle-complex x) (angle x) ) 
   
(define (minus-complex x) (- x) )

(define (inverse-complex x)
  (cond
    ((unit-complex? x) (/ 1 x))
    ((error "Inverse does not exist -- INVERSE-REAL" x))) )

(define (conjugate-complex x) (conjugate x) )

(define (polar-complex x) 
  (make-polar (magnitude x) (angle x)) )

;  Typ polar:
 
(define (magnitude-polar z) (car (contents z))) 

(define (angle-polar z) (cdr (contents z))) 

(define (zero-polar? z) (zero? (magnitude-polar z)) )

(define (unit-polar? z) (not (zero-polar? z)) )

(define (real-part-polar z) 
  (* (car (contents z)) (cos (cdr (contents z)))))

(define (imag-part-polar z) 
  (* (car (contents z)) (sin (cdr (contents z)))))

(define (minus-polar z)
  (make-polar (magnitude-polar z) (+ pi (angle-polar z))) )

(define (inverse-polar z)
  (cond
    ( (unit-polar? z)
        (make-polar (/ 1 (magnitude-polar z)) (- (angle-polar z))) )
    ( (error "Inverse does not exist -- INVERSE-POLAR" z) )) )

(define (normform-polar z)
  (cond
    ( (zero-polar? z) (make-polar 0 0) )
    ( (make-polar
        (magnitude-polar z)
        (* 2 pi (mantisse (/ angle-polar 2 pi)))) )) )

(define (mantisse x)
  (- x (floor x)))

(define (conjugate-polar z)
  (make-polar (magnitude-polar z) (- (angle-polar z))) )

(define (complex-polar z)
  (make-complex (* (magnitude-polar z) (cos (angle-polar z)))
                    (* (magnitude-polar z) (sin (angle-polar z)))) )

; Typ gaussian:

(define (zero-gaussian? z)
  (and (zero? (real-part-gaussian z)) 
       (zero? (imag-part-gaussian z))))

(define (magnitude-gaussian z)
   (let ((x (real-part-gaussian z)) (y (imag-part-gaussian z)))
   (magnitude-complex (+ x (* 0+i z)))))

(define (angle-gaussian z)
   (let ((x (real-part-gaussian z)) (y (imag-part-gaussian z)))
   (angle-complex (+ x (* 0+i z)))))
   
(define (polar-gaussian z)
   (let ((x (real-part-gaussian z)) (y (imag-part-gaussian z)))
   (polar-complex (+ x (* 0+i z)))))

(define (unit-gaussian? z) 
  (= 1 (magnitude-gaussian z)))

(define (real-part-gaussian z) (car (contents z)))

(define (imag-part-gaussian z) (cdr (contents z)))

(define (minus-gaussian z)
  (make-gaussian (- (real-part-gaussian z)) 
                 (- (imag-part-gaussian z))) )

(define (inverse-gaussian z)
  (cond
    ( (unit-gaussian? z)
        ( (lambda (d)
                  (make-gaussian (/    (real-part-gaussian z)  d)
                                 (/ (- (imag-part-gaussian z)) d)
                  ) 
          )
          (+ (square (real-part-gaussian z)) 
             (square (imag-part-gaussianz))
          ) 
        ) 
     )
     ( (error "Inverse does not exist -- INVERSE-GAUSSIAN" z) )) )
 
(define (conjugate-gaussian z)
  (make-gaussian (real-part-gaussian z)
                 (- (imag-part-gaussian z))) )

(define (deg-euclid-gaussian z)
  (+ (square (real-part-gaussian z)) (square (imag-part-gaussian z))) )

; Typ residue:
 
(define (modulus-residue x) (car (contents x)) )

(define (representative-residue x) (cdr (contents x)) )

(define (normform-residue x) 
  (make-residue (modulus-residue x) 
                (modulo (representative-residue x) (modulus-residue x))) )

(define (zero-residue? x) 
  (zero? (modulo (representative-residue x) (modulus-residue x))) )

(define (unit-residue? x) 
  (= 1 (gcd (modulus-residue x) (representative-residue x))) )

(define (minus-residue x) (make-residue (modulus-residue x) 
  (- (representative-residue x))) )

(define (inverse-residue x) (error "Noch nicht definiert -- INVERSE-RESIDUE" x))

; Gleichheits-Pr"adikate  

(define (equ-integer? m n) (= m n)) 

(define (equ-real? x y) (= x y)) 

(define (equ-rational? x y) (= x y)) 

(define (equ-complex? x y) (= x y)) 

(define (equ-gaussian? x y) 
  (and (= (real-part-gaussian x) (real-part-gaussian y))
       (= (imag-part-gaussian x) (imag-part-gaussian y)))) 

(define (equ-polar? z w)
 (define (integer-real? x) (= x (floor x)))
 (cond
    ( (zero-polar? z) (zero-polar? w) )
    ( else            (and (= (car (contents z)) (car (contents w))) 
                           (integer-real? 
                              (/ (- (cdr (contents z)) (cdr (contents w))) 
                                 2 
                                 pi
                              )
                           )
                       )
    )
  )
) 

(define (equ-residue? x y) 
  (zero? 
    (remainder 
       (- (cdr (contents x)) (cdr (contents y))) 
       (car (contents x)))))  

; Ordnungs-Pr"adikate

(define (<-integer? m n)  (< m n)) 

(define (<=-integer? m n)  (<= m n)) 

(define (>-integer? m n)  (> m n)) 

(define (>=-integer? m n)  (>= m n)) 

(define (<-real? x y) (< x y)) 
 
(define (<=-real? x y)  (<= x y)) 

(define (>-real? x y)  (> x y)) 

(define (>=-real? x y) (>= x y)) 

(define (<-rational? x y) (< x y) )

(define (<=-rational? x y) (<= x y) )

(define (>-rational? x y) (> x y) )

(define (>=-rational? x y) (>= x y) )

; Algebraische Operatoren 

; Type integer:

(define (quotient-integer a b) (quotient a b))

(define (modulo-integer a b)
  (modulo a b))

; type polar:

(define (+polar z w)
  (polar-complex 
    (+complex (complex-polar z) (complex-polar w))) )
             
(define (-polar z w)
  (polar-complex 
    (-complex (complex-polar z) (complex-polar w))) )
           
(define (*polar z w)
  (make-polar 
    (* (magnitude-polar z) (magnitude-polar w))
    (+ (angle-polar z) (angle-polar w))) )

(define (/polar z w)
  (*polar z (inverse-polar w)) )
 
; type gaussian:

(define (+gaussian z w)
  (make-gaussian (+ (real-part-gaussian z) (real-part-gaussian w))
                 (+ (imag-part-gaussian z) (imag-part-gaussian w))) )

(define (-gaussian z w)
  (make-gaussian (- (real-part-gaussian z) (real-part-gaussian w))
                 (- (imag-part-gaussian z) (imag-part-gaussian w))) )

(define (*gaussian z w)
  (make-gaussian 
    (- (* (real-part-gaussian z) (real-part-gaussian w))
       (* (imag-part-gaussian z) (imag-part-gaussian w)))
    (+ (* (real-part-gaussian z) (imag-part-gaussian w))
       (* (imag-part-gaussian z) (real-part-gaussian w)))) )

(define (/gaussian z w)
  (*gaussian z (inverse-gaussian w)) )
   
(define (quotient-gaussian z w)
  (define (next-gaussian-complex z)
    (make-gaussian 
      (round (real-part-complex z))
      (round (imag-part-complex z))) )
  (next-gaussian-complex
    (/
      (gaussian->complex z)
      (gaussian->complex w))) )

; type residue:

(define (+residue x y)
  (make-residue 
    (modulus-residue x) 
    (+ (representative-residue x) (representative-residue y))) )

(define (-residue x y)
  (make-residue 
    (modulus-residue x) 
    (- (representative-residue x) (representative-residue y))) )

(define (*residue x y)
  (make-residue 
    (modulus-residue x) 
    (* (representative-residue x) (representative-residue y))) )

(define (/residue x y)
  (*residue x (inverse-residue y)) )


; Generische Operatoren

(define operation-table (make-table))
  
(define (put type op proc)
  (insert! type op proc operation-table))

(define (get type op)
  (lookup type op operation-table))

; Tabelleneintr"age

; type integer:
 
(put 'integer 'zero zero-integer)

(put 'integer 'identity identity-integer)

(put 'integer 'zero? zero-integer?)

(put 'integer 'unit? unit-integer?)

(put 'integer 'positive? positive-integer?)

(put 'integer 'negative? negative-integer?)

(put 'integer 'minus minus-integer)

(put 'integer 'inverse inverse-integer)

(put 'integer 'normform normform-most-types)

(put 'integer 'equ? equ-integer?)

(put 'integer '<? <-integer?)

(put 'integer '<=? <=-integer?)

(put 'integer '>? >-integer?)

(put 'integer '>=? >=-integer?)

(put 'integer '+ +)

(put 'integer '- -)

(put 'integer '* *)

(put 'integer '/ /)

; type real:
 
(put 'real 'zero zero-real)

(put 'real 'identity identity-real)

(put 'real 'zero? zero-real?)

(put 'real 'unit? unit-real?)

(put 'real 'positive? positive-real?)

(put 'real 'negative? negative-real?)

(put 'real 'minus minus-real)

(put 'real 'inverse inverse-real)

(put 'real 'normform normform-most-types)

(put 'real 'equ? equ-real?)

(put 'real '<? <-real?)

(put 'real '<=? <=-real?)

(put 'real '>? >-real?)

(put 'real '>=? >=-real?)

(put 'real '+ +)

(put 'real '- -)

(put 'real '* *)

(put 'real '/ /)

; type rational:
 
(put 'rational 'zero zero-rational)

(put 'rational 'identity identity-rational)

(put 'rational 'numer numerator-rational)

(put 'rational 'denom denominator-rational)

(put 'rational 'normform normform-most-types)

(put 'rational 'zero? zero-rational?)

(put 'rational 'unit? unit-rational?)

(put 'rational 'positive? positive-rational?)

(put 'rational 'negative? negative-rational?)

(put 'rational 'minus minus-rational)

(put 'rational 'inverse inverse-rational)

(put 'rational 'equ? equ-rational?)

(put 'rational '<? <-rational?)

(put 'rational '<=? <=-rational?)

(put 'rational '>? >-rational?)

(put 'rational '>=? >=-rational?)

(put 'rational '+ + )

(put 'rational '- - )

(put 'rational '* * )

(put 'rational '/ /)

; type complex:
 
(put 'complex 'zero zero-complex)

(put 'complex 'identity identity-complex)

(put 'complex 'real-part real-part-complex)

(put 'complex 'imag-part imag-part-complex)

(put 'complex 'zero? zero-complex?)

(put 'complex 'unit? unit-complex?)

(put 'complex 'magnitude magnitude-complex)

(put 'complex 'angle angle-complex)

(put 'complex 'minus minus-complex)

(put 'complex 'inverse inverse-complex)

(put 'complex 'normform normform-most-types)

(put 'complex 'conjugate conjugate-complex)

(put 'complex 'polar polar-complex)

(put 'complex 'equ? equ-complex?)

(put 'complex '+ + )

(put 'complex '- - )

(put 'complex '* * )

(put 'complex '/ / )

; type polar:
 
(put 'polar 'zero zero-polar)

(put 'polar 'identity identity-polar)

(put 'polar 'real-part real-part-polar)

(put 'polar 'imag-part imag-part-polar)

(put 'polar 'zero? zero-polar?)

(put 'polar 'unit? unit-polar?)

(put 'polar 'magnitude magnitude-polar)

(put 'polar 'angle angle-polar)

(put 'polar 'minus minus-polar)

(put 'polar 'inverse inverse-polar)

(put 'polar 'normform normform-polar)

(put 'polar 'conjugate conjugate-polar)

(put 'polar 'complex complex-polar)

(put 'polar '= equ-polar?)

(put 'polar '+ +polar)

(put 'polar '- -polar)

(put 'polar '* *polar)

(put 'polar '/ /polar)

; type gaussian:
 
(put 'gaussian 'zero zero-gaussian)

(put 'gaussian 'identity identity-gaussian)

(put 'gaussian 'real-part real-part-gaussian)

(put 'gaussian 'imag-part imag-part-gaussian)

(put 'gaussian 'zero? zero-gaussian?)

(put 'gaussian 'unit? unit-gaussian?)

(put 'gaussian 'magnitude magnitude-gaussian)

(put 'gaussian 'angle angle-gaussian)

(put 'gaussian 'minus minus-gaussian)

(put 'gaussian 'inverse inverse-gaussian)

(put 'gaussian 'normform normform-most-types)

(put 'gaussian 'conjugate conjugate-gaussian)

(put 'gaussian 'polar polar-gaussian)

(put 'gaussian '= equ-gaussian?)

(put 'gaussian '+ +gaussian)

(put 'gaussian '- -gaussian)

(put 'gaussian '* *gaussian)

(put 'gaussian '/ /gaussian)

; type residue:
 
(put 'residue 'zero zero-residue)

(put 'residue 'identity identity-residue)

(put 'residue 'modulus modulus-residue)

(put 'residue 'representative representative-residue)

(put 'residue 'normform normform-residue)

(put 'residue 'zero? zero-residue?)

(put 'residue 'unit? unit-residue?)

(put 'residue 'minus minus-residue)

(put 'residue 'inverse inverse-residue)

(put 'residue '= equ-residue?)

(put 'residue '+ +residue)

(put 'residue '- -residue)

(put 'residue '* *residue)

(put 'residue '/ /residue)


; Nullstellige Operatoren:

(define (operate-0 op type)
  (let ((proc (get type op)))
    (cond
      ( (not (null? proc)) (proc type) )
      ( else (error "Operator undefined for this type -- OPERATE-0"
                     (list op type)) )) ))

; Einstellige Operatoren:
 
(define (operate-1 op arg)
  (let ((proc (get (type arg) op)))
    (cond
      ( (not (null? proc)) (proc arg) )
      ( else (error "Operator undefined for this type -- OPERATE-1"
                     (list op arg)) )) ))

; Zweistellige Operatoren:
 
 (define (operate-2a op arg1 arg2)
   (let ((t1 (type arg1)))
     (cond
       ( (eq? t1 (type arg2))
           (let ((proc (get t1 op)))
             (cond
               ( (not (null? proc)) (proc arg1 arg2) )
               ( else (error "Operator undefined for this type -- OPERATE-2A"
                              (list op arg1 arg2)) )) ) )
        ( else (error "Operands not of same type -- OPERATE-2A"
                       (list op arg1 arg2)) ))) )


 (define (operate-2b op arg1 arg2)
   (let ((t1 (type arg1)))
        (let ((proc (get t1 op)))
        (cond ( (not (null? proc)) (proc arg1 arg2) )
              ( else (error "Operator undefined for this type -- OPERATE-2B"
                              (list op arg1 arg2)) )) ) ))
         

(define (operate-2 op arg1 arg2)
  (let ((t1 (type arg1)) (t2 (type arg2)))
    (cond
      ( (eq? t1 t2)
          (let ((proc (get t1 op)))
            (cond
              ( (not (null? proc)) (proc arg1 arg2) )
              ( else (error "Operator undefined for this type -- OPERATE-2"
                            (list op arg1 arg2)) )) ) )
      ( (cond
          ( (and (eq? t1 'poly) (eq? t2 'quot))
            (let (( arg1 (g-normform arg1) )
                  ( arg2 (g-normform arg2) ))
            (cond
              ( (or (poly? (g-numer arg2)) (poly? (g-denom arg2)))
                (let (( t1->t2 (get-coercion t1 t2) ))
                (cond
                  ( (not (null? t1->t2)) (operate-2b op (t1->t2 arg1) arg2) )
                  ( else (error "Operands not of same type -- OPERATE-2"
                                (list op arg1 arg2)) ))) )
              ( else
                (let (( t2->t1 (get-coercion t2 t1) ))
                (cond
                  ( (not (null? t2->t1)) (operate-2b op arg1 (t2->t1 arg2)) )
                  ( else (error "Operands not of same type -- OPERATE-2"
                                (list op arg1 arg2)) ))) ))) )
          ( (and (residue? arg1) (integer? arg2))
            (operate-2 op arg1 (make-residue (modulus-residue arg1) arg2)) )
          ( (and (residue? arg2) (integer? arg1))
            (operate-2 op (make-residue (modulus-residue arg2) arg1) arg2) )
          ( (let (( t1->t2 (get-coercion t1 t2) )
                  ( t2->t1 (get-coercion t2 t1) ))
            (cond
              ( (not (null? t1->t2)) (operate-2b op (t1->t2 arg1) arg2) )
              ( (not (null? t2->t1)) (operate-2b op arg1 (t2->t1 arg2)) )
              ( else (error "Operands not of same type -- OPERATE-2"
                            (list op arg1 arg2)) ))) ))) )) )


; Nullstellige Operatoren:
 
(define (g-zero type) (operate-0 'zero type))

(define (g-identity type) (operate-0 'identity type)) 


; Einstellige Operatoren:
 
(define (g-zero? x) (operate-1 'zero? x))

(define (g-unit? x) (operate-1 'unit? x))

(define (g-positive? x) (operate-1 'positive? x))

(define (g-negative? x) (operate-1 'negative? x))

(define (g-minus x) (operate-1 'minus x))

(define (g-inverse x) (operate-1 'inverse x))

(define (g-numer x) (operate-1 'numer x))

(define (g-denom x) (operate-1 'denom x))

(define (g-normform x) (operate-1 'normform x))

(define (g-real-part z) (operate-1 'real-part z))

(define (g-imag-part z) (operate-1 'imag-part z))

(define (g-magnitude z) (operate-1 'magnitude z)) 

(define (g-angle z) (operate-1 'angle z)) 

(define (g-conjugate z) (operate-1 'conjugate z))

(define (g-polar z) (operate-1 'polar z))

(define (g-complex z) (operate-1 'complex z))

(define (g-modulus x) (operate-1 'modulus x))

(define (g-representative x) (operate-1 'representative x))

; Zweistellige Operatoren:
 
(define (g-= x y) (operate-2 '= x y))

(define (g-< x y) (operate-2 '< x y))

(define (g-<= x y) (operate-2 '<= x y))

(define (g-> x y) (operate-2 '> x y))


(define (g->= x y) (operate-2 '>= x y))

(define (g-+ x y) (operate-2 '+ x y))

(define (g-- x y) (operate-2 '- x y))

(define (g-* x y) (operate-2 '* x y))

(define (g-/ x y) (operate-2 '/ x y))


; Uebergangsprozeduren

(define (integer->rational n) n)
  
(define (integer->real n) n)
 
(define (integer->gaussian n) (make-gaussian n 0))
 
(define (integer->complex n) n)

(define (integer->polar n) (make-polar n 0))
 
(define (rational->real n) n)
 
(define (rational->complex n) n)

(define (rational->polar n) 
  (make-polar (/ (numerator-rational n) (denominator-rational n)) 0))
 
(define (real->complex x) x)

(define (real->polar x) (make-polar x 0))

(define (gaussian->complex x) 
 (+ (real-part-gaussian x) (* 0+i (imag-part-gaussian x))) )

; Tabelle der Uebergangsfunktionen

(define coercion-table (make-table))

(define (put-coercion type op proc)
  (insert! type op proc coercion-table))

(define (get-coercion type op)
  (lookup type op coercion-table))

(put-coercion 'integer 'rational integer->rational)

(put-coercion 'integer 'real integer->real)

(put-coercion 'integer 'gaussian integer->gaussian)

(put-coercion 'integer 'complex integer->complex)

(put-coercion 'integer 'polar integer->polar)

(put-coercion 'rational 'real rational->real)

(put-coercion 'rational 'complex rational->complex)

(put-coercion 'rational 'polar rational->polar)

(put-coercion 'real 'complex real->complex)

(put-coercion 'real 'polar real->polar)

(put-coercion 'complex 'polar polar-complex)

(put-coercion 'polar 'complex complex-polar)

(put-coercion 'gaussian 'complex gaussian->complex)
 

; Nullteiler

(define (zero-divisor-integer? n)
  (g-zero? n))

(define (zero-divisor-gaussian? z)
  (g-zero? z))

(define (zero-divisor-poly? f)
  (g-zero? f))

(put 'integer 'zero-divisor? zero-divisor-integer?)

(put 'gaussian 'zero-divisor? zero-divisor-gaussian?)

(put 'poly 'zero-divisor? zero-divisor-poly?)

(define (g-zero-divisor? x) (operate-1 'zero-divisor? x))

; Quotienten

(define (quot? x)
  (eq? (type x) 'quot))

(define (make-quot n d)
  (attach-type 'quot (cons n d)))

(define (zero-quot type)
  (make-quot (g-zero type) (g-identity type)))

(define (identity-quot type)
  (make-quot (g-identity type) (g-identity type)))

(put 'quot 'zero zero-quot)

(put 'quot 'identity identity-quot)

(define (numer-quot x)
  (car (contents x)))

(define (denom-quot x)
  (cdr (contents x)))

(define (zero-quot? x)
  (g-zero? (numer-quot x)))

(define (unit-quot? x)
  (cond
    ( (g-unit? (numer-quot x)) )
    ( (g-zero? (numer-quot x)) nil )
    ( (not (g-zero-divisor? (numer-quot x))) )
    ( else nil )))

(define (minus-quot x)
  (make-quot (g-minus (numer-quot x)) (denom-quot x)))

(define (inverse-quot x)
  (cond
    ( (unit-quot? x) (make-quot (denom-quot x) (numer-quot x)) )
    ( (error "Inverse does not exist -- INVERSE-QUOT" x) )) )

(define (normform-quot x)
  (let ( (t-mod (get (type (numer-quot x)) 'modulo)) )
    (let 
      ( (xx
          (cond
            ( (null? t-mod) x )
            ( (let ( (d (g-gcd (numer-quot x) (denom-quot x))) )
                (make-quot 
                  (g-/ (numer-quot x) d) 
                  (g-/ (denom-quot x) d))) ))) )
       (cond
         ( (g-unit? (denom-quot xx)) 
             (g-normform (g-/ (numer-quot xx) (denom-quot xx))) )
         ( (make-quot 
             (g-normform (numer-quot xx))
             (g-normform (denom-quot xx))) )))) )

(define (equ-quot? x y)
  (g-equ 
    (g-* (numer-quot x) (denom-quot y)) 
    (g-* (denom-quot x) (numer-quot y))))

(define (+quot x y)
  (make-quot
    (g-+
      (g-* (numer-quot x) (denom-quot y))
      (g-* (denom-quot x) (numer-quot y)))
    (g-*
      (denom-quot x) (denom-quot y))))

(define (-quot x y)
  (+quot x (minus-quot x)))

(define (*quot x y)
  (make-quot
    (g-* (numer-quot x) (numer-quot y))
    (g-* (denom-quot x) (denom-quot y))) )

(define (/quot x y)
  (cond
    ( (unit-quot? y)
        (make-quot
          (g-* (numer-quot x) (denom-quot y))
          (g-* (denom-quot x) (numer-quot y))) )
    ( (error "Division not possible - /QUOT" (list x y)) )) )

(put 'quot 'zero zero-quot)

(put 'quot 'identity identity-quot)

(put 'quot 'numer numer-quot)

(put 'quot 'denom denom-quot)

(put 'quot 'zero? zero-quot?)

(put 'quot 'unit? unit-quot?)

(put 'quot 'minus minus-quot)

(put 'quot 'inverse inverse-quot)

(put 'quot 'normform normform-quot)

(put 'quot 'equ? equ-quot?)

(put 'quot '+ +quot)

(put 'quot '- -quot)

(put 'quot '* *quot)

(put 'quot '/ /quot)

(define (most-types->quot x)
  (make-quot x (g-identity (type x))))

(define (rational->quot x)
  (make-quot (numer-rat x) (denom-rat x)))

(define (poly->quot f)
  (make-quot f (g-identity (type-of-coefficients f))) )

(define (quot->poly x)
  (make-poly (list (make-monom x nil)) nil))

(put-coercion 'integer 'quot most-types->quot)

(put-coercion 'rational 'quot rational->quot)

(put-coercion 'real 'quot most-types->quot)

(put-coercion 'complex 'quot most-types->quot)

(put-coercion 'polar 'quot most-types->quot)

(put-coercion 'gaussian 'quot most-types->quot)

(put-coercion 'residue 'quot most-types->quot)

(put-coercion 'poly 'quot poly->quot)

(put-coercion 'quot 'poly quot->poly)


; Erweiterte Definition der Division

(define (//all-types x y)
  (cond
    ( (g-unit? y) (g-/ x y) )
    ( (g-zero? y) 
        (error "Division by zero - //ALL-TYPES" (list x y)) )
    ( (not (g-zero-divisor? y))
        (g-/  
          ((get-coercion (type x) 'quot) x)
          ((get-coercion (type y) 'quot) y)) )
    ( (error "Division by zero-divisor - //ALL-TYPES" (list x y)) )) )

(define (quot-inverse-most-types x)
  (//all-types 1 x))

(define (quot-inverse-poly f)
  (cond
    ( (zero-poly? f) 
        (error "Division by zero -- QUOT-INVERSE-POLY" f) )
    ( (//all-types 1 f) )) )

(put 'integer '// //all-types)

(put 'rational '// //all-types)

(put 'real '// //all-types)

(put 'complex '// //all-types)

(put 'polar '// //all-types)

(put 'gaussian '// //all-types)

(put 'residue '// //all-types)

(put 'poly '// //all-types)

(put 'quot '// //all-types)

(put 'integer 'quot-inverse quot-inverse-most-types )

(put 'rational 'quot-inverse quot-inverse-most-types )

(put 'real 'quot-inverse quot-inverse-most-types )

(put 'complex 'quot-inverse quot-inverse-most-types )

(put 'polar 'quot-inverse quot-inverse-most-types )

(put 'gaussian 'quot-inverse quot-inverse-most-types )

(put 'residue 'quot-inverse quot-inverse-most-types )

(put 'poly 'quot-inverse quot-inverse-poly)

(put 'quot 'quot-inverse quot-inverse-most-types )

(define (g-// x y) (operate-2 '// x y))

(define (g-quot-inverse x) (operate-1 'quot-inverse x))

; Division mit Rest


(define (deg-euclid-integer n)
  (abs n))

(define (quotient-integer a b)
  (quotient a b))

(define (modulo-integer a b)
  (modulo a b))

(define (deg-euclid-gaussian z)
  (+ (square (g-real-part z)) (square (g-imag-part z))) )

(define (modulo-gaussian z w)
  (g-- z (g-* (g-quotient z w) w)))

; Tabelleneintraege:
 
(put 'integer 'deg-euclid deg-euclid-integer)

(put 'integer 'quotient quotient-integer)

(put 'integer 'modulo modulo-integer)

(put 'gaussian 'deg-euclid deg-euclid-gaussian)

(put 'gaussian 'quotient quotient-gaussian)

(put 'gaussian 'modulo modulo-gaussian)

(define (g-deg-euclid x) (operate-1 'deg-euclid x))

(define (g-quotient x y) (operate-2 'quotient x y))

(define (g-modulo x y) (operate-2 'modulo x y))

(define (g-div x y)
  (let ( (q (g-quotient x y)) )
    (cons q (g-- x (g-* q y)))) )

; Euklidischer Algorithmus

(define (g-euclid a b)
  (cond
    ( (g-zero? b) (list a 1 0) )
    ( (let ( (div (g-div a b)) )
        (let ( (eucl (g-euclid b (cdr div))) )
          (list
            (car eucl)
            (caddr eucl)
            (g-- (cadr eucl) (g-* (car div) (caddr eucl)))))) )) )

(define (g-norm-euclid a b)
  (let ( (eucl (g-euclid a b)) )
    (cond
      ( (g-unit? (car eucl))
          (let ( (inv (g-inverse (car eucl))) )
            (list 
              1 
              (g-normform (g-* inv (cadr eucl)))
              (g-normform (g-* inv (caddr eucl))))) )
      ( else 
         (list 
           (car eucl)
           (g-normform (cadr eucl))
           (g-normform (caddr eucl))) ))) )

(define (g-gcd a b)
  (cond
    ( (g-zero? b) a )
    ( (g-gcd b (g-modulo a b)) )) )

(define (g-norm-gcd a b)
  (g-norm-ideal (g-gcd a b)))

(define (g-gcd a b)
  (car (g-euclid a b)))

(define (inverse-residue x)
  (cond
    ( (g-unit? x)
        (make-residue 
          (g-modulus x) 
          (cadr (g-euclid (g-representative x) (g-modulus x)))) )
    ( (error "Not existing inverse - INVERSE-RESIDUE" x) )) )

(define z1 (make-gaussian 5 6))

(define z2 (make-gaussian 45 50))

; Ideale

(define (principal-ideal-euclid ideal)
  (cond
    ( (null? ideal) nil )
    ( (null? (cdr ideal)) (normalize-principal-ideal ideal) )
    ( (principal-ideal-euclid
        (cons
          (g-gcd (car ideal) (cadr ideal))
          (cddr ideal))) )) )

(define (normalize-principal-ideal ideal)
  (list (g-norm-ideal (g-normform (car ideal)))) )

(define (norm-ideal-integer n)
  (abs n))

(define (norm-ideal-gaussian z)
  (make-imag-positive-gaussian (make-real-positive-gaussian z)))

(define (make-real-positive-gaussian z)
  (g-* (sign (g-real-part z)) z))
(define (make-imag-positive-gaussian z)
  (cond
    ( (negative? (g-imag-part z))
        (g-* (make-gaussian 0 1) z) )
    ( else z )) )

(define (norm-ideal-poly f)
  (cond
    ( (g-zero? f) f )
    ( (zero? (degree-poly f)) 1 )
    ( (g-* (g-quot-inverse (coefficient (h-term f))) f) )) )

(define (norm-ideal-other-types x)
  (cond
    ( (g-zero? x) 0 )
    ( (g-unit? x) 1 )
    ( (g-normform x) )) )

(put 'integer 'norm-ideal norm-ideal-integer)

(put 'gaussian 'norm-ideal norm-ideal-gaussian)

(put 'poly 'norm-ideal norm-ideal-poly)

(put 'rat 'norm-ideal norm-ideal-other-types)

(put 'real 'norm-ideal norm-ideal-other-types)

(put 'rectangular 'norm-ideal norm-ideal-other-types)

(put 'polar 'norm-ideal norm-ideal-other-types)

(put 'residue 'norm-ideal norm-ideal-other-types)

(put 'quot 'norm-ideal norm-ideal-other-types)

(define (g-norm-ideal x) (operate-1 'norm-ideal x))

; Restklassenringe

(define (res? x)
  (eq? (type x) 'res))

(define (make-res ideal representative)
  (attach-type 'res (cons ideal representative)))

(define (ideal-res x)
  (car (contents x)) )

(define (representative-res x)
  (cdr (contents x)) )

(define (minus-res x)
  (make-res (ideal-res x) (g-minus (representative-res x))) )

(define (principalize-euclid x)
  (make-res 
    (principal-ideal-euclid (ideal-res x))
    (representative-res x)) )

(define (unit-res? x)
  (unit? (g-gcd (car (ideal-res x)) (representative-res x))) )

(define (inverse-res x)
  (let ( (eucl (g-norm-euclid (representative-res x) (car (ideal-res x)))) )
    (cond
      ( (= 1 (car eucl))
          (make-res (ideal-res x) (cadr eucl)) )
      ( (error "Non-existing inverse -- INVERSE-RES" x) ))) )

(define (+res x y)
  (make-res 
    (ideal-res x)
    (g-+
      (representative-res x)
      (representative-res y))))

(define (-res x y)
  (+res x (minus-res y)))

(define (*res x y)
  (make-res 
    (ideal-res x)
    (g-*
      (representative-res x)
      (representative-res y))))

(put 'res 'ideal ideal-res)

(put 'res 'representative representative-res)

(put 'res 'minus minus-res)

(put 'res 'unit? unit-res?)

(put 'res 'inverse inverse-res)

(put 'res '+ +res)

(put 'res '- -res)

(put 'res '* *res)

; Kanonische Normalformen

(define (normform-euclid-res x)
  (make-res
    (ideal-res x)
    (g-normform
      (normalize-representative (ideal-res x) (representative-res x)))) )

(define (normalize-representative ideal rep)
  (cond
    ( (null? ideal) rep )
    ( (g-normform 
        (normalize-representative
          (cdr ideal)
          (g-modulo rep (car ideal)))) )) )

(put 'res 'normform normform-euclid-res)

(define (g-normform-euclid x) (operate-1 'normform-euclid x))


; CRA-Algorithmus

(define (g-cra xl)
  (cond
    ( (null? xl) nil )
    ( (null? (cdr xl)) (car xl) )
    ( (let ( (xx (g-cra (cdr xl))) )
        (let ( (eucl (g-norm-euclid 
                       (car (ideal-res (car xl)))
                       (car (ideal-res xx)))) )
          (cond
            ( (= 1 (car eucl))
                (g-normform
                  (make-res
                    (list (g-* (car (ideal-res (car xl))) (car (ideal-res xx))))
                    (g-+
                      (representative-res xx)
                      (g-*
                        (g-- 
                          (representative-res (car xl)) 
                          (representative-res xx))
                      (g-*
                        (caddr eucl)
                        (car (ideal-res xx))))))) )
             ( (error "Ideals not relatively prime -- G-CRA" xl) )))) )) )

(define (g-norm-cra xl)
  (g-normform (g-cra xl)))


; \sct{Polynomarithmetik}

; \ssct{Darstellung von Polynomen}

; Ziel ist die Behandlung des Polynomrings $S=R[X_1,\dots,X_n]$ "uber
; einem beliebigen Ring $R$. Die Polynome $f \in S$ k"onnen auf
; verschiedene Weise dargestellt werden:

; Summe von Monomen mit Koeffizienten in $R$,

; Summe von homogenen Polynomen,

; Entwicklung nach $X_n$ (mit entsprechender Darstellung der
; Koeffizienten $\in R[X_1,\dots,X_{n-1}]$), also Betrachtung des
; Polynomrings $R[X_1][X_2],\dots,[X_n]$.

; Man kann ferner diverse Vereinfachungen der Bezeichnungsweise
; einf"uhren, z.B. indem man die Variablennamen nicht explizit
; angibt, sondern Listen betrachtet, in denen nur die Koeffizienten
; und die Exponenten vorkommen. Oder man gibt nur Listen von
; Koeffizienten an, wobei von einer festen Ordnung der Monome
; ausgegangen wird; in diesem Fall m"ussen auch Koeffizienten $=0$
; aufgef"uhrt werden.

; Bei Polynomen in einer Unbestimmten bieten sich noch folgende
; Darstellungsm"oglichkeiten an:

; als Produkt von Linearfaktoren,

; als Liste der Nullstellen des Polynoms,

; als Liste der Werte des Polynoms an vorgegebenen Punkten.

; Je nach konkreter Aufgabenstellung kann die eine oder die andere
; Vorgehensweise vorzuziehen sein.

; Unser Verfahren verlangt nicht, da"s wir uns von vornherein auf
; eine bestimmte Darstellungsart festlegen. So "ahnlich, wie wir
; komplexe Zahlen durch Real- und Imagin"arteil oder in
; Polarkoordinatendarstellung behandlen konnten, k"onnen auch hier
; verschiedene Repr"asentationen neben- und miteinander verwendet
; werden.

; In dieser Vorlesung soll allerdings nur eine Darstellungsform
; eingef"uhrt werden: Polynome werden explizit als Summe (d.h.: als
; Liste) von Monomen eingef"uhrt, wobei die Variablennamen in jedem Monom
; angegeben werden. Monome mit Koeffizient $0$ werden nicht
; angegeben.

; Die Monome sind nicht in willk"urlicher Ordnung in dieser Liste
; eingetragen. Die Reihenfolge h"angt vielmehr ab von der Angabe
; einer in der Definition des Polynoms zus"atzlich angegeben
; Ordnungsfunktion f"ur die Monome (z.B. lexikographische oder
; grad-lexikographische Ordnung der Monome)

; Auch f"ur die Variablen kann die Ordnung frei definiert werden.
; Geeignete Festlegungen der Ordnungen f"ur die Monome und f"ur
; die Variablen sind wichtig bei gewissen Algorithmen f"ur
; Polynome.

; Da der Koeffizientenring beliebig ist, ist die Darstellungsform
; von Polynomen als Elemente von $R[X_1][X_2],\dots,[X_n]$ in diesem
; Verfahren als Spezialfall mit inbegriffen.

; \beg{alg} Einf"uhrung von Polynomen

; \index{poly?}\bv
(define (poly? f)
  (eq? (type f) 'poly))
; \end{verbatim}\index{make-poly}\bv
(define (make-poly mlist olist)
  (attach-type 'poly (cons mlist olist)))
; \end{verbatim}\index{mlist}\bv
(define (mlist f)
  (cond
    ( (poly? f) (car (contents f)) )
    ( else nil )))
; \end{verbatim}\index{olist}\bv
(define (olist f)
  (cond
    ( (poly? f) (cdr (contents f)) )
    ( else nil )))
; \end{verbatim}\index{monom-ordering-poly}\bv
(define (monom-ordering-poly f)
  (monom-ordering-olist (olist f)) )
; \end{verbatim}\index{monom-ordering-olist}\bv
(define (monom-ordering-olist ol)
  (cond
    ( (null? ol) (give-global-monom-ordering) )
    ( else (car ol) )) )
; \end{verbatim}\index{give-global-monom-ordering}\bv
(define (give-global-monom-ordering)
  'lexicographic )
; \end{verbatim}\index{var-ordering-poly}\bv
(define (var-ordering-poly f)
  (var-ordering-olist (olist f)) )
; \end{verbatim}\index{var-ordering-olist}\bv
(define (var-ordering-olist ol)
  (cond
    ( (null? ol) (give-global-var-ordering) )
    ( (null? (cdr ol)) (give-global-var-ordering) )
    ( else (cadr ol) )) )
; \end{verbatim}\index{give-global-var-ordering}\bv
(define (give-global-var-ordering)
   'alphabetic )
  
; Fuer spaetere Anwendungen wird noch eingefuehrt:
; \end{verbatim}\index{h-term}\bv
(define (h-term f)
  (cond
    ( (not (poly? f)) (list f) )
    ( (null? (mlist f)) nil )
    ( else (car (mlist f)) )) )
; \end{verbatim}\index{rest-list}\bv
(define (rest-list f)
  (cond
    ( (not (poly? f)) nil )
    ( (null? (mlist f)) nil )
    ( else (cdr (mlist f)) )) )
; \end{verbatim}\index{rest-poly}\bv
(define (rest-poly f)
  (cond
    ( (not (poly? f)) 0 )
    ( (null? (mlist f)) (make-poly nil (olist f)))
    ( else (make-poly (cdr (mlist f)) (olist f)) )) )
; \end{verbatim}


; \end{alg}

; Die bei der Einf"uhrung der Polynome angegebene {\bf olist} ist
; dabei eine Liste, die die Prozeduren angibt, nach denen die
; Monome und die Variablen geordnet werden sollen. Sind keine
; entsprechenden Prozeduren in dieser Liste eingetragen, sollen die
; Algorithmen die Ordnung nach Standard-Vorgaben vornehmen
; (lexikographische Ordnung der Monome, alphabetische Ordnung der
; Variablen bzw. andere global vorgegeben Ordnungen).


; Die arithmetischen Operationen und sonstigen Operatoren f"ur
; Polynome werden auf entsprechende Operationen f"ur Monomlisten
; zur"uckgef"uhrt:

; \beg{alg} Operatoren f"ur Polynome

; \bv

; Nullstellige Operationen:
; ========================
; \end{verbatim}\index{he-empty-olist}\bv
(define the-empty-olist nil)
; \end{verbatim}\index{he-empty-mlist}\bv
(define the-empty-mlist nil)
; \end{verbatim}\index{he-empty-plist}\bv
(define the-empty-plist nil)
; \end{verbatim}\index{zero-poly}\bv
(define (zero-poly type-of-coefficients)
  (make-poly the-empty-mlist the-empty-olist) )
; \end{verbatim}\index{identity-poly}\bv
(define (identity-poly type-of-coefficients)
  (make-poly 
    (list (make-monom 1 the-empty-plist))
    the-empty-olist) )

; Einstellige Operationen:
; =======================
; \end{verbatim}\index{zero-poly?}\bv
(define (zero-poly? f)
  (zero-monom? (h-term f)) )
; \end{verbatim}\index{unit-poly?}\bv
(define (unit-poly? f)
  (unit-monom? (h-term f)) )
; \end{verbatim}\index{degree-poly}\bv
(define (degree-poly f)
  (degree-mlist (mlist f)) )
; \end{verbatim}\index{var-degree-poly}\bv
(define (var-degree-poly var f)
  (var-degree-mlist var (mlist f)) )
; \end{verbatim}\index{minus-poly}\bv
(define (minus-poly f)
  (make-poly (minus-mlist (mlist f)) (olist f)) )
; \end{verbatim}\index{inverse-poly}\bv
(define (inverse-poly f)
  (cond
    ( (unit-poly? f) (g-inverse (coefficient (h-term f))) )
    ( (error "Non existing inverse -- INVERSE-POLY" f) )) )
; \end{verbatim}\index{type-of-coefficients}\bv
(define (type-of-coefficients f)
  (type (coefficient (h-term f))) )

; Zweistellige Operationen:
; ========================
; \end{verbatim}\index{+poly}\bv
(define (+poly f1 f2)
  (let ( (ol (check-olists (olist f1) (olist f2))) )
       (make-poly (+mlist ol (mlist f1) (mlist f2)) ol)) )
; \end{verbatim}\index{-poly}\bv
(define (-poly f1 f2)
  (+poly f1 (minus-poly f2)))
; \end{verbatim}\index{*poly}\bv
(define (*poly f1 f2)
  (let ( (ol (check-olists (olist f1) (olist f2))) )
       (make-poly (*mlist ol (mlist f1) (mlist f2)) ol)) )
; \end{verbatim}\index{/poly}\bv
(define (/poly f1 f2)
  (*poly f1 (quot-inverse-poly f2)))
; \end{verbatim}\index{check-olists}\bv
(define (check-olists ol1 ol2)
  (cond
    ( (null? ol1) ol2 )
    ( (cond
        ( (null? ol2) ol1 )
        ( (equal? ol1 ol2) ol1 )
        ( (error "Inconsistent orderings -- CHECK-OLISTS"
                 (list ol1 ol2)) )) )) )
; \end{verbatim}\index{normform-poly}\bv
(define (normform-poly f)
  (cond
    ( (zero-poly? f) 0 )
    ( (zero? (degree-poly f)) (g-normform (coefficient (h-term f))) )
    ( (make-poly (normform-mlist (mlist f) (olist f)) (olist f)) )) )
; \end{verbatim}

; \end{alg}

; \ssct{Monome und Monomlisten}

; Wir f"uhren jetzt die im letzten Abschnitt bereits erw"ahnten
; Prozeduren f"ur die Monomlisten von Polynomen ein.

; Monomlisten sind Listen von Monomen in absteigender Reihenfolge der
; gegebenen Ordnung von Monomen.

; Monome sind "`A-Listen mit Kopf"', also eindimensionale Tabellen im
; Sinn von Abschnitt 2.1.4. Der {\bf car} dieser Listen enth"alt
; den Koeffizienten des Monoms, dann kommt eine Liste von Paaren,
; bei denen jeweils der {\bf car} den Variablennamen, der {\bf cdr}
; den zugeh"origen Exponenten enth"alt. Die Variablen sind in der
; angegebenen Ordnung von Variablen aufgef"uhrt.

; Es werden spezielle Operationen f"ur Variable und f"ur Monome
; und Monomlisten eingef"uhrt. Diese Operationen werden aber nicht
; in die Operatoren-Tabelle eingetragen, weil wir f"ur Variable und
; Monome nicht die Typbezeichnungen und generischen Operatoren
; einf"uhren wollen, sondern in eine spezielle Tabelle mit
; diesen Ordnungen.

; \beg{alg} Ordnungen f"ur Variable und Monome

; \bv

; Ordnungen von Variablen:
; =======================
; \end{verbatim}\index{-order-table}\bv
(define v-order-table (make-table))
; \end{verbatim}\index{put-v-order}\bv
(define (put-v-order v-order op proc)
  (insert! v-order op proc v-order-table))
; \end{verbatim}\index{var-<-alphabetic?}\bv
(define (var-<-alphabetic? var1 var2)
  (cond
    ( (char? var1)
        (cond
          ( (char? var2) (char-ci<? var1 var2) )
          ( (string? var2) (string-ci<? (make-string 1 var1) var2) )
          ( (error "Variables of wrong type -- VAR-<-ALPHABETIC?"
                   (list var1 var2)) )) )
    ( (string? var1)
        (cond
          ( (string? var2) (string-ci<? var1 var2) )
          ( (char? var2) (string-ci<? var1 (make-string 1 var2)) )
          ( (error "Variables of wrong type -- VAR-<-ALPHABETIC?"
                   (list var1 var2)) )) )
    ( (error "Variables of wrong type -- VAR-<-ALPHABETIC?" (list var1 var2)) )) )

(put-v-order 'alphabetic '< var-<-alphabetic?)
; \end{verbatim}\index{get-v-order}\bv
(define (get-v-order v-order op)
  (lookup v-order op v-order-table))
; \end{verbatim}\index{<-var}\bv
(define (<-var v1 v2 v-order)
  (let ((proc (get-v-order v-order '<)))
    (cond
      ( (not (null? proc)) (proc v1 v2) )
      ( (error "Order of variables undefined -- <-VAR" (list v1 v2)) ))) )
; \end{verbatim}\index{>-var}\bv
(define (>-var v1 v2 v-order)
  (<-var v2 v1 v-order))

; Ordnungen von Monomen:
; =====================
; \end{verbatim}\index{m-order-table}\bv
(define m-order-table (make-table))
; \end{verbatim}\index{put-m-order}\bv
(define (put-m-order m-order op proc)
  (insert! m-order op proc m-order-table))

; (put-m-order 'lexicographic '< <-lexicographic)

; (put-m-order 'degree-lexicographic '< <-degree-lexicographic)

; Die Definition dieser Ordnungen wird weiter unten angegeben.
; \end{verbatim}\index{get-m-order}\bv
(define (get-m-order m-order op)
  (lookup m-order op m-order-table))
; \end{verbatim}\index{<-monom}\bv
(define (<-monom m1 m2 ol)
  (let ((m-order (monom-ordering-olist ol)) (v-order (var-ordering-olist ol)))
    (let ((proc (get-m-order m-order '<)))
      (cond
        ( (not (null? proc)) (proc m1 m2 v-order) )
        ( (error "Order of monomials undefined -- <-MONOM" (list m1 m2)) )))) )
; \end{verbatim}\index{>-monom}\bv
(define (>-monom m1 m2 ol)
  (<-monom m2 m1 ol))
; \end{verbatim}

; \end{alg}

; Man betrachtet zun"achst Monome:

; \beg{alg} Operationen f"ur Monome

; \bv

; Allgemeine Prozeduren:
; =====================
; \end{verbatim}\index{make-monom}\bv
(define (make-monom coefficient plist)
  (cond
    ( (null? coefficient) nil )
    ( (g-zero? coefficient) nil )
    ( (cons coefficient plist) )) )
; \end{verbatim}\index{coefficient}\bv
(define (coefficient monom)
  (cond
    ( (null? monom) 0)
    ( (atom? monom) monom )
    ( (car monom) )) )
; \end{verbatim}\index{powers-list}\bv
(define (powers-list monom)
  (cond
    ( (null? monom) nil )
    ( (atom? monom) nil )
    ( (cdr monom) )) )
; \end{verbatim}\index{variables-list}\bv
(define (variables-list monom)
  (map car (powers-list monom)))
; \end{verbatim}\index{exponents-list}\bv
(define (exponents-list monom)
  (map cdr (powers-list monom)))
; \end{verbatim}\index{minus-monom}\bv
(define (minus-monom m)
  (make-monom (g-minus (coefficient m)) (powers-list m)))
; \end{verbatim}\index{zero-monom?}\bv
(define (zero-monom? m)
  (cond
    ( (null? m) )
    ( (g-zero? (coefficient m)) )) )
; \end{verbatim}\index{unit-monom?}\bv
(define (unit-monom? m)
  (and (g-unit? (coefficient m))
       (null? (powers-list m))) )

; Grad von Monomen:
; ================
; \end{verbatim}\index{degree-monom}\bv
(define (degree-monom monom)
  (sum-list (exponents-list monom)))
; \end{verbatim}\index{sum-list}\bv
(define (sum-list li)
  (eval (cons '+ li)))
; \end{verbatim}\index{var-degree-monom}\bv
(define (var-degree-monom var monom)
  (let ((p (assq var (powers-list monom))))
    (cond
      ( (null? p) 0 )
      ( else (cdr p) ))) )

; Die folgende Prozedur erstellt zu einer vorgegebenen Liste von
; Variablen die Liste der in einem Monom vorkommenden Exponenten
; dieser Variablen:
; \end{verbatim}\index{exp-list}\bv
(define (exp-list monom varlist); \end{verbatim}\index{vardeg}\bv
  (define (vardeg var)    ; die Prozedur vardeg wird als lokal-
                          ; definierte Prozedur eingefuehrt, da
                          ; innerhalb des Prozedur-Koerpers von
                          ; dem durch das define implizit
                          ; aufgerufenen lambda.
    (var-degree-monom var monom)) 
  (map vardeg varlist))

; Hilfsprozeduren fuer geordnete Listen:
; =====================================

; Die Listen sind in absteigender Folge geordnet.
; Bei der folgenden Prozedur kommen Elemente, die sich der
; Ordnung nach nicht unterscheiden, nur einmal vor:
; \end{verbatim}\index{join-ordered-lists}\bv
(define (join-ordered-lists list1 list2 <-proc)
  (cond
    ( (null? list1) list2 )
    ( (join-ordered-lists 
        (cdr list1)
        (join-element (car list1) list2 <-proc) 
        <-proc) )) )
; \end{verbatim}\index{join-element}\bv
(define (join-element element li <-proc)
  (cond
    ( (null? li) (list element) )
    ( (<-proc (car li) element) (cons element li) )
    ( (<-proc element (car li))
      (cons
        (car li)
        (join-element element (cdr li) <-proc)) )
    ( li )) )

; Bei der nun folgenden Prozedur kommen Elemente, die sich der
; Ordnung nach nicht unterscheiden, unter Umstaenden mehrmals vor:
; \end{verbatim}\index{join2-ordered-lists}\bv
(define (join2-ordered-lists list1 list2 <-proc)
  (cond
    ( (null? list1) list2 )
    ( (join2-ordered-lists 
        (cdr list1)
        (join2-element (car list1) list2 <-proc) 
        <-proc) )) )
; \end{verbatim}\index{join2-element}\bv
(define (join2-element element li <-proc)
  (cond
    ( (null? li) (list element) )
    ( (<-proc (car li) element) (cons element li) )
    ( (<-proc element (car li))
      (cons
        (car li)
        (join-element element (cdr li) <-proc)) )
    ( (cons element li) )) )

; Lexikographische Ordnung von Listen ganzer Zahlen:
; =================================================
; \end{verbatim}\index{<-lexi-integer?}\bv
(define (<-lexi-integer? l1 l2)
  (cond
    ( (null? l1) 
      (cond
        ( (not (null? l2))  
            (error "Different lengths of lists -- LEXI-INTEGER" l2) )
        ( else nil )) )
    ( (null? l2) (error "Different lengths of lists -- LEXI-INTEGER" l1) ) 
    ( (= (car l1) (car l2)) (<-lexi-integer? (cdr l1) (cdr l2)) ) 
    ( (< (car l1) (car l2)) ) 
    ( else nil )) )

; Beispiel: (0 1) < (0 2) < (0 3) < (1 1)

; Lexikographische Ordnung von Monomen:
; ====================================

; Es wird zunaechst die Liste der in beiden Monomen vorkommenden
; Variablen gebildet. Dann erstellt man die Listen der Exponenten
; dieser Variablen in jedem der Monome. Man wendet dann die Prozedur 
; <-lexi-integer auf diese Listen an.
; \end{verbatim}\index{<-lexicographic?}\bv
(define (<-lexicographic? m1 m2 v-order)
  (let ((j-v-list (joined-var-list m1 m2 v-order)))
    (<-lexi-integer? (exp-list m1 j-v-list) (exp-list m2 j-v-list))))
; \end{verbatim}\index{joined-var-list}\bv
(define (joined-var-list m1 m2 v-order); \end{verbatim}\index{<-proc}\bv
  (define (<-proc v1 v2)  
    (<-var v1 v2 v-order))
  (join-ordered-lists 
    (variables-list m1) 
    (variables-list m2)
    <-proc) )

; Grad-lexikographische Ordnung von Monomen:
; =========================================
; \end{verbatim}\index{<-degree-lexicographic?}\bv
(define (<-degree-lexicographic? m1 m2 v-order)
  (cond 
    ( (< (degree-monom m1) (degree-monom m2)) )
    ( (> (degree-monom m1) (degree-monom m2)) nil )
    ( (<lexicographic? m1 m2 v-order) )))

(put-m-order 'lexicographic '< <-lexicographic?)

(put-m-order 'degree-lexicographic '< <-degree-lexicographic?)

; Multiplikation von Monomen:
; ==========================
; \end{verbatim}\index{*monom}\bv
(define (*monom m1 m2 v-order)
  (make-monom (g-* (coefficient m1) (coefficient m2))
              (*plist (powers-list m1) (powers-list m2) v-order)))
; \end{verbatim}\index{*plist}\bv
(define (*plist pp1 pp2 v-order)
  (cond
    ( (null? pp1) pp2 )
    ( (*plist (cdr pp1) (*vp-plist (car pp1) pp2 v-order) v-order) )) )
; \end{verbatim}\index{*vp-plist}\bv
(define (*vp-plist vp plist v-order)
  (cond
    ( (null? plist) 
      (cond
        ( (zero? (cdr vp)) nil )
        ( (list vp) )) )
    ( (>-var (car vp) (caar plist) v-order)
        (cons vp plist) )
    ( (eq? (car vp) (caar plist))
        (cons (cons (car vp) (+ (cdr vp) (cdar plist))) (cdr plist)) )
    ( (cons (car plist) (*vp-plist vp (cdr plist) v-order)) )) )

; Normalform von Monomen:
; ======================
; \end{verbatim}\index{normform-monom}\bv
(define (normform-monom m ol)
  (cond
    ( (null? m) nil )
    ( (let ( (v-order (var-ordering-olist ol)) )
        (make-monom 
          (g-normform (coefficient m)) 
          (normform-plist (powers-list m) v-order))) )) )
; \end{verbatim}\index{normform-plist}\bv
(define (normform-plist pl v-order)
  (cond
    ( (null? pl) nil )
    ( (adjoin-p-plist 
        v-order 
        (car pl) 
        (normform-plist (cdr pl) v-order)) )) )
; \end{verbatim}\index{adjoin-p-plist}\bv
(define (adjoin-p-plist v-order p pl)
  (cond
    ( (null? p) pl )
    ( (null? pl) 
      (cond
        ( (zero? (cdr p)) nil )
        ( (list p) )) )
    ( (>-var (car p) (caar pl) v-order) 
      (cond
        ( (zero? (cdr p)) pl )
        ( else (cons p pl) )) )
    ( (<-var (car p) (caar pl) v-order)
        (cons (car pl) (adjoin-p-plist v-order p (cdr pl))) )
    ( (let ( (expon (+ (cdr p) (cdar pl))) )
        (cond
          ( (zero? expon) (cdr pl) )
          ( (cons 
              (cons (car p) expon) 
              (cdr pl)) ))) )) )

; Manchmal ist es zweckmaessig, auch negative Exponenten
; zuzulassen. Man kann dann definieren:
; \end{verbatim}\index{inverse-monom}\bv
(define (inverse-monom m v-order)
  (cond
    ( (null? m)
        (error "Inverse does not exist -- INVERSE-MONOM" m) )
    ( (make-monom 
        (g-quot-inverse (coefficient m))
        (inverse-plist (powers-list m) v-order)) )) )
; \end{verbatim}\index{inverse-plist}\bv
(define (inverse-plist pl v-order)
  (cond
    ( (null? pl) nil )
    ( (*plist 
        (list (cons (caar pl) (- (cdar pl))))
        (inverse-plist (cdr pl) v-order)
        v-order) )) )
; \end{verbatim}

; \end{alg}

; \beg{alg} Operationen f"ur Monomlisten

; \bv

; Einstellige Operationen:
; =======================
; \end{verbatim}\index{degree-mlist}\bv
(define (degree-mlist mlist)
  (cond
    ( (null? mlist) (- 1) )
    ( (eval (cons 'max (map degree-monom mlist))) )) )
; \end{verbatim}\index{var-degree-mlist}\bv
(define (var-degree-mlist var mlist); \end{verbatim}\index{var-degree}\bv
  (define (var-degree monom)
    (var-degree-monom var monom))
  (eval (cons 'max (map var-degree mlist))) )
  ; \end{verbatim}\index{minus-mlist}\bv
(define (minus-mlist mlist)
  (map minus-monom mlist))


; Addition von Monomlisten:
; ========================
; \end{verbatim}\index{+mlist}\bv
(define (+mlist ol ml1 ml2)
  (cond
    ( (null? ml1) ml2)
    ( (+mlist
         ol
         (cdr ml1)
         (+monom-monomlist ol (car ml1) ml2)) )) )
; \end{verbatim}\index{+monom-monomlist}\bv
(define (+monom-monomlist ol m ml)
  (cond
    ( (null? m) ml )
    ( (null? ml) (list m) )
    ( (>-monom  m (car ml) ol)
        (cons m ml) )
    ( (equal? (powers-list m) (powers-list (car ml)))
        (let ((coeff (g-+ (coefficient m) (coefficient (car ml)))))
          (cond
            ( (g-zero? coeff) (cdr ml) )
            ( (cons
                (make-monom coeff (powers-list m))
                (cdr ml)) ))) ) 
     ( (cons (car ml) (+monom-monomlist ol m (cdr ml))) )) )

; Multiplikation von Monomlisten:
; ==============================
; \end{verbatim}\index{*mlist}\bv
(define (*mlist ol ml1 ml2)
  (cond
    ( (null? ml1) the-empty-mlist )
    ( (+mlist
        ol
        (*monom-monomlist ol (car ml1) ml2)
        (*mlist ol (cdr ml1) ml2)) )) )
; \end{verbatim}\index{*monom-monomlist}\bv
(define (*monom-monomlist ol m ml); \end{verbatim}\index{*m-monom}\bv
  (define (*m-monom monom)
    (*monom m monom (var-ordering-olist ol)))
  (map *m-monom ml) )

; Normalform von Monomlisten:
; ==========================
; \end{verbatim}\index{normform-mlist}\bv
(define (normform-mlist ml ol)
  (cond
    ( (null? ml) nil )
    ( (adjoin-m-mlist 
        ol 
        (normform-monom (car ml) ol) 
        (normform-mlist (cdr ml) ol)) )) )
; \end{verbatim}\index{adjoin-m-mlist}\bv
(define (adjoin-m-mlist ol m ml)
  (cond
    ( (null? m) ml )
    ( (null? ml) (list m) )
    ( (>-monom m (normform-monom (car ml) ol) ol) (cons m ml) )
    ( (<-monom m (normform-monom (car ml) ol) ol) 
        (cons 
          (normform-monom (car ml) ol)
          (adjoin-m-mlist ol m (cdr ml))) )
    ( (let ((coeff (g-+ (coefficient m) (coefficient (car ml)))))
        (cond
          ( (g-zero? coeff) (cdr ml) )
          ( (cons
              (make-monom coeff (powers-list m))
              (cdr ml)) ))) )) )
; \end{verbatim}

; \end{alg}

; \beg{alg} Einf"ugen der Prozeduren in die Operatorentabelle

; \bv

(put 'poly 'zero zero-poly)

(put 'poly 'identity identity-poly)

(put 'poly 'zero? zero-poly?)

(put 'poly 'unit? unit-poly?)

(put 'poly 'degree degree-poly)

(put 'poly 'var-degree var-degree-poly)

(put 'poly 'normform normform-poly)

(put 'poly 'minus minus-poly)

(put 'poly 'inverse inverse-poly)

(put 'poly '+ +poly)

(put 'poly '- -poly)

(put 'poly '* *poly)

(put 'poly '/ /poly)
; \end{verbatim}\index{g-degree}\bv
(define (g-degree f) (operate-1 'degree f))
; \end{verbatim}\index{g-var-degree}\bv
(define (g-var-degree var f) (operate-2 'var-degree var f))
; \end{verbatim}\index{g-id}\bv
(define (g-id a)
  (cond
    ( (poly? a)
        (cond
          ( (g-zero? a) 1 )
          ( (g-identity (type (coefficient (h-term a)))) )) )
    ( (g-identity (type a)) )) )
; \end{verbatim}\index{g-ze}\bv
(define (g-ze a)
  (cond
    ( (poly? a)
        (cond
          ( (g-zero? a) 0 )
          ( (g-zero (type (coefficient (h-term a)))) )) )
    ( (g-zero (type a)) )) )
; \end{verbatim}

; \end{alg}

; \ssct{"Ubergangsprozeduren}


; \beg{alg} Uebergangsprozeduren

; \index{integer->poly}\bv
(define (integer->poly n) 
  (make-poly
    (list (make-monom n the-empty-plist))
    the-empty-olist) )
; \end{verbatim}\index{rat->poly}\bv
(define (rat->poly x) 
  (make-poly
    (list (make-monom x the-empty-plist))
    the-empty-olist) )
; \end{verbatim}\index{real->poly}\bv
(define (real->poly x) 
  (make-poly
    (list (make-monom x the-empty-plist))
    the-empty-olist) )
; \end{verbatim}\index{residue->poly}\bv
(define (residue->poly x) 
  (make-poly
    (list (make-monom x the-empty-plist))
    the-empty-olist) )
; \end{verbatim}\index{rectangular->poly}\bv
(define (rectangular->poly z) 
  (make-poly
    (list (make-monom z the-empty-plist))
    the-empty-olist) )
; \end{verbatim}\index{polar->poly}\bv
(define (polar->poly z) 
  (make-poly
    (list (make-monom z the-empty-plist))
    the-empty-olist) )

(put-coercion 'integer 'poly integer->poly)

(put-coercion 'rat 'poly rat->poly)

(put-coercion 'real 'poly real->poly)

(put-coercion 'residue 'poly residue->poly)

(put-coercion 'rectangular 'poly rectangular->poly)

(put-coercion 'polar 'poly polar->poly)
; \end{verbatim}

; \end{alg}

; \ssct{Beispiele}


; \beg{alg} Beispiele

; \index{ }\bv
(define f (make-poly '( (1 (#\z . 2) (#\y . 3)) (5 (#\y . 1) (#\x . 2)))  
                      nil ))
; \end{verbatim}\index{g}\bv
(define g (minus-poly f))
; \end{verbatim}\index{a}\bv
(define a (make-poly (append (mlist f) (mlist g)) nil))
; \end{verbatim}\index{h}\bv
(define h 
  (make-poly 
    (list 
      (make-monom 3 '((#\z . 2) (#\y . 3)))
      (make-monom 4 '((#\y . 1) (#\x . 2))))  
    nil ))

(define k (minus-poly h))

(define l 
  (make-poly 
    (list 
      (make-monom 6 '((#\z . 2) (#\y . 3)))
      (make-monom 7 '((#\y . 1) (#\x . 2))))  
    nil ))

(define m (minus-poly l))
; \end{verbatim}\index{s1}\bv
(define s1 (g-+ f g))

(define s2 (g-+ f h))

(define s3 (g-+ f l))

(define s4 (g-+ h l))
; \end{verbatim}\index{p1}\bv
(define p1 (g-* f g))

(define p2 (g-+ f h))

(define p3 (g-* f l))

(define p4 (g-+ h l))

(define p5 (g-* s3 s4))

(define p6 (g-+ p3 p4))

(define p8
  (make-poly 
    (list 
      (make-monom p3 '((#\z . 2) (#\y . 3)))
      (make-monom  l '((#\y . 1) (#\x . 2)))
      (make-monom (g-+ p3 l) nil))  
    nil ))
; \end{verbatim}\index{g-square}\bv
(define (g-square x)
  (g-* x x))
; \end{verbatim}

; \end{alg}


; \sct{Der Chinesische Restsatz}

; Sei $R$ ein kommutativer Ring mit 1.

; \begin{defi}
; Zwei Ideale $A,B \subset R$ hei"sen {\em relativ prim}, wenn
; gilt: $A + B = R$.

; \end{defi}

; \begin{bem}

; a) Zwei Hauptideale $A= aR,B =bR$ in einem euklidischen Ring sind genau dann 
; relativ prim, wenn gilt: $\gcd(a,b)$ = 1.
; (Dies ist eine Folgerung aus dem euklidischen Algorithmus.)

; b) Sei $\pi_A : R \to R/A$ die kanonische Restklassenabbildung.
; $A,B$ sind genau dann relativ prim, wenn gilt: $\pi_A(B) = R/A$.
; (Dies folgt aus $\pi_A(B) = A+B/A$.)

; \end{bem}

; Dies ist eine Folgerung aus dem euklidischen Algorithmus.

; \begin{lemma}
; Seien $A_1, \dots ,A_k$ relativ prim. Dann gilt:

; a) $A_1 \dots A_{k-1}$ und $A_k$ sind relativ prim. (F"ur diese
; Behauptung mu"s eigentlich nur vorausgesetzt werden: $A_i,A_k$
; relativ prim f"ur $i=1,\dots,k-1$).

; b) $A_1 \dots A_k = A_1 \cap \dots \cap A_k$

; \end{lemma}

; {\em Beweis:} 

; a) Ist $\pi : R \to R/A_k$ die Restklassenabbildung, so
; gilt nach der Bemerkung oben: $\pi(A_i) = R/A$ f"ur $i=1,\dots,k-1$.
; Es folgt: $\pi(A_1 \dots A_{k-1}) = R/A \dots R/A = R/A$.

; b) Induktion nach $k$.

; F"ur $k=1$ ist nichts zu beweisen.

; Sei $k > 1$. 
; Induktionsvoraussetzung: $A_1 \dots A_{k-1} = A_1 \cap \dots \cap A_{k-1} =: A$ 
; Zu zeigen: $A A_k = A \cap A_k$. Offensichtlich gilt "`$\subset$"'.
; Da $A = A_1 \dots A_{k-1}$ und $A_k$ relativ prim sind, gibt es Elemente
; $a \in A, \ a_k \in A_k$ mit $a + a_k = 1$. F"ur $x \in A \cap A_k$ folgt
; $x = a x + a_k x \in A A_k$; daraus folgt "`$\supset$"'.

; \begin{satz}[Chinesischer Restsatz] 

; Seien $A_1, \dots A_k \subset R$ paarweise teilerfremde Ideale,
; und sei $A := A_1 A_2 \dots A_k$. Die Abbildung
; $\chi:  R \to     (R/A_1) \times \dots \times (R/A_k), \quad
; x \mapsto (x+A_1, \dots , x+A_k)$ ist surjektiv, und es gilt 
; $\ker(\chi) = A$.

; \end{satz}

; Im Fall von Hauptidealen $A_i = m_iR$ macht der chinesische
; Restsatz eine Aussage "uber die L"osbarkeit simultaner
; Kongruenzen der folgenden Art: Sind $m_1, \dots, m_k$ teilerfremde Elemente, so
; gibt es zu beliebig vorgegebenen Ringelementen $r_1, \dots r_k$
; eine (modulo $m := m_1m_2\dots m_k$ eindeutig bestimmte)
; L"osung $r$ f"ur die Kongruenzen


; $$   x      \equiv r_1 mod m_1 $$

; $$   x      \equiv r_2 mod m_2 $$

; $$   \vdots $$

; $$   x      \equiv r_k mod m_k $$

; {\em Beweis:} Sei $i \in \{1,\dots,k\}$. Nach Voraussetzung gibt
; es f"ur jedes $j \in \{1,\dots,k\}$ Elemente $x_{ij} \in A_i$ und
; $y_{ij} \in A_j$ mit $x_{ij} + y{ij} = 1$. Sei $\delta_i := 
; y_{i1} \dots y_{i,i-1}  y_{i,i+1} \dots y_{ik}$. Dann gilt:
; $\delta_i \equiv 1 mod A_i$, $\delta_i \equiv 0 mod A_j$ f"ur
; $j \ne i$. Dann ist

; $$ r := \delta_1 r_1 \dots \delta_k r_k$$

; die gew"unschte L"osung. F"ur weitere Details des Beweises vgl.
; z.B. Schneider: Algebra und Elemente der Zahlentheorie.

; Wir bringen hier zun"achst den Satz in einer weiteren
; "aquivalenten Formulierung und dann eine rekursive Konstruktion
; der L"osung:

; \begin{satz}[Chinesischer Restsatz - alternative Formulierung]

; Seien $x_1 = r_1 + A_1 \in R/A_1, \dots x_k = r_k + A_k \in R/A_k$ 
; Restklassen mit paarweise teilerfremden Idealen $A_1, \dots ,A_k \subset R$,
; und sei  $A := A_1 A_2 \dots A_k$. Dann gibt es genau eine
; Restklasse $x = r + A \in R/A$, so da"s f"ur $i= 1, \dots k$ gilt:
; $r + A_i = x_i$.

; \end{satz}

; {\em Rekursiver Beweis:} Im Fall $k=1$ w"ahle $ x := x_1$. Sei nun $k > 1$, 
; und sei $x' = r' + A'$  die L"osung zu den Restklassen $x_1, \dots ,x_{k-1}$. 
; Dann sind $A_k$ und $A'$ teilerfremd, es gibt also Elemente $a_k \in A$ und
; $a' \in A'$ mit $a_k + a' = 1$. Mit $A := A_k A'$, $r := r'+ (r_k-r')a'$
; folgt die Behauptung.

; \beg{alg} Chinesischer Rest-Algorithmus f"ur euklidische Ringe.

; Argument: Eine Liste von Restklassen nach teilerfremden Hauptidealen.
; Wert: Die nach dem Chinesischen Restsatz ermittelte Restklasse.

; \index{g-cra}\bv
(define (g-cra xl)
  (cond
    ( (null? xl) nil )
    ( (null? (cdr xl)) (car xl) )
    ( (let ( (xx (g-cra (cdr xl))) )
        (let ( (eucl (g-norm-euclid 
                       (car (ideal-res (car xl)))
                       (car (ideal-res xx)))) )
          (cond
            ( (= 1 (car eucl))
                (g-normform
                  (make-res
                    (list (g-* (car (ideal-res (car xl))) (car (ideal-res xx))))
                    (g-+
                      (representative-res xx)
                      (g-*
                        (g-- 
                          (representative-res (car xl)) 
                          (representative-res xx))
                      (g-*
                        (caddr eucl)
                        (car (ideal-res xx))))))) )
             ( (error "Ideals not relatively prime -- G-CRA" xl) )))) )) )
; \end{verbatim}\index{g-norm-cra}\bv
(define (g-norm-cra xl)
  (g-normform (g-cra xl)))
; \end{verbatim}

; \end{alg}


; \sct{Restklassenringe von Polynomringen}

; \ssct{Polynomreduktion}

; Die Polynomreduktion fungiert als Ersatz f"ur die in euklidischen Ringen
; verwendete Division mit Rest bei der Bildung von Normalformalgorithmen.
; Die hier vorgestellten Algorithmen sind f"ur Polynomringe in endlich vielen
; Unbestimmten "uber einem K"orper; entsprechende Algorithmen k"onnen f"ur
; Polynomringe "uber euklidischen Ringen entwickelt werden.

; \beg{alg} Polynomreduktion

; \index{max-pol-order-monom}\bv
(define (max-pol-order-monom m)
  (minus (eval (cons 'min (exponents-list m)))) )
; \end{verbatim}\index{divides-monom?}\bv
(define (divides-monom? m1 m2 v-order)
  (not 
    (positive? 
      (max-pol-order-monom 
        (*monom (inverse-monom m1 v-order) m2 v-order)))) )
; \end{verbatim}\index{quotient-monom}\bv
(define (quotient-monom m1 m2 v-order)
  (let ( (q (*monom m1 (inverse-monom m2 v-order) v-order)) )
    (cond
      ( (positive? (max-pol-order-monom q)) nil )
      ( else q ))) )
; \end{verbatim}\index{reduce-poly}\bv
(define (reduce-poly f h)
  (cond
    ( (g-zero? h)
        (error 
          "Reduction with zero-polynomial not allowed - REDUCE-POLY"
          (list f h)) )
    ( else
       (let ( (ol (check-olists (olist f) (olist h))) )
         (let ( (pair (pair-poly h)) )
           (g-normform   
             (g-norm-ideal 
               (car 
                 (reduce-poly-pair
                   f 
                   (car pair)
                   (cdr pair)
                   ol)))))) )) )
; \end{verbatim}\index{pair-poly}\bv
(define (pair-poly h)
  (cons (h-term h) (g-minus (rest-poly h))))
; \end{verbatim}\index{reduce-poly-pair}\bv
(define (reduce-poly-pair f a b ol)
  (cond
    ( (null? f) '(0) )
    ( (g-zero? f) '(0) )
    ( else
       (let ( (q (quotient-monom (h-term f) a (var-ordering-olist ol))) )
         (cond
           ( (null? q)
               (let ( (rpp (reduce-poly-pair (rest-poly f) a b ol)) )
                 (cons
                   (g-+
                     (make-poly (list (h-term f)) nil)
                     (car rpp))
                 (cdr rpp))) )
             ( else
                (cons
                  (g-+
                    (*poly
                      (make-poly (list q) nil)
                      b)
                    (rest-poly f))
                  q) ))) )) )
                    ; \end{verbatim}

; \end{alg}

; \ssct{Reduktions-Normalform-Algorithmen}

; Gegeben sei eine Restklasse $x$ mit Repr"asentant $f$ und Ideal $A$. Ein
; Reduktions-Normalform-Algorithmus wendet auf den Repr"asentanten $f$ die
; oben beschriebene Reduktion nach den Basiselementen $h \in A$ an solange,
; bis das Verfahren abbricht.

; \begin{defi} Eine Monom-Ordnung $<-monom$ hei"st "`zul"assig"', wenn gilt:

; 1. F"ur alle Monome $m$ gilt $(<-monom 1 m)$.

; 2. Die Monom-Ordnung ist vertr"aglich mit der Monommultiplikation.

; \end{defi}

; Man kann zeigen:

; \begin{satz} Bei einer zul"assigen Monom-Ordnung bricht ein Reduktions-
; Normalform-Algorithmus stets nach endlich vielen Schritten ab.

; \end{satz}

; Man erh"alt unterschiedliche Reduktions-Normalform-Algorithmen je nach
; der Strategie, nach welcher die einzelnen Polynome $h$ der Idealbasis auf
; die einzelnen Monome von $f$ angewendet werden.

; \beg{alg} Ein Reduktions-Normalform-Algorithmus

; \index{total-reduction-poly}\bv
(define (total-reduction-poly f h)
  (cond
    ( (g-zero? h)
        (error 
          "Reduction with zero-polynomial not allowed - REDUCE-POLY"
          (list f h)) )
    ( else
       (let ( (ol (check-olists (olist f) (olist h))) )
         (let ( (pair (pair-poly h)) )
           (g-normform   
             (g-norm-ideal 
               (car 
                 (total-reduction-poly-pair 
                   f 
                   (car pair)
                   (cdr pair)
                   ol)))))) )) )
; \end{verbatim}\index{total-reduction-poly-pair}\bv
(define (total-reduction-poly-pair f a b ol)
  (cond
    ( (null? f) '(0) )
    ( (g-zero? f) '(0) )
    ( else
       (let ( (rpp (reduce-poly-pair f a b ol)) )
         (cond
           ( (null? (cdr rpp)) rpp )
           ( else
              (total-reduction-poly-pair (car rpp) a b ol) ))) )) )
; \end{verbatim}\index{total-reduction-ideal}\bv
(define (total-reduction-ideal f aa)
  (cond
    ( (null? aa) f )
    ( else
       (total-reduction-ideal
         (total-reduction-poly f (car aa))
         (cdr aa)) )) )
; \end{verbatim}\index{normform-reduction-res}\bv
(define (normform-reduction-res x)
  (make-res
    (ideal-res x)
    (total-reduction-ideal
      (representative-res x)
      (ideal-res x))) )
; \end{verbatim}

; \end{alg}

; \beg{alg} Beispiele

; \index{f1}\bv
(define
  f1
  (make-poly
    (list
      '( 3 (#\y . 1) (#\x . 2) )
      '( 2 (#\y . 1) (#\x . 1) )
      '( 1 (#\y . 1) )
      '( 9 (#\x . 2) )
      '( 5 (#\x . 1) )
      '(-3 ) )
    nil ))

(define
  f2
  (make-poly
    (list
      '( 2 (#\y . 1) (#\x . 3) )
      '(-1 (#\y . 1) (#\x . 1) )
      '(-1 (#\y . 1) )
      '( 6 (#\x . 3) )
      '(-5 (#\x . 2) )
      '(-3 (#\x . 1) )
      '( 3 ) )
    nil ))

(define
  f3
  (make-poly
    (list
      '( 1 (#\y . 1) (#\x . 3) )
      '( 1 (#\y . 1) (#\x . 2) )
      '( 3 (#\x . 3) )
      '( 2 (#\x . 2) ))
    nil ) )
; \end{verbatim}\index{aa}\bv
(define aa (list f1 f2 f3))
; \end{verbatim}\index{f1-res}\bv
(define
  f1-res
  (make-poly
    (list
      '( (residue 7 . 3) (#\y . 1) (#\x . 2) )
      '( (residue 7 . 2) (#\y . 1) (#\x . 1) )
      '( (residue 7 . 1) (#\y . 1) )
      '( (residue 7 . 9) (#\x . 2) )
      '( (residue 7 . 5) (#\x . 1) )
      '( (residue 7 . -3) ) )
    nil ))

(define
  f2-res
  (make-poly
    (list
      '( (residue 7 . 2) (#\y . 1) (#\x . 3) )
      '( (residue 7 . -1) (#\y . 1) (#\x . 1) )
      '( (residue 7 . -1) (#\y . 1) )
      '( (residue 7 . 6) (#\x . 3) )
      '( (residue 7 . -5) (#\x . 2) )
      '( (residue 7 . -3) (#\x . 1) )
      '( (residue 7 . 3) ) )
    nil ))

(define
  f3-res
  (make-poly
    (list
      '( (residue 7 . 1) (#\y . 1) (#\x . 3) )
      '( (residue 7 . 1) (#\y . 1) (#\x . 2) )
      '( (residue 7 . 3) (#\x . 3) )
      '( (residue 7 . 2) (#\x . 2) ))
    nil ) )
; \end{verbatim}\index{aa-res}\bv
(define aa-res (list f1-res f2-res f3-res))
; \end{verbatim}\index{g}\bv
(define
  g
  (make-poly
    (list
      '( 5 (#\y . 2) )
      '( 2 (#\y . 1) (#\x . 2) )
      '( (rat 5 . 2) (#\y . 1) (#\x . 1) )
      '( (rat 5 . 2) (#\y . 1) (#\x . 1) )
      '( (rat 3 . 2) (#\y . 1) )
      '( 8 (#\x . 2) )
      '( (rat 3 . 2) (#\x . 1) )
      '( (rat -9 . 2) ))
    nil))
; \end{verbatim}\index{xx}\bv
(define xx (make-res aa g))
; \end{verbatim}\index{xx1}\bv
(define xx1 (make-res aa f1))

(define xx2 (make-res aa f2))

(define xx3 (make-res aa f3))
; \end{verbatim}

; \end{alg}

; \sct{Gr"obner-Basen}

; Der Reduktions-Normalform-Algorithmus ist i.a. kein kanonischer Normalform-
; Algorithmus. Z.B. reduzieren sich die oben angegebenen Restklassen $xx2$ und
; $xx3$ bei Anwendung des Algorithmus nicht zur Nullklasse.

; \begin{defi} Eine Idealbasis hei"st Gr"obner-Basis, wenn jeder 
; Reduktions-Normalform-Algorithmus nach dieser Basis kanonisch ist.

; \end{defi}

; Wir werden den {\em Vervollst"andigungsalgorithmus} angeben, mit dessen Hilfe
; man von einer beliebigen Basis zu einer Gr"obner-Basis "ubergehen kann.
; Der Vervollst"andigungsalgorithmus basiert auf der nun im folgenden
; beschriebenen Charakterisierung von Gr"obner-Basen durch sog. 
; {\em S-Polynome}.

; \begin{defi} Seien $h_1, h_2$ Polynome mit den f"uhrenden Termen $a_1,a_2$. Sei
; weiter $b_i := a_i - h_1$, $i = 1,2$. Sei
; $s$ das kleinste gemeinsame Vielfache von $a_1$ und $a_2$, und zwar gelte
; $s = \sigma_i a_i$ f"ur$i=1,2$. Das Polynom 
; $SP(h_1,h_2) := \sigma_1 b_1 - \sigma_2 b_2$ hei"st das {\em S-Polynom}
; von $h_1$ und $h_2$.

; \end{defi}

; \beg{alg} S-Polynome

; \index{s-poly}\bv
(define (s-poly h1 h2)
  (s-poly-ol h1 h2 (check-olists (olist h1) (olist h2))))
; \end{verbatim}\index{s-poly-ol}\bv
(define (s-poly-ol h1 h2 ol)
  (let ( (pair1 (pair-poly h1))
         (pair2 (pair-poly h2)) 
         (v-order (var-ordering-olist ol)) )
    (let ( (multiples (lcm-factors-monom (car pair1) (car pair2) v-order)) )
      (g--
        (g-*
          (g-normform (make-poly (list (cadr multiples)) ol))
          (g-normform (cdr pair1)))
        (g-*
          (g-normform (make-poly (list (caddr multiples)) ol))
          (g-normform (cdr pair2)))))))
; \end{verbatim}\index{lcm-factors-monom}\bv
(define (lcm-factors-monom m1 m2 v-order)                     
  (let ( (j-v-list (joined-var-list m1 m2 v-order)) ); \end{verbatim}\index{power-lcm}\bv
    (define (power-lcm var)
      (cons var (max (var-degree-monom var m1) (var-degree-monom var m2))))
    (let ( (lcm-pl 
             (normform-plist
               (map power-lcm j-v-list)
               v-order)) )
      (let ( (lcm (make-monom 1 lcm-pl)) )
        (list
          lcm
          (quotient-monom lcm m1 v-order)
          (quotient-monom lcm m2 v-order))))))
; \end{verbatim}

; \end{alg}

; \begin{satz}[Charakterisierung von Gr"obner-Basen] Eine Idealbasis $E$ ist
; genau dann eine Gr"obner-Basis, wenn gilt: Ist $RNA$ ein 
; Reduktions-Normalform-Algorithmus in Bezug auf diese Idealbasis, so gilt
; f"ur je zwei Basiselemente $h_1, h_2 \in E$: $RNA(SP(h_1,h_2) = 0$.

; \end{satz}

; Der Beweis dieses Satzes ist nicht trivial, vgl. das Manuskript
; "`Theorie und Praxis der Polynomideale"' und die dort angegebene Literatur.

; \begin{defi} Eine Gr"obner-Basis $E$ hei"st {\em reduziert}, wenn jedes
; ihrer Polynome den h"ochsten Koeffizienten 1 hat und in Bezug auf die
; "ubrigen Polynome nicht reduzierbar ist.

; \end{defi}

; \begin{satz} Jedes Ideal besitzt eine (bis auf Reihenfolge) eindeutig 
; bestimmte reduzierte Gr"obner-Basis.

; \end{satz}

; Zum Beweis wird wieder auf das o.a. Manuskript verwiesen. Der folgende
; Algorithmus hat als Argument eine beliebige Idealbasis $E$ und als Wert die
; zugeh"orige reduzierte Gr"obner-Basis $F$. Die Basis wird bei der 
; Ausf"uhrung des Algorithmus stets so umgeordnet, da"s die f"uhrenden Terme
; der Basiselemente in schwach monoton fallender Folge kommen; bei der als
; Ergebnis erhaltenen reduzierten Gr"obner-Basis stehen sie dann sogar in
; strikt monoton fallender Folge.

; \beg{alg} Vervollst"andigungsalgorithmus

; \bv

; Hilfsprozeduren zur Anordnung von Basen:
; =======================================
; \end{verbatim}\index{<-poly}\bv
(define (<-poly f g)
  (let (( ol (check-olists (olist f) (olist g)) ))
    (<-monom (h-term f) (h-term g) ol)))
; \end{verbatim}\index{>-poly}\bv
(define (>-poly f g)
  (<-poly g f))

(put 'poly '< <-poly)

(put 'poly '> >-poly)
; \end{verbatim}\index{order-base}\bv
(define (order-base e)
  (join2-ordered-lists e nil <-poly))

; Der Vervollstaendigungsalgorithmus:
; ==================================
; \end{verbatim}\index{groebner}\bv
(define (groebner e)
  (cond
    ( (null? e) e )
    ( (let (( e (order-base e) ))
      (let (( i (indices e) )
            ( ol (olist (car e)) ))
      (let (( reduced-pair (reduce-base e e i ol) ))
      (let (( e (groebner-kernel (car reduced-pair) (cdr reduced-pair) ol) ))
      (order-base (car (reduce-base e e nil ol))) )))) )) )
; \end{verbatim}\index{indices}\bv
(define (indices e)
  (cond
    ( (null? e) nil )
    ( (null? (cdr e)) nil )
    ( (append (firstlist e) (indices (cdr e))) )) )
; \end{verbatim}\index{firstlist}\bv
(define (firstlist e); \end{verbatim}\index{make-pair}\bv
  (define (make-pair element)
    (cons (car e) element))
  (map make-pair (cdr e)))
; \end{verbatim}\index{groebner-kernel}\bv
(define (groebner-kernel e i ol)
  (cond
    ( (null? i) 

      (newline)
      (newline)
      (display "Groebner-Basis:")
      (newline)
      (newline)

      e )
    ( (let (( h (total-reduction-ideal (s-poly (caar i) (cdar i)) e) ))

      (newline)
      (display "Bildung des S-Polynoms der folgenden Polynome:")
      (newline)
      (pp (caar i))
      (newline)
      (pp (cdar i))
      (newline)
      (display "Reduziertes S-Polynom:")
      (newline)
      (pp h)
      (newline)

      (cond
        ( (g-zero? h)
          (groebner-kernel e (cdr i) ol) )
        ( (let (( e (cons h e) )
                ( i (append (cdr i) (firstlist (cons h e))) ))
          (let (( reduced-pair (reduce-base e e i ol) ))
          (groebner-kernel (car reduced-pair) (cdr reduced-pair) ol))) ))) )) )

; Der Hilfsalgorithmus zur Reduktion der Basis:
; ============================================

(define (reduce-base old-e new-e i ol)
  (cond
    ( (null? old-e) (cons new-e i) )
    ( (let (( ff (g-norm-ideal (total-reduction-ideal (car old-e) (cdr new-e))) )
            ( old-e (cdr old-e) )
            ( new-e (cdr new-e) )
            ( i (remove-indices (car old-e) i) ))
      (cond
        ( (g-zero? ff) (reduce-base old-e new-e i ol) )
        ( (reduce-base
            old-e
            (append new-e (list ff))
            (append i (firstlist (cons ff new-e)))
            ol) ))) )) )

; (define (remove-indices element i)
;   (cond
;     ( (null? i) nil )
;     ( (eq? (car i) element) (remove-indices element (cdr i)) )
;     ( (cons 
;         (car i)
;        (remove-indices element (cdr i))) )) )

; \end{verbatim}

; \end{alg}

; \beg{alg} Beispiele

; \index{gb-aa}\bv
; (define gb-aa (groebner aa))

; (pp gb-aa)

; Man erhaelt die Antwort

;((POLY ((1 (#\y . 1))
;        (-3)))
; (POLY ((1 (#\x . 1)))))
; \end{verbatim}\index{gb-aa-res}\bv
; (define gb-aa-res (groebner aa-res))

; (pp gb-aa-res)
; \end{verbatim}\index{ee}\bv
(define ee
  (list
    (make-poly
      '( ( 1 (#\y . 1) (#\x . 3))
         (-2 (#\x . 2)))
      nil)
    (make-poly
      '( ( 1 (#\y . 3) (#\x . 1))
         (-3 (#\y . 1) (#\x . 1)))
      nil)))
; \end{verbatim}\index{gb-ee}\bv
; (define gb-ee (groebner ee))

; (pp gb-ee)
; \end{verbatim}

; \end{alg}
 
; Stroeme
(define-syntax cons-stream                           
    (syntax-rules ()                                   
      ((_ h t) ((lambda () (cons h (delay t)))))))


(define the-empty-stream '())
(define (empty-stream? s) (null? s))
(define (head s) (car s))
(define (tail s)  (force (cdr s)))
                                                     
                                                     

(define (integers-starting-from n)
  (cons-stream n (integers-starting-from (1+ n))))

(define naturals (integers-starting-from 0))

(define (nth n s)
 (cond
  ( (empty-stream? s) '() )
  ( (= n 1) (head s) )
  ( (nth (-1+ n) (tail s)) )) )

(define (head-s n s)
 (cond
  ( (empty-stream? s) the-empty-stream )
  ( (< n 1) the-empty-stream )
  ( (cons-stream (head s) (head-s (-1+ n) (tail s))) )) )

(define (tail-s n s)
 (cond
  ( (empty-stream? s) the-empty-stream )
  ( (< n 1) s )
  ( (tail-s (-1+ n) (tail s)) )) )

 (define (for-each-s proc s)
 (cond
  ( (empty-stream? s) (newline) 'done )
  ( (proc (head s)) (for-each-s proc (tail s)) )) )

(define (write-s s)
  (define counter 1)
  (define (write1 exp)
    (write counter)
    (display "   ")
    (write exp)
    (cond ((zero? (modulo counter 3)) (newline))
          (else (display "        ")))
    (set! counter (1+ counter)))
  (for-each-s write1 s))

(define hs (head-s 100 naturals))

(define (head-pred-s pred s)
 (cond
  ( (empty-stream? s) the-empty-stream )
  ( (pred (head s)) the-empty-stream )
  ( (cons-stream (head s) (head-pred-s pred (tail s))) )) )

(define (tail-pred-s pred s)
 (cond
  ( (empty-stream? s) the-empty-stream )
  ( (pred (head s)) s )
  ( (tail-pred-s pred (tail s)) )) )

(define (memq-s el s)
 (tail-pred-s (lambda (x) (eq? x el)) s))

(define (filter pred s )
 (cond
  ( (empty-stream? s ) the-empty-stream )
  ( (pred (head s)) (cons-stream (head s) (filter pred (tail s))) )
  ( (filter pred (tail s)) )) )

(define (map-s proc s)
 (cond
  ( (empty-stream? s) the-empty-stream )
  ( (cons-stream (proc (head s)) (map-s proc (tail s))) )) )

(define (multiply-s factor s) (map-s (lambda (x) (* factor x)) s))

(define (-multiply-s factor s) (map-s (lambda (x) (* (- factor) x)) s))

(define (divide-s divisor s) (map-s (lambda (x) (/ x divisor)) s))

(define (g-multiply-s factor s) (map-s (lambda (x) (g-* factor x)) s))

(define (g-g-multiply-s factor s) 
 (map-s (lambda (x) (g-* (g-minus factor) x)) s)) 

(define (g-divide-s divisor s) (map-s (lambda (x) (g-/ x divisor)) s))

(define (g-quot-divide-s divisor s) (map-s (lambda (x) (g-// x divisor)) s))

(define (accumulate combiner initial-value s)
 (cond
  ( (empty-stream? s) initial-value )
  ( (combiner
     (head s)
     (accumulate combiner initial-value (tail s))) )) )

(define (sum-s s) (accumulate + 0 s))
(define (product-s s) (accumulate * 1 s))
(define (g-sum-s s) (accumulate g-+ 0 s))
(define (g-product-s s) (accumulate g-* 1 s))

(define (s-accumulate combiner s1 s2)
 (cond
  ( (empty-stream? s1) s2 )
  ( (empty-stream? s2) s1 )
  ( (cons-stream   
     (combiner (head s1) (head s2))
     (s-accumulate combiner (tail s1) (tail s2))) )) )

(define (add-s s1 s2) (s-accumulate + s1 s2))
(define (mult-s s1 s2) (s-accumulate * s1 s2))
(define (g-add-s s1 s2) (s-accumulate g-+ s1 s2))
(define (g-mult-s s1 s2) (s-accumulate g-* s1 s2))

(define (constant-pair-s s1 s2) (s-accumulate cons s1 s2))

(define (convolute s1 s2) (sum-s (mult-s s1 s2)))
(define (g-convolute s1 s2) (g-sum-s (g-mult-s s1 s2)))

(define (equ?-s s1 s2)
 (define (local-and x y) (and x y))
 (accumulate local-and #t (s-accumulate g-= s1 s2)))

(define (ordered-el-s-accumulate << combiner el s)
 (cond
  ( (empty-stream? s) (cons-stream el the-empty-stream) )
  ( (atom? s) (ordered-el-s-accumulate << combiner el (list s)) )
  ( (<< (head s) el) (cons-stream el s) )
  ( (<< el (head s)) 
    (cons-stream (head s) (ordered-el-s-accumulate << combiner el (tail s))) )
  ( (cons-stream (apply combiner (list el (head s))) (tail s)) )))

(define (ordered-s-accumulate << combiner s1 s2)
 (cond
  ( (empty-stream? s1) s2 )
  ( (empty-stream? s2) s1 )
  ( (let 
     (( h1 (head s1) ) ( h2 (head s2) ))
     (cond
      ( (<< h1 h2)
        (cons-stream h2 (ordered-s-accumulate << combiner s1 (tail s2))) )
      ( (<< h2 h1)
        (cons-stream h1 (ordered-s-accumulate << combiner (tail s1) s2)) )
     ( (cons-stream
        (apply combiner (list h1 h2))
        (ordered-s-accumulate << combiner (tail s1) (tail s2))) ))) )) )

(define (join-ordered-s << s1 s2)
 (ordered-s-accumulate << (lambda (x y) x) s1 s2))

(define (append-s s1 s2)
 (cond
  ( (empty-stream? s1) s2 )
  ( (cons-stream (head s1) (append-s (tail s1) s2)) )) )

(define (finite-flatten s)
 (accumulate append-s the-empty-stream s))

(define (accumulate-delayed combiner initial-value s)
 (cond
  ( (empty-stream? s) initial-value )
  ( (combiner
     (head s)
     (delay
      (accumulate-delayed combiner initial-value (tail s)))) )) )

(define (append-s-delayed s1 delayed-s2)
 (cond
  ( (empty-stream? s1) (force delayed-s2) )
  ( (cons-stream   
     (head s1) 
     (append-s-delayed (tail s1) delayed-s2)) )) )

(define (flatten s)
 (accumulate-delayed append-s-delayed the-empty-stream s))

(define (flatmap f s) (flatten (map-s f s)))
                                                     
(define (all-pairs-s s1 s2)
 (define (pairs-up-to n s1 s2)
  (append-s
   (map-s
    (lambda (y) (cons (nth n s1) y))
    (head-s n s2))
   (map-s
    (lambda (x) (cons x (nth n s2)))
    (head-s (-1+ n) s1))))
 (flatmap
  (lambda (n) (pairs-up-to n s1 s2))
  naturals))
                           




; Prime Gauss-Zahlen

(define natural-gaussians
  (map-s
    (lambda (x) (cons 'gaussian x))
    (all-pairs-s (integers-starting-from 1) naturals)))

(define (ordered-pairs-s s1 s2)
  (define (ordered-pairs-up-to n s1 s2)
    (map-s (lambda (y) (cons (nth n s1) y)) (head-s n s2)))
  (flatmap (lambda (n) (ordered-pairs-up-to n s1 s2)) naturals))

(define gaussians-of-first-octant
  (map-s 
    (lambda (x) (cons 'gaussian x))
    (ordered-pairs-s naturals naturals)))

(define (g-divides? z w) (g-zero? (g-modulo w z)))

(define (sieve-conjugate s)
 (cons-stream
  (head s)
   (sieve-conjugate
    (filter
     (lambda (x) 
      (and
       (not (g-divides? (head s) x))
       (not (g-divides? (g-conjugate (head s)) x))))
     (filter
      (lambda (x)
       (> 
        (g-square (g-deg-euclid (head s))) (g-deg-euclid x)))
      (tail s))))))

(define gauss-primes
 (sieve-conjugate (tail (tail gaussians-of-first-octant))))

(define (gs-prime? z)
 (define (iter ps)
   (cond
   ( (> (square (square (g-real-part (head ps)))) (g-deg-euclid z)) '#t )
   ( (g-divides? (head ps) z) '() )
   ( (g-divides? (g-conjugate (head ps)) z) '() )
   ( else (iter (tail ps)) )))
 (iter gs-primes))

(define gs-primes
 (cons-stream
  (make-gaussian 1 1)
  (cons-stream
   (make-gaussian 2 1)
   (filter gs-prime? (tail-s 6 gaussians-of-first-octant)) )) )

  (define (divides? z w) (zero? (modulo w z)))                                                   
                                                     
 (define (s-prime? z)
 (define (iter ps)
   (cond
   ( (divides? (head ps) z) '() )
   ( else      (iter (tail ps)) )))
 (iter s-primes))

(define s-primes
 (cons-stream
  2
  (cons-stream
   3
   (filter s-prime? (tail-s 4 naturals)) )) )