\documentclass[a4paper]{article}

\usepackage[latin1]{inputenc}
\usepackage[german]{babel}
\usepackage{hyperref}
\usepackage[top=2cm, left=2cm, right=2cm, bottom=2cm, a4paper]{geometry}
\usepackage[nofancy]{svninfo}
\usepackage{tikz}

\usepackage{haskell}
\lstset{firstnumber=last}

\title{Puzzle-Löser in Haskell}
\date{8.5.2006}
\author{Joachim Breitner}

\begin{document}
\svnInfo $Id: puzzle.lhs 361 2006-05-14 19:10:46Z nomeata $
\maketitle

Folgendes Puzzle wurde mir kürzlich gestellt:

\section{Aufgabenstellung}
Gegeben ist ein Spielfeld mit $5x4$ Feldern, auf dem Spielsteine wie folgt angeordnet sind:
\begin{center}
\begin{tikzpicture}
\draw (0,0) grid (5,4);
\fill[black!50,rounded corners=2mm] (.1,.1) rectangle (1.9,1.9);
\fill[black!40,rounded corners=2mm] (0.1,2.1) rectangle (0.9,3.9);
\fill[black!40,rounded corners=2mm] (1.1,2.1) rectangle (1.9,3.9);
\fill[black!40,rounded corners=2mm] (3.1,2.1) rectangle (3.9,3.9);
\fill[black!40,rounded corners=2mm] (4.1,2.1) rectangle (4.9,3.9);
\fill[black!60,rounded corners=2mm] (2.1,2.1) rectangle (2.9,2.9);
\fill[black!60,rounded corners=2mm] (2.1,3.1) rectangle (2.9,3.9);
\fill[black!80,rounded corners=2mm] (3.1,0.1) rectangle (4.9,0.9);
\fill[black!80,rounded corners=2mm] (3.1,1.1) rectangle (4.9,1.9);
\end{tikzpicture}
\end{center}
Die Felder in der Mitte unten sind leer. Diese Spielsteine sollen jetzt so verschoben werden, dass das Viereck unten links steht.

\section{Lösung in Haskell}

Da ich "`von Hand"' nicht drauf kam, wie das Problem zu lösen ist, erstellte ich folgendes Haskellprogramm. Da dies auch für andere, vor allem für Besucher meines \href{http://www.joachim-breitner.de/wiki/Info\_II\_Tutorium\_SS\_06}{Informatik-II-Tutoriums}, interessant sein könnte, dokumentiere und veröffentliche ich es hier.

Ich beginne mit dem Import einiger weniger Library-Funktionen. Dabei verstecke ich die "`\texttt{lines}"'-Funktion, da ich selbe eine solche habe.
\begin{code}
import qualified Prelude(lines)
import Prelude hiding(lines)
import Data.List hiding (lines)
import System.IO

\end{code}
% Leerzeilen am Ende, Workaround für listings-bug

In meinem Programm schiebe ich viel Puzzlezustände hin und her, also definiere ich dafür einen neuen Typ, \texttt{HWState}. Der Typ \texttt{Coord} ist nur da, um etwas Schreibarbeit zu sparen. Der Typ ist ein Record mit Feldern für die Coordinaten der Spielsteine. Da es von senkrechten, waagrechten und kleinen Steinen mehrere gibt, verwende ich hier eine Liste. Ich muss später selbst drauf achten, dass die richtige Anzahl gespeichert ist. Auch werde ich die Coordinaten stets sortiert einspeichern, darauf verlässt sich der folgende Code auch.
\begin{code}
type Coord = (Int, Int)
data HWState = HWState {
	square::Coord,
	bars::[Coord],
	lines::[Coord],
	dots::[Coord]
} deriving Eq -- Damit schenkt mir Haskell ohne Mehraufwand die (==) und (/=)-Operatoren

\end{code}

Ich werde viel mit Coordinaten rumschieben, also dazu ein paar Funktionen:
\begin{code}
rueber    (x,y) = (x+1,y)
runter    (x,y) = (x,y+1)
ruerunter (x,y) = (x+1,y+1)
hoch      (x,y) = (x,y-1)
links     (x,y) = (x-1,y)



\end{code}

Die Funktion \lstinline.doeach. wendet die Funktion auf jeweils eines der Elemnete von \lstinline-f- an und gibt eine Liste all dieser Möglichkeiten zurück.
\begin{code}
doeach f []      = []
doeach f (x:xs)  = ((f x):xs) : (map (x:) (doeach f xs))




\end{code}

Diese Funktion wird für die Funktion \lstinline-bewegeach- gebraucht. Analog zu \lstinline-beweg-, welche eine Koordinate in alle richtungen macht, macht \lstinline-bewegeach- das für alle Koordinaten in der übergebenen Liste. Das ganze brauch ich für später, wenn ich die möglichen Züge berechnen will.
\begin{code}
beweg c = [rueber c, runter c, hoch c, links c]
bewegeach l = (doeach runter l ++ doeach rueber l ++ doeach hoch l ++ doeach links l)

\end{code}

Ich will überprüfen können, ob ein Spielfeld gültig ist, sich also keine Spielsteine überlappen oder herausragen. Dazu habe ich für jede Spielsteinart eine Funktion, die die verwendeten Felder zurückgibt, sowie eine, die diese dann noch zusammenführt:
\begin{code}
usedBySquare state  = [             square state,
         	       (rueber    $ square state),
	  	       (runter    $ square state),
	  	       (ruerunter $ square state) ]

usedByLines state  = lines state ++ map rueber (lines state)
usedByBars  state  = bars  state ++ map runter (bars  state)
usedByDots  state  = dots  state

used state  = usedBySquare state  ++ usedByLines state ++ usedByBars  state ++ usedByDots state

\end{code}

Gültig ist ein Feld natürlich zum einen, wenn nichts herausragt. Das überprüfen erstmal für jede Spielsteinart die folgenden Funktionen:
\begin{code}
validSquare (HWState s _ _ _) =     (\(x,y) -> 0 <= x && x <= 3 && 0 <= y && y <= 2) s
validBars   (HWState _ b _ _) = all (\(x,y) -> 0 <= x && x <= 4 && 0 <= y && y <= 2) b
validLines  (HWState _ _ l _) = all (\(x,y) -> 0 <= x && x <= 3 && 0 <= y && y <= 3) l
validDots   (HWState _ _ _ d) = all (\(x,y) -> 0 <= x && x <= 4 && 0 <= y && y <= 3) d


\end{code}

Gültig letztendlich ist ein Feld genau dann, wenn alle Steine im Feld liegen und wenn keine Felder doppelt belegt sind. Letzeres erkenen ich daran, ob die Liste der belegten Felder noch die gleiche ist, wenn ich Doubletten mit \lstinline-nub- entferne.
\begin{code}
valid state = validSquare state &&
              validLines  state &&
	      validBars   state &&
	      validDots   state &&
	      nub used' == used'
	      where used' = used state

\end{code}

Gelöst ist das Puzzle, wenn in einem Zustand das Viereck unten rechts ist:
\begin{code}
solved state = (square state ) == (3,2)


\end{code}

Für die Pseudo-Graphische Ausgabe brauche ich Zeichenfunktionen. Die \lstinline-pixs...--Funktionen geben mir eine Liste von Tupeln zurück, die zum einen die Koordinate und zum anderen die Zeichen enthalten.
\begin{code}
pixsSquare state = [ (            square state, "##"),
                     (rueber    $ square state, "##"),
                     (runter    $ square state, "##"),
                     (ruerunter $ square state, "##") ]
pixsLines state = concatMap (\c-> [ (c,"<="), (rueber c, "=>") ] )   (lines state)
pixsBars  state = concatMap (\c-> [ (c,"/\\"), (runter c, "\\/") ] ) (bars  state)
pixsDots  state = concatMap (\c-> [ (c,"()")                   ] )   (dots  state)



\end{code}

\lstinline-draw- sorgt dafür, das auch nicht belegte Pixel -- also solche für die \lstinline-lookup Nothing- zurück gibt -- ihren Raum einnehmen.
\begin{code}
draw Nothing  = "  "
draw (Just c) = c





\end{code}

Nun kann ich Zeichnen. Dazu mach ich mein Spielfeldtyp doch gleich eine Instanz der Klasse \lstinline-Show-. Ich berechne erst in \lstinline-pixs- alle Pixel des Zustandes und suche dann der Reihe nach mit \lstinline-lookup- danach. Wenn ich nichts finde, sort \lstinline-draw- dafür, dass das kein Problem ist.
\begin{code}
instance Show HWState where
	show state = "\n" ++ concat [
	 		concat [draw $ lookup (x,y) pixs | x<-[0..4] ] ++ "\n" | y <- [0..3] ]
	             where pixs = pixsSquare state ++ pixsBars state ++
		                  pixsLines state ++ pixsDots state







\end{code}				 

Die mehrzeilige Ausgabe ist etwas interessanter. Der Paramter \lstinline-n- zählt die ausgegebenen Felder hoch. Die innere Zeile (\lstinline-unlines-\ldots) nimmt die ersten 6 auszugebenden Felder, zeichnet diese mit dem \lstinline-show- von oben und spaltet diesen String in seine Zeilen auf. Wir haben jetzt eine Liste von einer Liste von Zeilen. Mit \lstinline-transpose- sortieren wir diese um, so was wir die Zeilen jetzt nur noch mit \lstinline-unwords- und \lstinline-unlines- zusammensetzen müssen.
\begin{code}
show' _ [] = ""				 
show' n l  = let (anf, end) = splitAt 6 l
	     in unlines ["Schritt "++(show n)++"-"++( show $ n + (length anf) - 1)++":", 
	                unlines $ map (unwords) $  transpose $ map Prelude.lines $ map show anf,
	                show' (n + (length anf)) end] 

\end{code}

Zurück zum Puzzle. Ein Zug bewegt genau ein Stein. Also für jede Steinsart eine Bewegungs-Funktion:
\begin{code}
moveSquare (HWState s b l d) = map (\s -> HWState s b l d) (beweg s)
moveBars   (HWState s b l d) = map (\b -> HWState s (sort b) l d) (bewegeach b)
moveLines  (HWState s b l d) = map (\l -> HWState s b (sort l) d) (bewegeach l)
moveDots   (HWState s b l d) = map (\d -> HWState s b l (sort d)) (bewegeach d)


\end{code}

Und nun eine fürs ganze Feld. Da wir hier nun viele unsinnge Bewegungen drin haben, schmeißen wir die mit \lstinline-filter- gleich wieder raus.
\begin{code}
moves state = filter valid $
              concat [
	      moveSquare state,
	      moveLines  state,
	      moveBars   state,
	      moveDots   state ]

\end{code}	      

Nicht zu vergessen: Die Startkonfiguration:
\begin{code}
start = HWState (0,2)
		(sort [ (0,0),  (1,0),  (3,0), (4,0)])
		(sort [ (3,2),  (3,3)])
		(sort [ (2,0),  (2,1)])








\end{code}		

Die folgende Funktion implementiert Breitensuche im Graphen, und terminiert wenn es eine Lösung gibt. Sie ist voll parametrisiert, benutzt also nichts vom Code weiter oben, und kann auch für viele andere Probleme verwendet werden. Dabei verrichtet die rekursive \lstinline-seen'--Funktion die Hauptarbeit: Der erste Parameter ist eine Liste von momentan untersuchten Wegen, also Listen von "`benachbarten"' Zuständen mit dem Startzustand am Ende. Der zweite Parameter ist zur Optimierung und ist eine Liste aller bereits passierten Zustände.

Falls einer der übergebenen Wege in einem Zielzustand endet, findet \lstinline-find- diesen und wir sind fertig. Ansonsten folgen wir mit \lstinline-next'- jeder Möglichkeit, noch einen Zug zu machen, und erhalten eine neue Liste von Wegen. Diese verkleinern wir jetzt, in dem wir alle Wege rausschmeißen, die an einem bereits gesehenen Weg enden (die \lstinline-filter--Zeile). Auch sorgen wir mit \lstinline-nubBy- dafür, dass nur Wege in der Liste bleiben, die in verschiedene Zustände enden. Diese Liste wird nun zusammen mit einer aktualisierten Liste passierter Zustände wiederrum an \lstinline-seen'- gefüttert.

Das \lstinline-reverse- sorgt dafür, dass der Startknoten am Anfang und das Ergebnis am Ende des Lösungsweges stehen.
\begin{code}
graphSolve start next check = reverse $ solve' [[start]] []
	where solve' l seen = case find (check.head) l of
		 Just way -> way
		 Nothing  -> solve' l' seen'
		             where seen' = (map head l) ++ seen
			           l'    = nubBy sameHead $
				           filter (\w -> (head w) `notElem` seen') $
					   concatMap next' l
	      next' (s:l) = map (:s:l) $ next s
              sameHead l1 l2 = head l1 == head l2


\end{code}	      

Das wars auch schon, wir müssen nur noch \lstinline-graphSolve- auf unsere Startkonfiguration los lassen und ihr dabei die passenden Parameter übergeben, und können die zurückgegebene Liste dann direkt ausgeben.
\begin{code}
main = hPutStr stdout $ show' 1 $ graphSolve start moves solved

\end{code}

\section{Finito}

Natürlich bin ich über Fehlerberichte, Ergänzungen, Verbesserungen, Kommentare und Lob jederzeit empfangsbereit, am besten per e-Mail an \href{mailto:mail@joachim-breitner.de}{\nolinkurl{mail@joachim-breitner.de}}. \copyright 2006 Joachim Breitner.

\begin{flushright}
\tiny Letze Änderung: \svnInfoLongDate{} \svnInfoTime
\end{flushright}
\end{document}