russel-norvig-ai-problems/chapter4/SlidingPuzzle.hs

{-# LANGUAGE BangPatterns #-}

-- Solves the sliding puzzle problem (http://en.wikipedia.org/wiki/Sliding_puzzle)
-- using A* algorithm

module SlidingPuzzle where

import Data.Ix
import qualified Data.Array as A
import Data.Array (Array, array, (//), (!))
import Data.List
import Data.List.Split
import Data.Maybe
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.PQueue.Prio.Min as PQ
import System.Random
import System.Environment
import Control.Monad.State

-- A State with a ramdom generator
type RandomState = State StdGen

-- Generates a random element between given limits inside State monad
getRandomR :: Random a => (a, a) -> RandomState a
getRandomR limits = do
  gen <- get
  let (val, gen') = randomR limits gen
  put gen'
  return val

-- Swap the contents of two array indices i and i' in array a
swap :: Ix a => a -> a -> Array a b -> Array a b
swap i i' a = a // [(i, ai'), (i', ai)]
  where
    !ai' = a ! i'
    !ai = a ! i

-- Cost of a move
type Cost = Int

-- A state in the game
class Ord a => GameState a where
  succs ::  a -> [(a, Cost)]

-- A* algorithm: Find a path from initial state to goal state using heuristic
-- Returns Nothing if no path found. Else returns Just (path cost, path).
astar :: GameState a => a ->  a -> (a ->  a -> Cost) -> Maybe (Cost, [a])
astar initState goalState hueristic =
  astar' (PQ.singleton (hueristic initState goalState) (initState, 0)) S.empty M.empty
  where
    -- pq: open set, seen: closed set, tracks: tracks of states
    astar' pq seen tracks
      -- If goal state reached then construct the path from the tracks and state
      | state == goalState = Just (gcost, findPath tracks state)
      -- If open set is empty then search has failed. Return Nothing
      | PQ.null pq = Nothing
      -- If state has already been seen then discard it and continue
      | S.member state seen = astar' pq' seen tracks
      -- Else expand the state and continue
      | otherwise = astar' pq'' seen' tracks'
      where
        -- Find the state with min f-cost
        !(state, gcost) = snd . PQ.findMin $ pq

        -- Delete the state from open set
        !pq' = PQ.deleteMin pq

        -- Add the state to the closed set
        !seen' =  S.insert state seen

        -- Find the successors (with their g and h costs) of the state
        -- which have not been seen yet
        !successors = filter (\(s, _, _) -> not $ S.member s seen')
                     $ successorsAndCosts state gcost

        -- Insert the successors in the open set
        !pq'' = foldl' (\q (s, g, h) -> PQ.insert (g + h) (s, g) q) pq' successors

        -- Insert the tracks of the successors
        !tracks' = foldl' (\m (s, _, _) -> M.insert s state m) tracks successors

    -- Finds the successors of a given state and their costs
    successorsAndCosts state gcost =
      map (\(s,g) -> (s, gcost + g, hueristic s goalState)) . succs $ state

    -- Constructs the path from the tracks and last state
    findPath tracks state =
      if M.member state tracks
      then findPath tracks (fromJust . M.lookup state $ tracks) ++ [state]
      else [state]

-- A point in 2d
type Point = (Int, Int)

-- A sliding puzzle
-- blank : which item is considered blank
-- blankPos : position of blank
-- pzState : the current state of the puzzle
data Puzzle a = Puzzle { blank :: !a, blankPos :: !Point, pzState :: !(Array Point a) }
              deriving (Eq, Ord)

-- Get puzzle size
puzzleSize :: Puzzle a -> Int
puzzleSize = fst . snd . A.bounds . pzState

-- Create a puzzle give the blank, the puzzle size and the puzzle state as a list,
-- left to right, top to bottom.
-- Return Just puzzle if valid, Nothing otherwise
fromList :: Ord a => a -> Int -> [a] -> Maybe (Puzzle a)
fromList b n xs =
  if (n * n /= length xs) || (b `notElem` xs)
  then Nothing
  else Just Puzzle { blank = b
                   , blankPos = let (d, r) = (fromJust . elemIndex b $ xs) `divMod` n
                                in (d + 1, r + 1)
                   , pzState = array ((1, 1), (n, n))
                               [((i, j), xs !! (n * (i - 1) + (j - 1)))
                               | i <- range (1, n), j <- range (1, n)]
                   }

-- Shows the puzzle state as a string
showPuzzleState :: Show a => Puzzle a -> String
showPuzzleState pz =
  ('\n' :) . intercalate "\n"
  . map unwords . splitEvery (puzzleSize pz)
  . map show . A.elems . pzState $ pz

-- Get the legal neighbouring positions
neighbourPos :: Int -> Point -> [Point]
neighbourPos len p@(x, y) =
  filter (\(x',y') -> and [x' >= 1, y' >= 1, x' <= len, y' <= len])
  [(x+1,y), (x-1,y), (x,y+1), (x,y-1)]

-- Get the next legal puzzle states
nextStates :: Ord a => Puzzle a -> [Puzzle a]
nextStates pz = map (\p -> Puzzle (blank pz) p (swap p blankAt (pzState pz)))
                $ neighbourPos (puzzleSize pz) blankAt
  where
    blankAt = blankPos pz

-- Make Puzzle an instance of GameState with unit step cost
instance Ord a => GameState (Puzzle a) where
  succs pz = zip (nextStates pz) (repeat 1)

-- Make Puzzle an instance of Show for pretty printing
instance Show a => Show (Puzzle a) where
  show = showPuzzleState

-- Shuffles a puzzle n times randomly to return a new (reachable) puzzle.
shufflePuzzle :: Ord a => Int -> Puzzle a -> RandomState (Puzzle a)
shufflePuzzle n pz =
  if n == 0
  then return pz
  else do
    let s = nextStates pz
    i <- getRandomR (0, length s - 1)
    shufflePuzzle (n - 1) (s !! i)

-- Calculates the number of inversions in puzzle
inversions :: Ord a => Puzzle a -> Int
inversions pz = sum . map (\l -> length . filter (\e -> e < head l) $ tail l)
                . filter ((> 1). length) . tails
                . filter (not . (== blank pz)) . A.elems . pzState $ pz

-- Calculates the puzzle pairty. The puzzle pairty is invariant under legal moves.
puzzlePairty :: Ord a => Puzzle a -> Int
puzzlePairty pz =
  if odd w
  then (w + i) `mod` 2
  else (w + i + 1 - b) `mod` 2
  where w = puzzleSize pz
        i = inversions pz
        b = fst . blankPos $ pz

-- Solves a sliding puzzle from initial state to goal state using the given heuristic.
-- Return Nothing if the goal state is not reachable from initial state
-- else returns Just (cost, path).
solvePuzzle ::  Ord a => Puzzle a -> Puzzle a
               -> (Puzzle a -> Puzzle a -> Cost) -> Maybe (Cost, [Puzzle a])
solvePuzzle initState goalState hueristic =
  if puzzlePairty initState /= puzzlePairty goalState
  then Nothing
  else astar initState goalState hueristic

-- Returns number of tiles in wrong position in given state compared to goal state
wrongTileCount :: Ord a => Puzzle a -> Puzzle a -> Cost
wrongTileCount givenState goalState =
  length . filter (uncurry (/=))
  $ zip (A.elems . pzState $ givenState) (A.elems . pzState $ goalState)

-- Calculates Manhattan distance between two points
manhattanDistance :: Point -> Point -> Int
manhattanDistance (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2)

-- Calculates the sum of Manhattan distances of tiles between positions in
-- given state and goal state
sumManhattanDistance :: Ord a => Puzzle a -> Puzzle a -> Cost
sumManhattanDistance givenState goalState =
  sum . map (\(p, t) -> manhattanDistance p (fromJust . M.lookup t $ revM))
  . A.assocs . pzState $ givenState
  where
    revM = M.fromList . map (\(x, y) -> (y, x)) . A.assocs . pzState $ goalState

-- The classic 15 puzzle (http://en.wikipedia.org/wiki/Fifteen_puzzle)

fifteenPuzzle = nPuzzle 4 50

-- seed : the seed for random generator
nPuzzle :: Int -> Int -> Int -> IO ()
nPuzzle n shuffles seed = do
  -- Random generator
  let gen = mkStdGen seed

  -- The goal
  let goalState = fromJust $ fromList 0 n [0 .. (n * n -1)]
  -- Shuffle the goal to get a random puzzle state
  let initState = evalState (shufflePuzzle shuffles goalState) gen
  -- Solve using sum manhattan distance heuristic
  let (cost, solution) = fromJust $ solvePuzzle initState goalState sumManhattanDistance

  -- Print the solution
  forM_ solution $ \s -> print s

  putStrLn ("Cost: " ++ show cost)

-- The main
main :: IO ()
main = do
  args <- fmap (map read) getArgs
  nPuzzle (args !! 0) (args !! 1) (args !! 2)