Explore the possible paths in parallel. From the starting position, make all possible moves. Each of the resulting configurations can be reached in exactly one way. Then, from each of the resulting configurations, make all possible moves. Add the counts of the new configurations that can be reached from several of the previous configurations. Repeat that step until there is only one nonzero element in the grid. Cull impossible paths early.
For the bookkeeping which configuration can be reached in how many ways from the initial configuration, the easiest way is to use a Map. I chose to represent the grid as an (unboxed) array, since
- they are easier to handle for indexing and updating than lists of lists
- they use less space and indexing is faster
The code:
module Ways where
import qualified Data.Map.Strict as M
import Data.Array.Unboxed
import Data.List
import Data.Maybe
type Grid = UArray (Int,Int) Int
type Position = (Int,Int)
type Configuration = (Position, Grid)
type State = M.Map Configuration Integer
buildGrid :: [[Int]] -> Grid
buildGrid xss
| null xss || maxcol == 0 = error "Cannot create empty grid"
| otherwise = listArray ((1,1),(rows,maxcol)) $ pad cols xss
where
rows = length xss
cols = map length xss
maxcol = maximum cols
pad (c:cs) (r:rs) = r ++ replicate (maxcol - c) 0 ++ pad cs rs
pad _ _ = []
targets :: Position -> [Position]
targets (i,j) = [(i+d,j) | d <- [-2 .. 2], d /= 0] ++ [(i,j+d) | d <- [-2 .. 2], d /= 0]
moves :: Configuration -> [Configuration]
moves (p,g) = [(p', g') | p' <- targets p
, inRange (bounds g) p'
, g!p' > 0, let g' = g // [(p, g!p-1)]]
moveCount :: (Configuration, Integer) -> [(Configuration, Integer)]
moveCount (c,k) = [(c',k) | c' <- moves c]
step :: (Grid -> Bool) -> State -> State
step okay mp = foldl' ins M.empty . filter (okay . snd . fst) $ M.assocs mp >>= moveCount
where
ins m (c,k) = M.insertWith (+) c k m
iter :: Int -> (a -> a) -> a -> a
iter 0 _ x = x
iter k f x = let y = f x in y `seq` iter (k-1) f y
ways :: Position -> Position -> [[Int]] -> Integer
ways start end grid
| any (< 0) (concat grid) = 0
| invalid = 0
| otherwise = fromMaybe 0 $ M.lookup target finish
where
ini = buildGrid grid
bds = bounds ini
target = (end, array bds [(p, if p == end then 1 else 0) | p <- range bds])
invalid = not (inRange bds start && inRange bds end && ini!start > 0 && ini!end > 0)
okay g = g!end > 0
rounds = sum (concat grid) - 1
finish = iter rounds (step okay) (M.singleton (start,ini) 1)
