;;;
(require-library "breakpoint.scm")
;;; Angewandt auf ein "kürzeste Wege" - Problem
;;; nach Turau - Algorithmische Graphentheorie (s.263)
; kW-Baum: Baum der kürzesten Wege in einem Graphen
; von einer Startecke aus. Hier im Graphen G ohne B.
; B: Liste der Ecken, die noch nicht in den kW-Baum eingebaut sind.
; Schätzfunktion ist wieder die Manhattan - Distanz
; Modellierung des Graphen durch Assoziationsliste:
; ((Zeilen-Nummer (Liste der Spalten-Nummern)) ... ) (der unzulässigen)
; da die zulässigen einfach zu berechnen sind.
;;; ===== globale Variable =====
(define
Hindernisse-Assoziationsliste
'((1 (2 6))
(2 (2 3 4 6))
(3 (2 6 8 9))
(4 (6 8 9))
(5 (9))
(6 (3 4 5 6))
(7 (3 7))
(8 (3 7))))
(define
Hindernisse
(let loop-1
((liste Hindernisse-Assoziationsliste)
(akku-1 '()))
(cond
((null? liste) akku-1)
(else
(loop-1
(cdr liste)
(append
akku-1
(let loop-2
((cdr-liste (cadar liste))
(akku-2 '()))
(cond
((null? cdr-liste) akku-2)
(else
(loop-2
(cdr cdr-liste)
(cons (cons (caar liste) (car cdr-liste)) akku-2)))))))))))
(define Start '(9 . 6))
(define Ziel '(1 . 4))
.
; Bildquelle. Turau (s.o.)
;;; ===== Nachfolger =====
; Bestimmt die Nachfolger des ersten Weges
; liste x liste x liste --> neue Wege - Liste
(define
(Nachfolger Wege besucht Hindernisse)
(let loop
((naechste (Nachbarfelder (caar Wege) besucht Hindernisse))
(akku (cdr Wege)))
(cond
((null? naechste) akku)
(else
(loop
(cdr naechste)
(cons (cons (car naechste) (car Wege)) akku))))))
;;; ===== Nachbarfelder =====
; Bestimmt alle zulässigen Nachbarfelder.
; Da bei diesem speziellen Problem mit uniformer Kantenbewertung (1)
; alle Nachbarfelder nächste Nachbarn darstellen, müssen nur einige
; ausgeschlossen werden.
; Paar x liste x liste --> Liste
(define
(Nachbarfelder Feld besucht Hindernisse)
(let loop
((alle
(list
(cons (sub1 (car Feld)) (cdr Feld))
(cons (car Feld) (sub1 (cdr Feld)))
(cons (add1 (car Feld)) (cdr Feld))
(cons (car Feld) (add1 (cdr Feld)))))
(akku '()))
(cond
((null? alle) akku)
((zulaessig? (car alle) besucht Hindernisse)
(loop (cdr alle) (cons (car alle) akku)))
(else
(loop (cdr alle) akku)))))
;;; ===== zulaessig? =====
; Prüft, ob ein Feld zulässig ist.
; Schon im Baum vorhandene Punkte entfallen, ebenso Hindernisse.
; Außerdem darf der Rand nicht überschritten werden.
; Paar x liste x liste --> boolean
(define
(zulaessig? Feld besucht Hindernisse)
(and
(> (car Feld) 0)
(> (cdr Feld) 0)
(< (car Feld) 11)
(< (cdr Feld) 11)
(not (member Feld besucht))
(not (member Feld Hindernisse))))
;;; ===== Distanz =====
; Berechnet die Manhattan - Distanz zweier Felder.
; Paar x Paar --> integer
(define
(Distanz Feld-1 Feld-2)
(+
(if (> (car Feld-1) (car Feld-2))
(- (car Feld-1) (car Feld-2))
(- (car Feld-2) (car Feld-1)))
(if (> (cdr Feld-1) (cdr Feld-2))
(- (cdr Feld-1) (cdr Feld-2))
(- (cdr Feld-2) (cdr Feld-1)))))
;;; ===== erstelle-besucht-Liste =====
; Erstellt aus der Wegeliste die besucht - Liste.
; liste --> liste
(define
(erstelle-besucht-Liste Wege)
(if
(null? Wege)
'()
(let loop
((Wege (cdr Wege))
(Weg (car Wege))
(akku '()))
(cond
((and (null? Wege) (null? Weg)) akku)
((null? Weg)
(loop (cdr Wege) (car Wege) akku))
((member (car Weg) akku)
(loop Wege (cdr Weg) akku))
(else
(loop Wege (cdr Weg) (cons (car Weg) akku)))))))
;;; ===== A*iter =====
; Die eigentliche Funktion.
(define
(A*iter Start Ziel)
(let loop
((besucht (erstelle-besucht-Liste '()))
(Wege (list (list Start)))
(Grenze (add1 (Distanz Start Ziel))))
(cond
((null? Wege)
(writeln "Grenze überschritten, Neustart mit " Grenze)
(loop
(list Start)
(list (list Start))
(add1 Grenze)))
((member Ziel (car Wege))
(writeln)
(writeln "Am Ziel !")
(writeln "Lösung :" (reverse (car Wege)))
(reverse (car Wege)))
((> (+ (sub1 (length (car Wege))) (Distanz (caar Wege) Ziel)) Grenze)
; Der aktuelle Weg überschreitet die Schranke
(writeln "kill that cat!" (car Wege))
(loop besucht (cdr Wege) Grenze))
(else
(loop
(erstelle-besucht-Liste Wege)
(Nachfolger Wege besucht Hindernisse)
Grenze)))))
;;; ===== Aufruf =====
(A*iter Start Ziel)
Ergebnisse:
kill that cat! ((8 . 4) (7 . 4) (7 . 5) (7 . 6) (8 . 6) (9 . 6))
kill that cat! ((7 . 5) (7 . 4) (8 . 4) (8 . 5) (8 . 6) (9 . 6))
kill that cat! ((9 . 4) (8 . 4) (8 . 5) (8 . 6) (9 . 6))
kill that cat! ((10 . 5) (9 . 5) (9 . 6))
kill that cat! ((10 . 6) (9 . 6))
kill that cat! ((9 . 7) (9 . 6))
Grenze überschritten, Neustart mit 11
kill that cat! ((9 . 4) (8 . 4) (7 . 4) (7 . 5) (7 . 6) (8 . 6) (9 . 6))
kill that cat! ((7 . 6) (7 . 5) (7 . 4) (8 . 4) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((8 . 6) (8 . 5) (8 . 4) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((10 . 3) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((10 . 3) (10 . 4) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((10 . 7) (10 . 6) (9 . 6))
kill that cat! ((10 . 7) (9 . 7) (9 . 6))
kill that cat! ((9 . 8) (9 . 7) (9 . 6))
Grenze überschritten, Neustart mit 12
kill that cat! ((9 . 4) (8 . 4) (7 . 4) (7 . 5) (7 . 6) (8 . 6) (9 . 6))
kill that cat! ((7 . 6) (7 . 5) (7 . 4) (8 . 4) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((8 . 6) (8 . 5) (8 . 4) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((10 . 3) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((10 . 3) (10 . 4) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((10 . 7) (10 . 6) (9 . 6))
kill that cat! ((10 . 7) (9 . 7) (9 . 6))
kill that cat! ((9 . 8) (9 . 7) (9 . 6))
Grenze überschritten, Neustart mit 13
kill that cat! ((9 . 3) (9 . 4) (8 . 4) (7 . 4) (7 . 5) (7 . 6) (8 . 6) (9 . 6))
kill that cat! ((10 . 4) (9 . 4) (8 . 4) (7 . 4) (7 . 5) (7 . 6) (8 . 6) (9 . 6))
kill that cat! ((8 . 6) (7 . 6) (7 . 5) (7 . 4) (8 . 4) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((4 . 1) (4 . 2) (5 . 2) (6 . 2) (7 . 2) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((3 . 5) (3 . 4) (3 . 3) (4 . 3) (4 . 2) (5 . 2) (6 . 2) (7 . 2) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((5 . 4) (4 . 4) (4 . 3) (4 . 2) (5 . 2) (6 . 2) (7 . 2) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((4 . 5) (4 . 4) (4 . 3) (4 . 2) (5 . 2) (6 . 2) (7 . 2) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((5 . 1) (5 . 2) (6 . 2) (7 . 2) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((3 . 3) (3 . 4) (4 . 4) (5 . 4) (5 . 3) (5 . 2) (6 . 2) (7 . 2) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((3 . 5) (3 . 4) (4 . 4) (5 . 4) (5 . 3) (5 . 2) (6 . 2) (7 . 2) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((4 . 3) (4 . 4) (5 . 4) (5 . 3) (5 . 2) (6 . 2) (7 . 2) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((4 . 5) (4 . 4) (5 . 4) (5 . 3) (5 . 2) (6 . 2) (7 . 2) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((5 . 5) (5 . 4) (5 . 3) (5 . 2) (6 . 2) (7 . 2) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((6 . 1) (6 . 2) (7 . 2) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((7 . 1) (7 . 2) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((8 . 1) (8 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((9 . 1) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((10 . 2) (9 . 2) (9 . 3) (9 . 4) (9 . 5) (9 . 6))
kill that cat! ((10 . 8) (10 . 7) (10 . 6) (9 . 6))
kill that cat! ((1 . 8) (1 . 7) (2 . 7) (3 . 7) (4 . 7) (5 . 7) (5 . 8) (6 . 8) (7 . 8) (8 . 8) (9 . 8) (9 . 7) (9 . 6))
kill that cat! ((2 . 8) (2 . 7) (3 . 7) (4 . 7) (5 . 7) (5 . 8) (6 . 8) (7 . 8) (8 . 8) (9 . 8) (9 . 7) (9 . 6))
Am Ziel !
Lösung : ((9 . 6) (9 . 7) (9 . 8) (8 . 8) (7 . 8) (6 . 8) (5 . 8) (5 . 7) (5 . 6) (5 . 5) (4 . 5) (3 . 5) (2 . 5) (1 . 5) (1 . 4))