{- Springerproblem in Haskell

Problemstellung:
----------------
Ein Springer wird an eine vorgegebene Position 
auf ein Schachbrett gestellt.
Von dort aus soll er alle Felder des Bretts genau 
einmal besuchen (und nur erlaubte Züge auf dem Brett
machen).
Die mögliche Lösung wird ausgegeben (sofern existent).
Die Lösung soll rekursiv gefunden werden und mit
den zu definierenden Funktionen erstellt werden.
------------------------------------------------
Gegeben: Position auf dem Schachbrett
Gesucht: Nummerierung aller Felder für eine Tour auf dem Brett.
---------------------------------------------------------------}

import Char -- für GHC

data Board = Brd [[Int]]

type Position = (Int,Int)

showBoard :: Board -> IO ()
showBoard (Brd b) = do
           showBoardLines (reverse b) -- umdrehen für die übliche Darstellung...(Sicht von Weiß)
           putStrLn ('\t':(foldr (\x str -> x:'\t':str) "" (take (length b) ['A','B'..]))) --Schlusszeile

showBoardLines :: [[Int]] -> IO ()
showBoardLines []     = return ()
showBoardLines l@(x:xs) = do
			 putStrLn (show (length l) ++ "\t"  -- Felder mit Tab trennen
 				     ++ concat (map ((++"\t").show) x))
			 showBoardLines xs 

-- für Test einschränken! Erst ab 5 x 5 existieren Lösungen.
boardsize :: Int
boardsize = 5

empty :: Board 
empty = Brd (replicate boardsize (replicate boardsize 0))

main :: IO ()
main = do 
        (a,b) <- inputPos
        putStrLn ("Startposition: " ++ [numToChar a,' '] ++ show (1+b) ++ ".")
	case (tryPos empty 1 (a,b)) of 
		[]      -> putStrLn ("Kein Ergebnis zu Startposition " 
				       ++ [numToChar a,' '] ++ show (1+b) ++ ".")
		(brd:_) -> do
			    putStrLn "Gefundenes Ergebnis:"
			    showBoard brd
	-- man könnte auch alle Lösungen ausgeben, müsste eine rekursive "showBoards" definieren

-- Eingabe der Startposition und Konvertierung
inputPos :: IO Position
inputPos = do
	    let limits = "a-" ++ [numToChar (boardsize-1)] ++ ", 1-" ++ show (boardsize)
	    putStr ("Startposition xy (" ++ limits ++ ") eingeben: ")
	    input <- getLine
	    if (length input < 2)
	        then again
	        else let 
		       x = (toLower.head) input
		       y = (read (dropWhites (tail input))):: Int
                       pos = (charToNum x,y-1)
		     in 
                       if (not (validPos pos)) then again
		                               else return pos
     where again = do 
		    print "Falsches Eingabeformat (bitte nochmal)"
		    inputPos
	   dropWhites = dropWhile isSpace

-- Helpers:
-----------
-- Eingabekonvertierung:
charToNum :: Char -> Int
charToNum c = fromEnum c - fromEnum 'a'
numToChar :: Int -> Char
numToChar n = chr (n+97)

-- Positionen auf Gültigkeit prüfen
validPos :: Position -> Bool
validPos (a,b) = and [a>=0,a <= limit,b>=0, b<=limit]
    where limit = boardsize-1

-------------------------------------------------------------------------------

-- 1: Liste der erlaubten Züge
moves :: Position -> Board -> [Position]
moves (a,b) (Brd brd) = filter allowed [(a+n,b+m) | (n,m) <- mv ]
    where mv :: [Position]
	  -- Liste erlaubter Bewegungen
          mv = [ (1,2), (-1,2), (1,-2), (-1,-2), (2,1), (-2,1), (2,-1), (-2,-1)]
	  -- wichtig: erst Position prüfen, dann auf brd zugreifen, falls OK !
	  allowed (a,b) = validPos (a,b) && (((brd!!b)!!a)==0)

-- 2: Position markieren
markPosition :: Int -> Position -> Board -> Board
markPosition i (a,b) (Brd brd) 
      | not (validPos (a,b)) = error ("Invalid position "++ show (a,b))
      | otherwise            = Brd (st ++ [marked] ++ rst)
    where st       = take b brd     -- Anfang, Zeile 0 bis b-1
          rst      = drop (b+1) brd -- Rest hinter Zeile b
	  line     = brd!!b         -- Zeile b
          x        = take a line    -- Anfang bis Spalte a-1
	  y        = drop (a+1) line-- Rest hinter Spalte a
          marked   = x ++ [i] ++ y  -- neue Spalte

-- 3: backtracking-Algorithmus:
tryPos :: Board -> Int -> Position -> [Board]
tryPos brd i pos | i > fields             = []                                  -- zuviele Felder: Fehler
                 | nextmoves == []        = if i>=fields then [newBoard] else []-- genug markiert: fertig, sonst Abbruch
		 | isolatedFields brd     = []                                  -- Optimierung: Abbruch falls unerreichbare Felder
	         | otherwise              = concat (map continue nextmoves)     -- weitermachen mit allen nächsten Zügen
		  where nextmoves = moves pos brd         -- nächste Züge
			continue  = tryPos newBoard (i+1) -- Funktion zum Weitermachen
			newBoard  = markPosition i pos brd-- Brett zum Weitermachen
			fields    = boardsize * boardsize
--------------------------------------------------------
-- 4. (Zusatz): Suche nach isolierten Feldern auf dem Brett
isolatedFields :: Board -> Bool
isolatedFields brd = or [isolated (a,b) brd | a <- [0..boardsize-1], b <- [0..boardsize-1] ] -- alle Felder des Bretts mit "isolated" prüfen

isolated :: Position -> Board -> Bool
isolated (a,b) (Brd brd) | ((brd!!b)!!a) /= 0 = False  -- falls markiert: nicht unerreichbar
		         | otherwise          = (moves (a,b) (Brd brd)== [] ) -- sonst: Prüfung mit "moves"

-------------------------------------------------------------------------------