Sudoku
Das klassische Sudoku ist ein Rätsel, bei dem ein Quadrat aus 9 x 9 Feldern mit Ziffern von 1 bis 9 auszufüllen ist. Dabei darf jede Ziffer nur ein mal auftreten
- in jeder Zeile,
- in jeder Spalte und
- in jedem der neun 3 x 3 Unterquadrate.
Es sind so viele Ziffern vorgegeben, dass sich eine eindeutige Lösung ergibt.
Die Funktion initialize-cells füllt in jedes Element einer 9 x 9 Matrix die Liste der Ziffern (1 2 3 4 5 6 7 8 9) und gibt die Matrix als Ergebnis zurück.
(defproc initialize-cells ()
(let
((cells (make-array (list 9 9)))
(digits19 (quote (1 2 3 4 5 6 7 8 9))))
(dotimes (r 9 cells)
(dotimes (c 9)
(set-array-element cells (list r c) digits19)))))
Die Funktion remove-digit entfernt die angegebene Ziffer aus einer Liste in der Matrix. Wenn die Liste danach leer ist, wird eine Ausnahme ausgelöst.
(defproc remove-digit (cells coordinates digit)
(set-array-element cells coordinates
(aif (remove digit (get-array-element cells coordinates))
it
(throw (quote return) nil))))
Die Funktion propagate-row-and-column-constraint entfernt die angegebene Ziffer aus allen Listen für eine Zeile, außer für die angegebene Spalte und aus allen Listen für eine Spalte, außer für die angegebene Zeile.
(defproc propagate-row-and-column-constraint (cells r c digit)
(catch (quote return)
(dotimes (i 9 t)
(unless (equal? i c)
(remove-digit cells (list r i) digit))
(unless (equal? i r)
(remove-digit cells (list i c) digit)))))
Die Funktion propagate-box-constraint entfernt die angegebene Ziffer aus allen Listen eines Unterquadrats, außer für das Element in der angegebenen Zeile und Spalte.
(defproc propagate-box-constraint (cells r c digit)
(catch (quote return)
(let
((br (* 3 (floor (/ r 3))))
(bc (* 3 (floor (/ c 3)))))
(dotimes (i 3 t)
(dotimes (j 3)
(let
((k (+ i br))
(l (+ j bc)))
(unless (and (= r k) (= c l))
(remove-digit cells (list k l) digit))))))))
Die Funktion propagate-constraint wendet eine Einschränkung an. Eine Einschränkung besteht aus den Koordinaten für Zeile und Spalte und der Ziffer für das Feld. Zuerst wird die Ziffer in das Feld eingesetzt, wenn das möglich ist. Danach wird die Ziffer aus allen anderen Feldern der Zeile, der Spalte und des Unterquadrats entfernt. Wenn sich beim Anwenden der Einschränkung ein Widerspruch ergibt, ist das Resultat der Funktion nil.
(defproc propagate-constraint (cells constraint)
(let
((coordinates (first constraint))
(r (first (first constraint)))
(c (second (first constraint)))
(digit (second constraint)))
(and
(member? digit (get-array-element cells coordinates))
(set-array-element cells coordinates (list digit))
(propagate-row-and-column-constraint cells r c digit)
(propagate-box-constraint cells r c digit)
cells)))
Die Funktion propagate-constraints wendet die angegebenen Einschränkungen an. Wenn sich ein Widerspruch ergibt, ist das Resultat nil. Anderenfalls wird eine 9 x 9 Matrix zurückgegeben, die als Elemente die Listen der noch möglichen Ziffern enthält.
(defproc propagate-constraints (cells constraints)
(if (null? constraints)
cells
(and
(propagate-constraint cells (first constraints))
(propagate-constraints cells (rest constraints)))))
Die Funktion is-solution? überprüft, ob eine Lösung vorliegt. Das ist der Fall, wenn in jedem Feld noch genau eine Ziffer möglich ist und diese nicht im Widerspruch zu anderen Feldbelegungen steht.
(defproc is-solution? (cells)
(catch (quote return)
(dotimes (i 9 t)
(dotimes (j 9)
(let
((coordinates (list i j)))
(let
((digits (get-array-element cells coordinates)))
(unless (and
(single? digits)
(propagate-constraint
cells
(list coordinates (first digits))))
(throw (quote return) nil))))))))
Die Funktion has-constraint-for? prüft, ob für die angegebenen Koordinaten eine Einschränkung in der übergebenen Liste enthalten ist.
(defproc has-constraint-for? (coordinates constraints)
(find-if
(lambda (constraint)
(= coordinates (first constraint)))
constraints)))
Die Funktion find-choices liefert mögliche Belegungen für ein Feld. Es wird das Feld betrachtet, für das es die wenigsten Möglichkeiten gibt (Heuristik der maximal eingeschränkten Variablen). Die gefundenen Belegungen betreffen ein Feld, das noch nicht eingeschränkt ist.
(defproc find-choices (cells constraints)
(let
((result-length 10)
(result nil))
(dotimes (i 9 result)
(dotimes (j 9)
(let
((coordinates (list i j)))
(let
((digits (get-array-element cells coordinates)))
(let
((digits-length (list-length digits)))
(when (and
digits
(not (has-constraint-for? coordinates constraints))
(< digits-length result-length))
(setq result-length digits-length)
(setq result
(map-with
(lambda (digit) (list coordinates digit))
digits))))))))))
Die Funktion count-digits zählt, wieviele Möglichkeiten für Feldbelegungen es insgesamt in der 9 x 9 Matrix gibt.
(defproc count-digits (cells)
(let
((result 0))
(dotimes (i 9 result)
(dotimes (j 9)
(let
((coordinates (list i j)))
(setq result
(+ result (length (get-array-element cells coordinates)))))))))
Die Funktion sort-choices sortiert mögliche Belegungen für ein Feld. Belegungen, die andere Felder möglichst wenig einschränken, werden an den Anfang des Resultats sortiert (Heuristik des minimalen Konflikts).
(defproc sort-choices (cells constraints choices)
(sort
(remove nil
(map-with
(lambda (choice)
(let
((next-cells (propagate-constraint (duplicate cells) choice)))
(and
next-cells
(list
next-cells
(cons choice constraints)
(count-digits next-cells)))))
choices))
(lambda (choice1 choice2)
(> (third choice1) (third choice2)))))
Die Funktion try-choices probiert die Möglichkeiten für ein Feld aus.
(defproc try-choices (choices)
(if
(null? choices)
nil
(let
((choice (first choices)))
(aif
(solve (first choice) (second choice))
it
(try-choices (rest choices))))))
Die Methode solve löst ein Sudoku.
(defmethod solve (cells constraints)
t
(cond
((null? cells) nil)
((is-solution? cells) cells)
(t (try-choices
(sort-choices cells constraints
(find-choices cells constraints))))))
(defmethod solve (constraints)
t
(solve
(propagate-constraints (initialize-cells) constraints)
constraints))
- in jeder Zeile,
- in jeder Spalte und
- in jedem der neun 3 x 3 Unterquadrate.
Es sind so viele Ziffern vorgegeben, dass sich eine eindeutige Lösung ergibt.
Die Funktion initialize-cells füllt in jedes Element einer 9 x 9 Matrix die Liste der Ziffern (1 2 3 4 5 6 7 8 9) und gibt die Matrix als Ergebnis zurück.
(defproc initialize-cells ()
(let
((cells (make-array (list 9 9)))
(digits19 (quote (1 2 3 4 5 6 7 8 9))))
(dotimes (r 9 cells)
(dotimes (c 9)
(set-array-element cells (list r c) digits19)))))
Die Funktion remove-digit entfernt die angegebene Ziffer aus einer Liste in der Matrix. Wenn die Liste danach leer ist, wird eine Ausnahme ausgelöst.
(defproc remove-digit (cells coordinates digit)
(set-array-element cells coordinates
(aif (remove digit (get-array-element cells coordinates))
it
(throw (quote return) nil))))
Die Funktion propagate-row-and-column-constraint entfernt die angegebene Ziffer aus allen Listen für eine Zeile, außer für die angegebene Spalte und aus allen Listen für eine Spalte, außer für die angegebene Zeile.
(defproc propagate-row-and-column-constraint (cells r c digit)
(catch (quote return)
(dotimes (i 9 t)
(unless (equal? i c)
(remove-digit cells (list r i) digit))
(unless (equal? i r)
(remove-digit cells (list i c) digit)))))
Die Funktion propagate-box-constraint entfernt die angegebene Ziffer aus allen Listen eines Unterquadrats, außer für das Element in der angegebenen Zeile und Spalte.
(defproc propagate-box-constraint (cells r c digit)
(catch (quote return)
(let
((br (* 3 (floor (/ r 3))))
(bc (* 3 (floor (/ c 3)))))
(dotimes (i 3 t)
(dotimes (j 3)
(let
((k (+ i br))
(l (+ j bc)))
(unless (and (= r k) (= c l))
(remove-digit cells (list k l) digit))))))))
Die Funktion propagate-constraint wendet eine Einschränkung an. Eine Einschränkung besteht aus den Koordinaten für Zeile und Spalte und der Ziffer für das Feld. Zuerst wird die Ziffer in das Feld eingesetzt, wenn das möglich ist. Danach wird die Ziffer aus allen anderen Feldern der Zeile, der Spalte und des Unterquadrats entfernt. Wenn sich beim Anwenden der Einschränkung ein Widerspruch ergibt, ist das Resultat der Funktion nil.
(defproc propagate-constraint (cells constraint)
(let
((coordinates (first constraint))
(r (first (first constraint)))
(c (second (first constraint)))
(digit (second constraint)))
(and
(member? digit (get-array-element cells coordinates))
(set-array-element cells coordinates (list digit))
(propagate-row-and-column-constraint cells r c digit)
(propagate-box-constraint cells r c digit)
cells)))
Die Funktion propagate-constraints wendet die angegebenen Einschränkungen an. Wenn sich ein Widerspruch ergibt, ist das Resultat nil. Anderenfalls wird eine 9 x 9 Matrix zurückgegeben, die als Elemente die Listen der noch möglichen Ziffern enthält.
(defproc propagate-constraints (cells constraints)
(if (null? constraints)
cells
(and
(propagate-constraint cells (first constraints))
(propagate-constraints cells (rest constraints)))))
Die Funktion is-solution? überprüft, ob eine Lösung vorliegt. Das ist der Fall, wenn in jedem Feld noch genau eine Ziffer möglich ist und diese nicht im Widerspruch zu anderen Feldbelegungen steht.
(defproc is-solution? (cells)
(catch (quote return)
(dotimes (i 9 t)
(dotimes (j 9)
(let
((coordinates (list i j)))
(let
((digits (get-array-element cells coordinates)))
(unless (and
(single? digits)
(propagate-constraint
cells
(list coordinates (first digits))))
(throw (quote return) nil))))))))
Die Funktion has-constraint-for? prüft, ob für die angegebenen Koordinaten eine Einschränkung in der übergebenen Liste enthalten ist.
(defproc has-constraint-for? (coordinates constraints)
(find-if
(lambda (constraint)
(= coordinates (first constraint)))
constraints)))
Die Funktion find-choices liefert mögliche Belegungen für ein Feld. Es wird das Feld betrachtet, für das es die wenigsten Möglichkeiten gibt (Heuristik der maximal eingeschränkten Variablen). Die gefundenen Belegungen betreffen ein Feld, das noch nicht eingeschränkt ist.
(defproc find-choices (cells constraints)
(let
((result-length 10)
(result nil))
(dotimes (i 9 result)
(dotimes (j 9)
(let
((coordinates (list i j)))
(let
((digits (get-array-element cells coordinates)))
(let
((digits-length (list-length digits)))
(when (and
digits
(not (has-constraint-for? coordinates constraints))
(< digits-length result-length))
(setq result-length digits-length)
(setq result
(map-with
(lambda (digit) (list coordinates digit))
digits))))))))))
Die Funktion count-digits zählt, wieviele Möglichkeiten für Feldbelegungen es insgesamt in der 9 x 9 Matrix gibt.
(defproc count-digits (cells)
(let
((result 0))
(dotimes (i 9 result)
(dotimes (j 9)
(let
((coordinates (list i j)))
(setq result
(+ result (length (get-array-element cells coordinates)))))))))
Die Funktion sort-choices sortiert mögliche Belegungen für ein Feld. Belegungen, die andere Felder möglichst wenig einschränken, werden an den Anfang des Resultats sortiert (Heuristik des minimalen Konflikts).
(defproc sort-choices (cells constraints choices)
(sort
(remove nil
(map-with
(lambda (choice)
(let
((next-cells (propagate-constraint (duplicate cells) choice)))
(and
next-cells
(list
next-cells
(cons choice constraints)
(count-digits next-cells)))))
choices))
(lambda (choice1 choice2)
(> (third choice1) (third choice2)))))
Die Funktion try-choices probiert die Möglichkeiten für ein Feld aus.
(defproc try-choices (choices)
(if
(null? choices)
nil
(let
((choice (first choices)))
(aif
(solve (first choice) (second choice))
it
(try-choices (rest choices))))))
Die Methode solve löst ein Sudoku.
(defmethod solve (cells constraints)
t
(cond
((null? cells) nil)
((is-solution? cells) cells)
(t (try-choices
(sort-choices cells constraints
(find-choices cells constraints))))))
(defmethod solve (constraints)
t
(solve
(propagate-constraints (initialize-cells) constraints)
constraints))
Die unten verlinkte Datei sudoku.sheet.xml enthält die Lösungsfunktion und wendet sie auf das abgebildete Beispiel (siehe http://de.wikipedia.org/wiki/Sudoku) an. Die Datei kann mit dem Programm Calc ausgeführt werden.
sudoku.sheet.xml