15

This is my first attempt at using (what I understand to be) dynamic programming. I'm trying to tackle this interesting problem: A* Admissible Heuristic for die rolling on grid

The q function attempts to recurse backwards, keeping track of the orientation of the die (visited is technically the next cell, but "visited" in terms of the recursion to prevent infinite back and forth loops). Although I'm not sure if the answer it provides is the best solution, it does seem to provide an answer, nonetheless.

I'm hoping for ideas about how to implement some kind of memoization to speed it up -- I tried unsuccessfully to implement something like memoized_fib (seen here) with lookup instead of !!, mapping q to a list of combinations of (i,j) but got Nothing, no pun intended.

Haskell code:

import Data.List (minimumBy)
import Data.Ord (comparing)

fst3 (a,b,c) = a

rollDie die@[left,right,top,bottom,front,back] move
  | move == "U" = [left,right,front,back,bottom,top]
  | move == "D" = [left,right,back,front,top,bottom]
  | move == "L" = [top,bottom,right,left,front,back]
  | move == "R" = [bottom,top,left,right,front,back]

dieTop die = die!!2

leftBorder = max 0 (min startColumn endColumn - 1)
rightBorder = min columns (max startColumn endColumn + 1)
topBorder = endRow
bottomBorder = startRow

infinity = 6*rows*columns

rows = 10
columns = 10

startRow = 1
startColumn = 1

endRow = 6
endColumn = 6

dieStartingOrientation = [4,3,1,6,2,5] --left,right,top,bottom,front,back

q i j visited 
  | i < bottomBorder || i > topBorder 
    || j < leftBorder || j > rightBorder = (infinity,[1..6],[])
  | i == startRow && j == startColumn    = (dieTop dieStartingOrientation,dieStartingOrientation,[])
  | otherwise                            = (pathCost + dieTop newDieState,newDieState,move:moves)
      where previous
              | visited == (i, j-1) = zip [q i (j+1) (i,j),q (i-1) j (i,j)] ["L","U"]
              | visited == (i, j+1) = zip [q i (j-1) (i,j),q (i-1) j (i,j)] ["R","U"]
              | otherwise           = zip [q i (j-1) (i,j),q i (j+1) (i,j),q (i-1) j (i,j)] ["R","L","U"]
            ((pathCost,dieState,moves),move) = minimumBy (comparing (fst3 . fst)) previous
            newDieState = rollDie dieState move

main = putStrLn (show $ q endRow endColumn (endRow,endColumn))
Community
  • 1
  • 1
גלעד ברקן
  • 23,602
  • 3
  • 25
  • 61
  • 1
    I think it would help if you posted your attempt that didn't work. – svick May 17 '13 at 18:15
  • I spent ages banging my head against the problem of memoising in Haskell some time ago. I can't remember details, but eventually I succeeded (I think; it may have had other problems, like space leaks) by defining an instance of an array so that the value for any given index is computed in terms of other array elements. Lazy evaluation then seemed to force all the array elements to be "populated" in the right order, which seemed a bit magical (though I was more relieved than pleased). IOW the data structure "leads", the function "follows". – j_random_hacker May 17 '13 at 18:23
  • @j_random_hacker please check out the applied dice algorithm -- 300x300 in 2.13 seconds without tables and a smaller sum than Paul's A*, cool or what? http://stackoverflow.com/questions/16547724/a-admissible-heuristic-for-die-rolling-on-grid/16629766#16629766 – גלעד ברקן May 20 '13 at 01:57

1 Answers1

15

My go-to tool for this kind of problem is the data-memocombinators library.

To use it, simply import Data.MemoCombinators, rename your q to something else such as q' (but leave the recursive calls as they are), and define a new q like this:

q = M.memo3 M.integral M.integral (M.pair M.integral M.integral) q'
  • memo3 makes a memoizer for a three argument function, given memoizers for each argument.
  • integral is a simple memoizer for integral types.
  • pair combines two memoizers to make a memoizer for pairs of those types.
  • Finally, we apply this memoizer to q' to obtain a memoized version.

And that's it. Your function is now memoized. Time to test it:

> :set +s
> q endRow endColumn (endRow,endColumn)
(35,[5,2,4,3,6,1],["R","R","R","R","R","U","U","U","U","U"])
(0.01 secs, 516984 bytes)

Full code below:

import Data.List (minimumBy)
import Data.Ord (comparing)
import qualified Data.MemoCombinators as M

fst3 (a,b,c) = a

rollDie die@[left,right,top,bottom,front,back] move
  | move == "U" = [left,right,front,back,bottom,top]
  | move == "D" = [left,right,back,front,top,bottom]
  | move == "L" = [top,bottom,right,left,front,back]
  | move == "R" = [bottom,top,left,right,front,back]

dieTop die = die!!2

leftBorder = max 0 (min startColumn endColumn - 1)
rightBorder = min columns (max startColumn endColumn + 1)
topBorder = endRow
bottomBorder = startRow

infinity = 6*rows*columns

rows = 10
columns = 10

startRow = 1
startColumn = 1

endRow = 6
endColumn = 6

dieStartingOrientation = [4,3,1,6,2,5] --left,right,top,bottom,front,back

q = M.memo3 M.integral M.integral (M.pair M.integral M.integral) q'
  where
    q' i j visited 
      | i < bottomBorder || i > topBorder || j < leftBorder || j > rightBorder = (infinity,[1..6],[])
      | i == startRow && j == startColumn    = (dieTop dieStartingOrientation,dieStartingOrientation,[])
      | otherwise                            = (pathCost + dieTop newDieState,newDieState,move:moves)
      where previous
              | visited == (i, j-1) = zip [q i (j+1) (i,j),q (i-1) j (i,j)] ["L","U"]
              | visited == (i, j+1) = zip [q i (j-1) (i,j),q (i-1) j (i,j)] ["R","U"]
              | otherwise           = zip [q i (j-1) (i,j),q i (j+1) (i,j),q (i-1) j (i,j)] ["R","L","U"]
            ((pathCost,dieState,moves),move) = minimumBy (comparing (fst3 . fst)) previous
            newDieState = rollDie dieState move

main = putStrLn (show $ q endRow endColumn (endRow,endColumn))
hammar
  • 138,522
  • 17
  • 304
  • 385