Dynamic Programming Memoization in Haskell

Question

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))

Answer 1

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))