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

I think it would help if you posted your attempt that didn't work. — svick
– svick, Commented May 17, 2013 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
– j_random_hacker, Commented May 17, 2013 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? stackoverflow.com/questions/16547724/… — גלעד ברקן
– גלעד ברקן, Commented May 20, 2013 at 1:57

hammar · Accepted Answer · 2013-05-17 18:30:33Z

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

Thanks! I did experiment with this package but did not know how to interpret my q function type for this purpose.

Collectives™ on Stack Overflow

Dynamic Programming Memoization in Haskell

1 Answer 1

1 Comment

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

1 Comment

Your Answer

Sign up or log in

Post as a guest

Linked

Related