nmpuzzle / NMPuzzle.lhs

%include polycode.fmt
%format hiding        = "\mathbf{hiding}"
%format qualified     = "\mathbf{qualified}"
%format as            = "\mathbf{as}"
%format <$>           = "\, \langle\$\rangle \,"
%format `quot`        = "\operatorname{quot}"
%format `rem`         = "\operatorname{rem}"
%format (abs (a))     = "\left|" a "\right|"

%format q0            = "q_0"
%format qt            = "q_t"
%format at            = "a_t"
%format nt            = "n_t"

%format expand        = "\delta"
%format qgoal         = "q_{goal}"
%format swapHoleDelta = "swapHole_\Delta"
%format xhole         = "x_{hole}"
%format yhole         = "y_{hole}"

%format hMisplaced    = "h_{Misplaced}"
%format hTaxicab      = "h_{Taxicab}"
%format dmoves        = "{\Delta}moves"
%format contentGoal   = "content_{goal}"
%format ix            = "i_x"
%format iqt           = "i^x_{q_t}"
%format igoal         = "i_{goal}"
%format di            = "\Delta_i"
\title{|NMPuzzle| Library}
\author{Rhys !}
\date{April 2014}

A Haskell module for generic $N{\times}M$ puzzle solving is implemented and
commented upon.


This is the |NMPuzzle| module, which defines the generic $N{\times}M$ puzzle
such that it can be solved using the |Search| module.

module NMPuzzle  (  NMPuzzle(..)
                 ,  mkPuzzle
                 ,  expand
                 ,  hMisplaced
                 ,  hTaxicab ) where

The only non-base modules we're going to use are the |Search| module and
|Data.Vector.Unboxed| from the \emph{vector} package \cite{vector}, which
supplies efficient unboxed immutable vectors for certain types.

import Prelude hiding (elemIndex, filter, length, zip)

import Control.Applicative ((<$>))
import qualified Data.List as List
import Data.Maybe (fromJust)
import Data.Vector.Unboxed  (  Vector
                            ,  (!), elemIndex
                            ,  (//), fromList
                            ,  filter, ifoldr', zip
                            ,  length )

import Search  (  FrontierApp
               ,  Path
               ,  mkNode
               ,  actions, stateAt )
% The following code is hidden from the TeX output, since it's just for testing.
%if False
import Search (mkRoot, aStar, search)
import Debug.Trace (traceShow)
import System.Random (randomRIO)

\section{Puzzle Definition}
Before doing anything specific to search, the puzzle is defined in terms of a
state and some operators on that state.

\subsection{|NMPuzzle| Data Type}
The state of an $N{\times}M$ puzzle is stored in a value of type |NMPuzzle|,
defined here.

data NMPuzzle =  NMPuzzle  {  hole :: Int
                           ,  ncols :: Int
                           ,  content :: Vector Int }
                 deriving (Eq,Show)

  \item The |Int| value of each tile in left-to-right, top-to-bottom order is
        held in the |content| vector.
  \item The index of the hole is stored in |hole|, so |content| does not need to
        be searched for each swap operation.
  \item The number of columns in the puzzle is stored in |ncols| for movement

Also, a constructor-like function is defined to easily create a |NMPuzzle| from
a list of tile values.

mkPuzzle :: Int -> [Int] -> NMPuzzle
mkPuzzle nc tiles = NMPuzzle hi nc (fromList tiles) where
  hi = fromJust (List.elemIndex 0 tiles)

All operations on an $N{\times}M$ puzzle boil down to swapping the hole with
another tile. This base operation is implemented in the |swapHole| function,
which takes a new absolute hole index and the |NMPuzzle| to operate on.
|swapHoleDelta| accepts a relative index instead.

Note the record update syntax (|{}|) and the |Vector| bulk update function |//|
do not modify values in-place but instead create a new value\footnote{Indeed,
all values are immutable in Haskell outside of the IO or ST
monads \cite{immutable}.}.

swapHole :: Int -> NMPuzzle -> NMPuzzle
swapHole to p = p { hole = to, content = current // diff } where
    diff = [(from, current!to), (to, current!from)]
    current = content p
    from = hole p

swapHoleDelta :: Int -> NMPuzzle -> NMPuzzle
swapHoleDelta di p = swapHole ((hole p) + di) p

There are four operators in the $N{\times}N$ puzzle: up, left, down and right.
Each has the condition that they cannot move the hole outside the bounds of
the puzzle; thus, the precondition for each operator is that the hole is not at
the extreme top, left, bottom or right of the puzzle respectively.

Operators with a name, precondition function and application function are
modelled in the |Operator| data type. |Operator| is polymorphic over the state
type |q|, but for the purposes of this module |q == NMPuzzle|.

data Operator q = Operator  {  name          :: String
                            ,  precondition  :: q -> Bool
                            ,  apply         :: q -> q }

We can now define the list of |operators|. Note the operators are defined in
this particular order to satisfy the problem constraint that when all else is
equal nodes must be expanded in this specific order; this works because the
search methods defined in |Search| are guaranteed to be stable.

operators =  [  Operator  {  name = "up"
                          ,  precondition = (> 0) . xhole
                          ,  apply = \p -> swapHoleDelta (-ncols p) p }
             ,  Operator  {  name = "left"
                          ,  precondition = (> 0) . yhole
                          ,  apply = swapHoleDelta (-1) }
             ,  Operator  {  name = "down"
                          ,  precondition = holeLt xhole nrows
                          ,  apply = \p -> swapHoleDelta (ncols p) p }
             ,  Operator  {  name = "right"
                          ,  precondition = holeLt yhole ncols
                          ,  apply = swapHoleDelta 1 } ]
    holeLt xy rc p = (xy p) < (rc p - 1)

\section{|expand| and Heuristics}
Now the puzzle has been defined, we can define an expansion function |expand|
and some suitable heuristic functions.

The |expand| function uses the operators defined earlier to expand nodes. The
name of each operator is stored in the action value of the |Path| node, along
with the $g(n)$ cost value. The latter value is used in A* search, and increases
by a constant $1$ for each operation performed.

expand :: Path (String, Int) NMPuzzle -> [Path (String, Int) NMPuzzle]
expand h = toPath <$> validOperators operators q where
    toPath op = mkNode h (name op, c+1) (apply op q)
    q = stateAt h
    c = case actions h of
      []        -> 0
      (_,ct):_  -> ct

Now to the $h(n)$ heuristic functions. The idea to employ both of these
heuristics comes from reading the Wikipedia page on the
15-puzzle \cite{15puzzle}.

The first heuristic is simply the number of misplaced tiles, ie. tiles not in
their goal state position. This is determined by zipping (ie. pairing) the
content of the current and goal states and keeping all non-equal pairs, then
taking the length of the resulting list.

hMisplaced :: NMPuzzle -> NMPuzzle -> Int
hMisplaced qgoal qt = length nonmatching where
  nonmatching = filter (uncurry (/=)) pairs
  pairs = zip (content qgoal) (content qt)

The second heuristic is the taxicab distance \cite{taxicab} of each tile from
its goal state position. The taxicab distance can be calculated by taking the
index difference for the tile between the current (|qt|) and goal (|qgoal|)
states and then summing the integer division and remainder of that difference
over the number of columns in the puzzle. The actual implementation is
described in terms of a right fold \cite{fold}.

hTaxicab :: NMPuzzle -> NMPuzzle -> Int
hTaxicab qgoal qt = ifoldr' dmoves 0 (content qt) where
  dmoves :: Int -> Int -> Int -> Int
  dmoves iqt x acc = acc + moves (abs (igoal x - iqt))
  igoal x = fromJust (elemIndex x contentGoal)
  moves di = (di `quot` cols) + (di `rem` cols)
  cols = ncols qgoal
  contentGoal = content qgoal

\section{Utility Definitions}
  \item Get the 0-indexed X and Y coordinates of the hole of a given puzzle.
xhole, yhole :: NMPuzzle -> Int
xhole p = hole p `quot` ncols p
yhole p = hole p `rem` ncols p

  \item The number of rows in the given puzzle.
nrows :: NMPuzzle -> Int
nrows p = (length . content) p `quot` ncols p

  \item Given a list of operators and a state |q|, return the operators whose
        precondition is fulfulled.
validOperators :: [Operator q] -> q -> [Operator q]
validOperators ops q = List.filter (flip ($) q . precondition) ops

% The following code is hidden from the TeX output, since it's just for testing.
%if False
\section{Testing Definitions}
randOps ::  Int -> [Operator q] -> Path String q ->
            IO (Path String q)
randOps 0 ops h = return h
randOps n ops h = do
  let q = stateAt h
      vops = validOperators ops q
  i <- randomRIO (1, List.length vops)
  let op = vops !! (i-1)
  randOps (n-1) ops (mkNode h (name op) (apply op q))

test :: NMPuzzle -> Int -> IO (NMPuzzle, Maybe [String])
test q0 n = do
  goal <- randOps n operators (mkRoot q0)
  let qgoal = stateAt goal
  return (stateAt goal, (fmap fst . actions) <$> snd (solution qgoal))
    solution qgoal = search (method qgoal) expand (== qgoal) q0
    method = aStar snd . hTaxicab

addTrace :: FrontierApp a q -> FrontierApp a q
addTrace m fr = traceShow (List.length fr, len fr) (m fr) where
  len [] = 0
  len fr = List.length $ actions $ List.head fr

puzzles :: [[Int]]
puzzles = [ [1,2,3,4,5,6,7,9,0,10,8,12,13,11,14]
          , [2,3,6,1,5,9,4,7,0,11,8,12,10,13,14]
          , [1,2,3,4,5,6,0,7,9,10,8,12,13,11,14]
          , [1,2,3,4,5,6,0,7,8,10,12,9,13,11,14]
          , [4,2,0,5,1,3,6,9,12,8,7,11,10,13,14]
          , [1,2,3,5,6,9,0,4,12,11,8,14,7,10,13]
          , [5,6,3,2,4,9,1,11,8,10,7,12,0,13,14] ]

main = sequence [print $ testPuzzle p | p <- puzzles] where
  testPuzzle = test . mkPuzzle 3
  test q0 = resActions $ search method expand (== ordered) q0
  resActions (nc, res) = (nc, actions <$> res)
  method = aStar snd (hTaxicab ordered)
  ordered = mkPuzzle 3 [1,2,3,4,5,6,7,8,9,10,11,12,13,14,0]


  Leshchinskiy R.,
  `vector: Efficient Arrays'

  `Functional programming',
  section `Immutable data'

  `15 puzzle',

  `Taxicab geometry'