Disclaimer: Dieser Thread wurde aus dem alten Forum importiert. Daher werden eventuell nicht alle Formatierungen richtig angezeigt. Der ursprüngliche Thread beginnt im zweiten Post dieses Threads.
Aufgabe 69 (und 68)
Hier kommt meine Löusung für die Programmierung des Gauss-Verfahrens in Scheme:
(define disp
(lambda args
(for-each (lambda x (display (car x)) (newline)) args)))
(define (assq key records)
(cond ((null? records) '())
((eq? key (caar records)) (car records))
(else (assq key (cdr records)))))
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-1 key-2)
(let ((subtable (assq key-1 (cdr local-table))))
(if (null? subtable)
'()
(let ((record
(assq key-2 (cdr subtable))))
(if (null? record)
'()
(cdr record))))))
(define (insert! key-1 key-2 value)
(let ((subtable (assq key-1 (cdr local-table))))
(if (null? subtable)
(set-cdr! local-table (cons (list key-1 (cons key-2 value)) (cdr local-table)))
(let ((record (assq key-2 (cdr subtable))))
(if (null? record)
(set-cdr! subtable (cons (cons key-2 value) (cdr subtable)))
(set-cdr! record value)))))
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else
(error "Unknown op. -- TABLE" m))))
dispatch))
(define matrix-table (make-table))
(define get (matrix-table 'lookup-proc))
(define put (matrix-table 'insert-proc!))
(define m2 (make-table))
(define put2 (m2 'insert-proc!))
(define get2 (m2 'lookup-proc))
(define (gauss vector . matrix)
(let ((n (sqrt (length matrix)))
(ii 1)
(jj 1)
(r 1))
(define (draw-matrix i j)
(if (<= i n)
(if (<= j n) (begin (display (get i j)) (display " ") (draw-matrix i (+ j 1)))
(begin (display "| ") (display (get i j)) (newline) (draw-matrix (+ i 1) 1)))))
(define (rewrite)
(define (help i j)
(if (<= i n)
(if (<= j n) (begin (put i j (get2 i j)) (help i (+ j 1)))
(begin (put i j (get2 i j)) (help (+ i 1) 1)))))
(help 1 1))
(define (write)
(define (help i j)
(if (<= i n)
(if (<= j n) (begin (put2 i j (get i j)) (help i (+ j 1)))
(begin (put2 i j (get i j)) (help (+ i 1) 1)))))
(help 1 1))
(define (list->matrix i j matrix vector)
(cond ((null? matrix) (display "."))
((and (> i n) (> j n)) (display "."))
((and (<= i n) (<= j n) (begin (put i j (car matrix)) (list->matrix i (+ j 1) (cdr matrix) vector))))
(else (list->matrix (+ i 1) 1 matrix vector)))
(cond ((not (null? vector))
(begin (put (+ (- n (length vector)) 1) (+ n 1) (car vector))
(list->matrix (+ n 1) (+ n 1) matrix (cdr vector))))
(else (display "."))))
(define (search-pivot i j)
(if (<= j n)
(if (and (> i n) (<= j n)) (search-pivot r (+ j 1))
(cond ((= (get i j) 0) (search-pivot (+ i 1) j))
(else (begin (set! ii i) (set! jj j) (transform ii jj)))))
(begin (display "Matrix ist in Basisform.")
(set! r (- r 1)))))
(define (solution i)
(if (and (= (get n n) 0) (not (= (get n (+ n 1)) 0))) (display "Das Gleichungssystem hat keine Lösung!")
(if (<= i n) (begin (display (get i (+ n 1))) (display ", ") (solution (+ i 1)))
)))
(define (transform i j)
(define (ezo1 i j)
(let ((elem (get i j)))
(if (not (= ii r))
(if (not (null? elem))
(begin (put2 r j (/ elem (get ii jj))) (put2 i j (get r j)) (ezo1 i (+ j 1)))
(begin (rewrite) (write) (set! ii r) (ezo2 (+ r 1) 1)))
(if (not (null? elem))
(begin (put2 r j (/ elem (get ii jj))) (ezo1 i (+ j 1)))
(begin (rewrite) (set! ii r) (write) (ezo2 (+ r 1) 1))))))
(define (ezo2 i j)
(let ((elem (get i j)))
(cond ((and (null? elem) (>= i n)) (ezo3 (- ii 1) 1))
((null? elem) (ezo2 (+ i 1) 1))
(else (begin (put2 i j (- elem (* (/ 1 (get ii jj)) (get i jj) (get ii j))))
(ezo2 i (+ j 1)))))))
(define (ezo3 i j)
(let ((elem (get i j)))
(cond ((and (null? elem) (= i 0)) (begin (set! r (+ r 1)) (rewrite) (write) (search-pivot r 1)))
((null? elem) (ezo3 (- i 1) 1))
(else (begin (put2 i j (- elem (* (/ 1 (get ii jj)) (get i jj) (get ii j))))
(ezo3 i (+ j 1)))))))
(write)
(ezo1 i j))
(newline)
(newline)
(newline)
(list->matrix 1 1 matrix vector)
(search-pivot 1 1)
(newline)
(draw-matrix 1 1)
(newline)
(display "Eine Lösung ist: (")
(solution 1)
(display ")")
))
(gauss '(5 6 10) 0 2 3 4 5 6 7 8 9)
(gauss '(-48.934 -11.185 57.522) 21.545 -95.510 -96.125 10.230 -91.065 7.340 51.215 12.270 86.455)
(gauss '(16 23 19) 5 6 5 7 7 9 6 8 5)
(gauss '(1 1 1) 1 1 1 1 1 1 1 1 1)
(gauss '(2 2) 1 2 0 0)
(gauss '(2 2) 1 1 0 1)
(gauss '(1 1 1 1) 0.1 0.3 0.2 0.4 0.2 0.2 0.4 0.2 0.4 0.0 0.4 0.2 0.5 0.1 0.2 0.2)
(gauss '(1) 6)
;Lösung Aufgabe 68:
(gauss '(17 17 22 24) 1/10 1/5 2/5 1/2 3/10 1/5 0 1/10 1/5 2/5 2/5 1/5 2/5 1/5 1/5 1/5)
Schoen gemacht!
Vielleicht wird’s ein wenig übersichtlicher, wenn du die Zeilen nicht bis ganz rechts ausschreibst, sondern öfters mal was auf mehrere Zeilen aufteilst? Ich mein, Scheme ist so schon nicht grade ein Prachtstück von übersichtlicher Programmiersprache…