15puzzle.hs

import Data.Array
import qualified Data.Set as S
import Text.Printf

newtype Puzzle = Puzzle (Array (Int,Int) Int) deriving (Eq, Ord)
instance Show Puzzle where
    show (Puzzle arr) = unlines [concat [printf "%02d " $ arr ! (x,y) | y <- [0..3]] | x <- [0..3]]

blank = 0
win = Puzzle $ listArray ((0,0),(3,3)) $ [1..15] ++ [0]
puzzle = Puzzle $ listArray ((0,0),(3,3)) [9,7,5,4,1,2,0,8,13,6,12,14,11,3,15,10] --Put your own puzzle here

findPiece piece (Puzzle arr) = head $ filter (\pos -> arr ! pos == piece) $ indices arr
moves (Puzzle arr) = newPoss where
    (bx, by) = findPiece blank $ Puzzle arr
    neighbors = filter (`elem` indices arr) [(bx-1,by),(bx+1,by),(bx,by-1),(bx,by+1)]
    newPoss = map swapper neighbors
    swapper npos = (arr ! npos, Puzzle $ arr // [((bx,by), arr ! npos), (npos, blank)])

heuristic puz = sum $ map score [0..15] where --Sum of the mahattan metrics
    score num = let (wx,wy) = findPiece num win
                    ( x, y) = findPiece num puz
                in abs(wx-x) + abs(wy-y)

data PuzzleStore = PuzzleStore (S.Set (Int, Puzzle, [Int])) (S.Set Puzzle) deriving Show
start = PuzzleStore (S.singleton (heuristic puzzle, puzzle, [])) S.empty
step (PuzzleStore nodes visited) = (puz, history, PuzzleStore nodes'' visited') where
    Just ((h, puz, history), nodes') = S.minView nodes
    newNodes = S.fromList $ filter (\(_,p) -> p `S.notMember` visited) $ moves puz
    nodes'' = nodes' `S.union` (S.map (\(moved,p) -> (heuristic p, p, moved:history)) newNodes)
    visited' = S.insert puz visited

loop i store = do
    let (puz,history,store') = step store
    if i `mod` 1000 == 0
        then print puz --Give an update on solving every 1000 iterations
        else return ()
    if puz == win
        then print $ reverse history --Moves to make to solve the puzzle
        else loop (i+1) store'

main = loop 0 start