zurück Ergebnisse
;;;                                          
;;; 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)))))


Ergebnisse