;;;;;; 8-[Neuner]-Puzzle mit A* - Algorithmus ;;; Die Felder sind als Liste gespeichert, ;;; "9" steht fuer das leere Feld. ;;; '(3 6 8 9 1 5 4 2 7) bedeutet also die folgende Position: ; =============== [3] [6] [8] ============================== ; =============== [ ] [1] [5] ============================== ; =============== [4] [2] [7] ============================== (define Ziel '(1 2 3 4 5 6 7 8 9)) (require-library "breakpoint.scm") ;;; ===== Verschieben ====================================== ;;; Jedes Element einer der Listen besteht aus (gn hn (Liste der Zahlen) 9-pos) ;;; Dabei ist gn die Zahl der fuer die Liste bereits erfolgten Verschiebungen, ;;; hn ist der Wert der Schaetzfunktion. fn ist dann die Summe beider Werte. ;;; 9-pos ist die Position des leeren Feldes (9) in der Liste. ;;; Am Schluss stehen die Vorgaengerknoten. (define (starte-Expansion L) (expandiere (list (list 0 (Bewertung L Ziel 0) L (Position-der-9 L 1))) '())) ;;; Die OPEN - Liste wird geordnet gefuehrt, beginnend bei den niedrigen fn - Zahlen (define (expandiere OPEN-Liste BESUCHT-Liste) ;(bkpt "expandiere" OPEN-Liste BESUCHT-Liste) (cond ((null? OPEN-Liste) (writeln "keine Loesung") (void)) ((equal? (caddar OPEN-Liste) Ziel) (writeln "Loesung gefunden.") (Ausgabe (cons Ziel (cddddr (car OPEN-Liste))))) (else ; Der folgende Funktionsaufruf gibt zwei Werte zurueck, die bearbeitete Liste der ; neuen Knoten und die ggf. bearbeitete OPEN-Liste (let-values (((Hilf-neu Hilf-OPEN) (entferne-besuchte-Knoten (zulaessige-Zuege (car OPEN-Liste)) BESUCHT-Liste OPEN-Liste '()))) ;(bkpt "values" Hilf-neu Hilf-OPEN) (expandiere (sortiere-ein ; Hier muessen die Elemente der BESUCHT-Liste herausgefiltert werden. ; Bleibt kein Element uebrig, muss der Knoten der CLOSE-Liste hinzugefuegt werden. ; Einfacher ist vielleicht, allein mit OPEN und BESUCHT zu arbeiten. Hilf-neu (cdr Hilf-OPEN)) (cons (caddar Hilf-OPEN) BESUCHT-Liste)))))) ;;; ===== =========================================================== (define (entferne-besuchte-Knoten neue-Knoten-Liste BESUCHT-Liste OPEN-Liste Akku) ;(bkpt "entferne-besuchte-Knoten" neue-Knoten-Liste BESUCHT-Liste OPEN-Liste Akku) (cond ((null? neue-Knoten-Liste) ; Die Funktion gibt zwei Werte zurueck, die bearbeitete Liste der ; neuen Knoten und die ggf. bearbeitete OPEN-Liste (values Akku OPEN-Liste)) ((enthalten? (caddr (car neue-Knoten-Liste)) BESUCHT-Liste) (let ((Hilfe (member (car neue-Knoten-Liste) OPEN-Liste))) (if (not (equal? Hilfe #f)) ; Der Knoten ist in der OPEN-Liste enthalten. Welcher ist besser? (if (< (caar neue-Knoten-Liste) (car Hilfe)) (entferne-besuchte-Knoten (cdr neue-Knoten-Liste) BESUCHT-Liste ; Knoten aus der OPEN-Liste muss raus, da der neue guenstiger ist. (entferne-Element (car Hilfe) OPEN-Liste) ; ist nicht definiert. Tritt es auf, muss Fehler entstehen! (cons (car neue-Knoten-Liste) Akku)) ; Knoten braucht nicht uebernommen zu werden, da der in der OPEN-Liste vorhandene guenstiger ist. (entferne-besuchte-Knoten (cdr neue-Knoten-Liste) BESUCHT-Liste OPEN-Liste Akku)) ; Der Knoten ist nicht in der OPEN-Liste enthalten. Er gehoert zu CLOSED. (entferne-besuchte-Knoten (cdr neue-Knoten-Liste) BESUCHT-Liste OPEN-Liste Akku)))) (else ; Knoten muss uebernommen werden. (entferne-besuchte-Knoten (cdr neue-Knoten-Liste) BESUCHT-Liste OPEN-Liste (cons (car neue-Knoten-Liste) Akku))))) ; ===== sortiertes Einfuegen in die OPEN-Liste ============================= (define (sortiere-ein neue-Knoten-Liste OPEN-Liste) ;(bkpt "sortiere-ein" neue-Knoten-Liste OPEN-Liste) (cond ((null? neue-Knoten-Liste) OPEN-Liste) (else (sortiere-ein (cdr neue-Knoten-Liste) (sortiere-einen-Knoten-ein (car neue-Knoten-Liste) OPEN-Liste '()))))) (define (guenstiger? K1 K2) (< (+ (car K1) (cadr K1)) (+ (car K2) (cadr K2)))) (define (sortiere-einen-Knoten-ein K L Akku) (cond ((null? L) (reverse (cons K Akku))) ((guenstiger? K (car L)) (append (reverse Akku) (cons K L))) (else (sortiere-einen-Knoten-ein K (cdr L) (cons (car L) Akku))))) ;(sortiere-einen-Knoten-ein '(3 4) '((1 2) (5 6) (7 8)) '()) ;;; ===== Ermittlung der zulaessigen Zuege ========================== ;;; Eine Expansion darf nur zulaessige Zuege liefern. Befindet sich die Luecke [9] ;;; z.B. am oberen Rand darf sie nicht nach oben verschoben werden. ;;; Knoten, die schon in der BESUCHT-Liste enthalten sind muessen aber noch weiter ;;; geprueft werden, da unklar ist, ob nicht ein Weg mit einer geringeren Zahl von ;;; bisherigen Schritten (gn) wegen auf dem anderen Weg auftretenden bisher geringeren ;;; Restkostenschaetzungen (hn) besser waere. (define (zulaessige-Zuege K) ; K ist die komplette Knotenliste des Knotens ;(bkpt "in zulaessige-Zuege: " K) (let ((gn (car K)) (L (caddr K)) (wo (cadddr K)) (Vorgaenger-Listen-Liste (cddddr K))) (append (if (> wo 3) ; von oben ist moeglich (let ((neu-oben (von-oben wo L))) (list (append (list (add1 gn) (Bewertung neu-oben Ziel 0) neu-oben (Position-der-9 neu-oben 1) L) Vorgaenger-Listen-Liste))) '()) (if (< wo 7) ; von unten ist moeglich (let ((neu-unten (von-unten wo L))) (list (append (list (add1 gn) (Bewertung neu-unten Ziel 0) neu-unten (Position-der-9 neu-unten 1) L) Vorgaenger-Listen-Liste))) '()) (if (not (= (remainder wo 3) 1)) ; von links ist moeglich (let ((neu-links (von-links wo L))) (list (append (list (add1 gn) (Bewertung neu-links Ziel 0) neu-links (Position-der-9 neu-links 1) L) Vorgaenger-Listen-Liste))) '()) (if (not (= (remainder wo 3) 0)) ; von rechts ist moeglich (let ((neu-rechts (von-rechts wo L))) (list (append (list (add1 gn) (Bewertung neu-rechts Ziel 0) neu-rechts (Position-der-9 neu-rechts 1) L) Vorgaenger-Listen-Liste))) '())))) ;;; Nun sind die neuen Knoten bekannt. (define (von-oben wohin L) (tausche (- wohin 3) wohin L)) (define (von-unten wohin L) (tausche (+ wohin 3) wohin L)) (define (von-links wohin L) (tausche (sub1 wohin) wohin L)) (define (von-rechts wohin L) (tausche (add1 wohin) wohin L)) (define (Position-der-9 L Akku) (cond ((null? L) (writeln "Liste enthaelt keine 9") 0) ((= (car L) 9) Akku) (else (Position-der-9 (cdr L) (add1 Akku))))) ;;; ===== Bewertung ========================================= ;;; Die Bewertungsfunktion berechnet die Summen aller Felddifferenzen ;;; zur gegebenen Position [Manhattan - Distanz]. (define (Bewertung aktuell Ziel Akku) (cond ((null? Ziel) Akku) (else (Bewertung (cdr aktuell) (cdr Ziel) (+ Akku (let ((SpA (remainder (sub1 (car aktuell)) 3)) (SpZ (remainder (sub1 (car Ziel)) 3)) (ZeA (quotient (car aktuell) 3)) (ZeZ (quotient (car Ziel) 3))) (+ (abs (- SpA SpZ)) (abs (- ZeA ZeZ))))))))) ;;; ===== allgemeine Listenoperationen ================================== (define (enthalten? Element L) (not (equal? (member Element L) #f))) (define (Zufallsliste Anfangsliste) (let loop ((L Anfangsliste) (Auswahl (add1 (random (length Anfangsliste))))) (cond ((null? (cdr L)) L) (else (cons (list-ref L (sub1 Auswahl)) (loop (entferne Auswahl L) (add1 (random (length (cdr L)))))))))) (define (entferne n-tes aus-Liste) (cond ((null? aus-Liste) (writeln "Zahl " n-tes " zu gross !") aus-Liste) ((< n-tes 1) (writeln "Zahl " n-tes " zu klein !") aus-Liste) ((= n-tes 1) (cdr aus-Liste)) (else (cons (car aus-Liste) (entferne (sub1 n-tes) (cdr aus-Liste)))))) (define (tausche m n Liste) ; Tauscht die Positionen m und n einer Liste (cond ((= m n) Liste) ((or (< m 1) (< n 1) (> m (length Liste)) (> n (length Liste))) (writeln "Positionen unzulaessig !")) (else (let loop ((L Liste) (mm (min m n)) (nn (max m n)) (m-tes '()) (Anfang '()) (Mitte '())) (cond ((> mm 1) ; vor dem ersten (loop (cdr L) (sub1 mm) (sub1 nn) m-tes (cons (car L) Anfang) Mitte)) ((= mm 1) ; erstes zu tauschendes gefunden! (loop (cdr L) (sub1 mm) (sub1 nn) (car L) Anfang Mitte)) ((= nn 1) ; zweites gefunden. Listen neu verbinden ! (append (reverse Anfang) (cons (car L) (reverse Mitte)) (cons m-tes (cdr L)))) (else ; dazwischen (loop (cdr L) (sub1 mm) (sub1 nn) m-tes Anfang (cons (car L) Mitte)))))))) ;;; ===== Ausgabe =========================================== ; Gibt die Lösung als Puzzle oder als Liste aus (define (Ausgabe Liste) (writeln "als Puzzle anzeigen : [p]") (writeln "als Liste zurueckgeben : [l]") (let loop ((ch (read-line))) (cond ((equal? ch "")(loop (read-line))) ((char=? (char-upcase (string-ref ch 0)) #\L) (reverse Liste)) ((char=? (char-upcase (string-ref ch 0)) #\P) (let loop-2 ((Liste (reverse Liste))) (cond ((null? Liste) (void)) (else (Ausgabe-Puzzle (car Liste)) (loop-2 (cdr Liste)))))) (else (loop (read-line)))))) ;;; ===== Ausgabe-Puzzle ==================================== (define (Ausgabe-Puzzle Liste) (cond ((null? Liste) (writeln)) (else (display (if (= (car Liste) 9) " "(car Liste))) (display " ") (display (if (= (cadr Liste) 9) " "(cadr Liste))) (display " ") (writeln (if (= (caddr Liste) 9) " "(caddr Liste))) (Ausgabe-Puzzle (cdddr Liste))))) ![]()