Extremwertsuche

Aus ProgrammingWiki

Extremwertsuche nach dem Verfahren des Goldenen Schnitts

Die binäre Suche muss nicht zwingend zur Intervallhalbierung führen.
Wir betrachten die Extremwertsuche nach dem Verfahren des Goldenen Schnitts zunächst für die Suche eines lokalen Minimums:

Animation: Minimumsuche nach dem Verfahren des Goldenen Schnitts

Algorithmus (Minimumsuche): Lege ein Suchintervall durch zwei äußere Intervallgrenzen fest. Zerlege dieses Suchintervall durch einen zweimaligen Goldenen Schnitt in 3 Teilintervalle. Berechne die Funktionswerte an beiden Schnittstellen. Das neue Suchintervall wird aus der Schnittstelle mit dem größeren der beiden Funktionswerte und einer der äußeren Intervallgrenzen derart gebildet, dass die Schnittstelle mit dem kleineren Funktionswert eingeschlossen wird. Führe im neuen Suchintervall den Goldener Schnitt durch, der wieder zu 3 Teilintervallen führt. Wiederhole das Verfahren solange, bis das Suchintervall einer hinreichend kleinen ε-Umgebung genügt. Der Funktionswert eines Arguments aus dieser ε-Umgebung entspricht dem gesuchten Minimum.

Implementation

Mit dem Konzept der Prozeduren höherer Ordnung lässt sich die Minimumsuche natürlich schnell zur Suche lokaler Extrema verallgemeinern:

(define eps 1e-10) (define anz 3) (define bez "x") (define runden (lambda (x anz) (/ (round (* x (expt 10 anz))) (expt 10 anz)))) (define wertetabelle (lambda (ls) (letrec ([tabausgabe (lambda (ls) (if (not (null? ls)) (begin (display (number->string (exact->inexact (runden (caar ls) anz)))) (display #\tab) (display (number->string (exact->inexact (runden (cdar ls) anz)))) (newline) (tabausgabe (cdr ls)))))]) (display bez) (display #\tab) (display (string-append "f(" bez ")")) (newline) (tabausgabe ls)))) (define extremwertsuche (lambda (fkt xu xo dx rel) (letrec ([suche (lambda (xl li re xr) (let ([gs (/ (- (sqrt 5) 1) 2)] [x (* (+ xl xr) 0.5)]) (cond [(<= (abs (- xr xl)) eps) x] [(rel (fkt li) (fkt re)) (suche xl (- re (* gs (- re xl))) li re)] [else (suche li re (+ li (* gs (- xr li))) xr)])))]) (let* ([gs (/ (- (sqrt 5) 1) 2)] [sch (* gs dx)] [xm (suche xu (- (+ xu dx) sch) (+ xu sch) (+ xu dx))] [yl (fkt xu)][ym (fkt xm)][yr (fkt (+ xu dx))]) (cond [(>= xu xo) ()] [(and (rel ym yl) (rel ym yr) (>= (* yl yr) 0)) (cons (cons xm ym) (extremwertsuche fkt (+ xu dx) xo dx rel))] [else (extremwertsuche fkt (+ xu dx) xo dx rel)]))))) (define extremwertausgabe (lambda (fkt xu xo dx) (let ([minima (extremwertsuche fkt xu xo dx <)] [maxima (extremwertsuche fkt xu xo dx >)]) (display "Minima:") (newline) (if (null? minima) (begin (display "--> keine") (newline)) (wertetabelle minima)) (display "Maxima:") (newline) (if (null? maxima) (begin (display "--> keine") (newline)) (wertetabelle maxima)) 'ok))) (define termeingabe (lambda () (let ([proz (read (open-input-string (inputDialog "Prozedur (Lambda-Term):")))]) (with-failure-continuation (lambda (error-record error-k) #f) (lambda () (eval proz)))))) (define extremwerte (lambda (xu xo yu yo dx) (let ([fkt (termeingabe)]) (if fkt (begin (schaubild (list fkt) xu xo yu yo xu xo black '(red)) (extremwertausgabe fkt xu xo dx)) (begin (display "--> Eingabefehler!") (newline) 'ok)))))

(define nr 1) (define genau 6) (define breite 610) (define hoehe 460) (define rand 50) (define canvas (eval (string->symbol (string-append "canvas" (number->string nr))))) (define raster #f) (define sqr (lambda (x) (* x x))) (define black (lambda (canvas) (setcolor canvas 0 0 0))) (define red (lambda (canvas) (setcolor canvas 255 0 0))) (define brown (lambda (canvas) (setcolor canvas 100 50 0))) (define orange (lambda (canvas) (setcolor canvas 255 100 0))) (define yellow (lambda (canvas) (setcolor canvas 255 200 0))) (define green (lambda (canvas) (setcolor canvas 0 255 0))) (define blue (lambda (canvas) (setcolor canvas 0 0 255))) (define pink (lambda (canvas) (setcolor canvas 200 50 200))) (define n-tes-mod (lambda (ls anz) (list-ref ls (modulo anz (length ls))))) (define genaurunden (lambda (x anz) (let ([n 0] [erg 0]) (if (not (= x 0)) (set! n (inexact->exact (round (- anz (/ (log (abs x)) (log 10)) -0.5))))) (set! erg (/ (round (* x (expt 10 n))) (expt 10 n))) (if (integer? erg) (inexact->exact erg) (exact->inexact erg))))) (define groessenordnung (lambda (x) (if (= x 0) 1 (let ([pot (/ (log (abs x)) (log 10))]) (genaurunden (expt 10 (floor pot)) genau))))) (define min (lambda (x y) (if (< x y) x y))) (define max (lambda (x y) (if (> x y) x y))) (define ungleich-null (lambda (x y) (if (= x y 0) (+ y 1) y))) (define schaubild (lambda (fkt-list x1 x2 y1 y2 von bis koordcolor color-list) (clear canvas) (setwidth canvas 1) (let* ([textgroesse 9] [rand 50] [xu (exact->inexact (min x1 x2))] [xo (exact->inexact (max x1 x2))] [xo (ungleich-null xu xo)] [yu (exact->inexact (min y1 y2))] [yo (exact->inexact (max y1 y2))] [yo (ungleich-null yu yo)] [spmin rand] [spmax (- breite rand)] [spend (+ spmax 15)] [zemin (- hoehe rand)] [zemax rand] [zeend (- zemax 15)] [s00 (+ (* (/ (- xu) (- xo xu)) (- spmax spmin)) spmin)] [s0 s00] [z00 (+ (* (/ (- yu) (- yo yu)) (- zemax zemin)) zemin)] [z0 z00] [spvon (+ (* (/ (- von xu) (- xo xu)) (- spmax spmin)) spmin)] [spbis (+ (* (/ (- bis xu) (- xo xu)) (- spmax spmin)) spmin)] [mx (- xo xu)] [teilerx 1] [stepx (/ (- spmax spmin) mx teilerx)] [ex mx] [faktorx 1] [my (- yo yu)] [teilery 1] [stepy (/ (- zemin zemax) my teilery)] [ey my] [faktory 1]) (letrec ([anpassen (lambda (m) (if (> m 2) (if (<= m 20) m (anpassen (/ m 10))) (if (> m 2) m (anpassen (* m 10)))))] [teilen (lambda (m) (cond [(< m 3) 5] [(< m 10) 2] [else 1]))] [x-raster (lambda (sx zy) (if (> zy (- zemax 1)) (begin (if (and (< zy (+ zemin 1)) (> (abs (- zy z0)) 1)) (line canvas sx zy sx zy)) (x-raster sx (- zy 3)))))] [x-teilen-positiv (lambda (sx) (if (< sx (+ spmax 1)) (begin (if (and (> sx (- spmin 1)) (> (abs (- sx s0)) 1)) (begin (line canvas sx z0 sx (- z0 3)) (if raster (x-raster sx zemin)))) (x-teilen-positiv (+ sx stepx)))))] [x-teilen-negativ (lambda (sx) (if (> sx (- spmin 1)) (begin (if (and (< sx (+ spmax 1)) (> (abs (- sx s0)) 1)) (begin (line canvas sx z0 sx (- z0 3)) (if raster (x-raster sx zemin)))) (x-teilen-negativ (- sx stepx)))))] [y-raster (lambda (sx zy) (if (< sx (+ spmax 1)) (begin (if (and (> sx (- spmin 1)) (> (abs (- sx s0)) 1)) (line canvas sx zy sx zy)) (y-raster (+ sx 3) zy))))] [y-teilen-positiv (lambda (zy) (if (> zy (- zemax 1)) (begin (if (and (< zy (+ zemin 1)) (> (abs (- zy z0)) 1)) (begin (line canvas s0 zy (+ s0 3) zy) (if raster (y-raster spmin zy)))) (y-teilen-positiv (- zy stepy)))))] [y-teilen-negativ (lambda (zy) (if (< zy (+ zemin 1)) (begin (if (and (> zy (- zemax 1)) (> (abs (- zy z0)) 1)) (begin (line canvas s0 zy (+ s0 3) zy) (if raster (y-raster spmin zy)))) (y-teilen-negativ (+ zy stepy)))))] [faktor (lambda (len step) (if (<= len step) 1 (+ 1 (faktor (- len step) step))))] [textwidth (lambda (str) (* textgroesse (string-length str)))] [textout-widthcenter (lambda (sx zy str unten) (if unten (if (integer? (string->number str)) (text canvas (- sx (/ (textwidth str) 2)) (+ zy (/ textgroesse 2/3)) str textgroesse) (text canvas (- sx (/ (textwidth str) 2) (- (/ textgroesse 2))) (+ zy (/ textgroesse 2/3)) str textgroesse)) (if (integer? (string->number str)) (text canvas (- sx (/ (textwidth str) 2)) (- zy textgroesse) str textgroesse) (text canvas (- sx (/ (textwidth str) 2) (- (/ textgroesse 2))) (- zy textgroesse) str textgroesse))))] [textout-heightcenter (lambda (sx zy str links) (if links (if (integer? (string->number str)) (text canvas (- sx (textwidth str) 2) (+ zy (/ textgroesse 2)) str textgroesse) (text canvas (- sx (textwidth str) (- (/ textgroesse 2))) (+ zy (/ textgroesse 2)) str textgroesse)) (if (integer? (string->number str)) (text canvas (+ sx textgroesse) (+ zy (/ textgroesse 2)) str textgroesse) (text canvas (+ sx textgroesse) (+ zy (/ textgroesse 2)) str textgroesse))))] [textout-bez-widthcenter (lambda (sx zy str) (text canvas (- sx (/ (textwidth str) 4)) (- zy textgroesse) str textgroesse))] [textout-bez-heightcenter (lambda (sx zy str) (text canvas (+ sx (/ textgroesse 2)) (+ zy (/ textgroesse 2)) str textgroesse))] [x-bezeichnen-positiv (lambda (sx e unten) (if (< sx (+ spmax 1)) (begin (if (and (> sx (- spmin 1)) (> (abs (- sx s0)) 1)) (textout-widthcenter sx z0 (number->string (genaurunden e genau)) unten)) (x-bezeichnen-positiv (+ sx (* stepx faktorx)) (+ e (* ex faktorx)) unten))))] [x-bezeichnen-negativ (lambda (sx e unten) (if (> sx (- spmin 1)) (begin (if (and (< sx (+ spmax 1)) (> (abs (- sx s0)) 1)) (textout-widthcenter sx z0 (number->string (genaurunden e genau)) unten)) (x-bezeichnen-negativ (- sx (* stepx faktorx)) (- e (* ex faktorx)) unten))))] [y-bezeichnen-positiv (lambda (zy e links) (if (> zy (- zemax 1)) (begin (if (and (< zy (+ zemin 1)) (> (abs (- zy z0)) 1)) (textout-heightcenter s0 zy (number->string (genaurunden e genau)) links)) (y-bezeichnen-positiv (- zy (* stepy faktory)) (+ e (* ey faktory)) links))))] [y-bezeichnen-negativ (lambda (zy e links) (if (< zy (+ zemin 1)) (begin (if (and (> zy (- zemax 1)) (> (abs (- zy z0)) 1)) (textout-heightcenter s0 zy (number->string (genaurunden e genau)) links)) (y-bezeichnen-negativ (+ zy (* stepy faktory)) (- e (* ey faktory)) links))))] [x-achse-bezeichnen (lambda (str) (textout-bez-heightcenter spend z0 str))] [y-achse-bezeichnen (lambda (str) (let ([y-str (string-append "f(" str ")")]) (textout-bez-widthcenter s0 zeend y-str)))] [graph-startpkt (lambda (fkt pkt) (let ([sx (car pkt)] [zy (cdr pkt)]) (if (< sx (+ spbis 1)) (with-failure-continuation (lambda (error-record error-k) (graph-startpkt fkt (cons (+ sx 1) zy))) (lambda () (let* ([x (+ (* (/ (- sx spmin) (- spmax spmin)) (- xo xu)) xu)] [y (fkt x)]) (if (real? y) (begin (set! zy (+ (* (/ (- y yu) (- yo yu)) (- zemax zemin)) zemin)) (if (> zy zemin) (set! zy zemin)) (if (< zy zemax) (set! zy zemax)) (cons sx zy)) (graph-startpkt fkt (cons (+ sx 1) zy)))))) (cons sx zy))))] [graph-zeichnen (lambda (fkt pkt) (let ([sx (car pkt)] [zy (cdr pkt)]) (if (< sx (+ spbis 1)) (with-failure-continuation (lambda (error-record error-k) (graph-zeichnen fkt (graph-startpkt fkt (cons (+ sx 1) zy)))) (lambda () (let* ([sx-neu (+ sx 1)] [x (+ (* (/ (- sx-neu spmin) (- spmax spmin)) (- xo xu)) xu)] [y (fkt x)]) (if (real? y) (let ([zy-neu (+ (* (/ (- y yu) (- yo yu)) (- zemax zemin)) zemin)]) (if (> zy-neu zemin) (set! zy-neu zemin)) (if (< zy-neu zemax) (set! zy-neu zemax)) (if (and (< zy zemin) (> zy zemax) (< zy-neu zemin) (> zy-neu zemax)) (line canvas sx zy sx-neu zy-neu)) (graph-zeichnen fkt (cons sx-neu zy-neu))) (graph-zeichnen fkt (graph-startpkt fkt (cons (+ sx 1) zy))))))))))] [graph-list-zeichnen (lambda (fkt-ls anz color-ls) (if (not (null? fkt-ls)) (let ([fkt (eval (car fkt-ls))]) ((eval (n-tes-mod color-ls anz)) canvas) (graph-zeichnen fkt (graph-startpkt fkt (cons spvon z0))) (graph-list-zeichnen (cdr fkt-ls) (+ anz 1) color-ls))))]) (koordcolor canvas) (if (< s0 spmin) (set! s0 spmin)) (if (> s0 spmax) (set! s0 spmax)) (if (> z0 zemin) (set! z0 zemin)) (if (< z0 zemax) (set! z0 zemax)) (line canvas spmin z0 spend z0) (line canvas s0 zemin s0 zeend) (line canvas (- spend 6) (- z0 2) spend z0) (line canvas (- spend 6) (+ z0 2) spend z0) (line canvas (- spend 6) (- z0 2) (- spend 6) (+ z0 2)) (line canvas (- s0 2) (+ zeend 6) s0 zeend) (line canvas (+ s0 2) (+ zeend 6) s0 zeend) (line canvas (- s0 2) (+ zeend 6) (+ s0 2) (+ zeend 6)) (set! mx (anpassen mx)) (set! teilerx (teilen mx)) (set! stepx (/ (- spmax spmin) mx teilerx)) (set! my (anpassen my)) (set! teilery (teilen my)) (set! stepy (/ (- zemin zemax) my teilery)) (x-teilen-positiv (+ s00 stepx)) (x-teilen-negativ (- s00 stepx)) (y-teilen-positiv (- z00 stepy)) (y-teilen-negativ (+ z00 stepy)) (set! ex (/ ex mx teilerx)) (set! faktorx (faktor (* 3/2 textgroesse (string-length (number->string (genaurunden ex genau)))) stepx)) (set! ey (/ ey my teilery)) (set! faktory (faktor (* 3/2 textgroesse) stepy)) (if (<= (abs yu) (abs yo)) (begin (x-bezeichnen-positiv (+ s00 (* stepx faktorx)) (* ex faktorx) #t) (x-bezeichnen-negativ (- s00 (* stepx faktorx)) (- (* ex faktorx)) #t)) (begin (x-bezeichnen-positiv (+ s00 (* stepx faktorx)) (* ex faktorx) #f) (x-bezeichnen-negativ (- s00 (* stepx faktorx)) (- (* ex faktorx)) #f))) (if (<= (abs xu) (abs xo)) (begin (y-bezeichnen-positiv (- z00 (* stepy faktory)) (* ey faktory) #t) (y-bezeichnen-negativ (+ z00 (* stepy faktory)) (- (* ey faktory)) #t)) (begin (y-bezeichnen-positiv (- z00 (* stepy faktory)) (* ey faktory) #f) (y-bezeichnen-negativ (+ z00 (* stepy faktory)) (- (* ey faktory)) #f))) (x-achse-bezeichnen bez) (y-achse-bezeichnen bez) (if (< spvon spmin) (set! spvon spmin)) (if (> spbis spmax) (set! spbis spmax)) (graph-list-zeichnen fkt-list 0 color-list) 'ok))))

(extremwerte -10 10 -8 8 0.33)

ausführen

Zurück zur Binären Suche.