My labmate pointed out to me that Facebook has some programming puzzles. I must have really been aching for Haskell again, because I decided to write up the first one, Evil Gambling Monster (Gamblor); it’s pasted below (TODO: upload the original problem somewhere for posterity). If we let A(t,x) = max possible score at time t at node x, then the recurrence relation is A(t,x) = delta score + (max over all possible previous positions px {A(t-1,px)}, or 0 if all the preceding are negative to capture the possibility of starting right at (t,x)). This one is actually fairly easy to reason about since any attempt to map out a table starting at 0,0 will take you to straight to the correct representation, which is the hardest part.

My first and only other Haskell DP is for the simple coin denomination problem, also pasted below. Haskell was fine for that, but I believe an imperative solution lends itself more naturally for Gamblor, because then we could avoid referencing ‘undefined’ cells of Nothings. Right now I’m a bit too sleepy to rewrite this in a mixed imperative/functional style (using, e.g., Scala or Python), but I’ll briefly try to explain what I mean.

The reason I believe an imperative solution is “superior” is because the data dependencies here are selective and resemble a sort of index-based permutation, and we’re trying to express this data flow with “pulling.” However, it could result in greater efficiency (and clarity) to express the propagation with “pushing,” i.e. destructively updating state (in this case, from the row earlier along the time dimension to the row later). This brought me to the realization that functional programming is “pull,” and imperative programming is “push.” This jives with my previously accepted perspectives on FP’s relative weaknesses – for instance, an imperative histogram builder is known to be more efficient because we push to a hash table instead of pulling tree map after tree map from the source data, and an imperative permutation inverter directly expresses the indices to mutate. In fact, both of these exhibit dictionary indirection in the push – perhaps that’s a more useful conclusion.

(To be sure, this is realized as a pretty small difference in the particular problem at hand – I doubt an imperative solution would be substantially better, especially in the face of a declarative style pervasive throughout the rest of the code. But use your imagination!)

Sadly, my solution is not pretty. Far from it. Again, too sleepy to care. 6.033 TA duties are teh sux.

(Update: cleaned up the code a bit and changed the output format to alternatively output just a synopsis.)

[haskell]
module Main
where

import Control.Arrow
import Data.Array
import Data.List
import Data.Maybe
import Text.Printf

— common —

seqArray a = foldr seq () $ elems a

compareBy f l r = f l `compare` f r

— gamblor, the evil gambling monster —

nx = 9
nt = 30

wins1 = [ 53,-84, 50,-73, 54, 60, 74, 22,-63,-78, 75, 72,
-46, 99,-33, 24, 6,-66, 77,-61,-60,-46,-52, 84,
91,-21,-52,-72,-39,-41]
wins2 = [ 77,-86,-25, 27,-59,-71,-13,-85, 50, 24,-63, 26,
-4,-10, 25, 62,-85,-68, 96, 92,-29,-64,-54, 18,
-79,-62, 97,-32,-35,-42]
wins3 = [ 27,-57,-28,-98, 69, 12,-70,-43, 27, 80, 80, 64,
6,-23,-45,-68,-60,-31,-36,-63,-39, 34,-27, 7,
-47, -7, 44,-50, 60,-90]
wins4 = [ 7,-12,-48, 79,-11,-78, -8, 19,-21,-81, -1,-40,
83,-95, 36,-62,-63, 76, 6, 0,-87, 67,-66,-15,
-26,-14, 78,-81, 36, 38]
wins5 = [-71,-56,-73,-20,-77, 15, 2, 14,-66, 81, 33, 33,
-59, 16, 37, 77, 53, 73, 53,-40,-26, 66,-73, 7,
-48, 1, 93,-70, 19, 30]
wins6 = [ 68, 47, 73, 94,-72, 96, 10, 30, 11, 44, 11,-56,
-23, 51, 60,-86, 29, 13, 87,-17, 73,-39,-51,-99,
68, 1, 1, 62, 30,-79]
wins7 = [ -8, -1, 68,-34, -7, 96,-37,-96, 26, 73, 47,-62,
-83,-76, 89, 77,-62, 18, -9,-75,-99,-36,-14,-50,
-36,-45, 50, 64,-83,-19]
wins8 = [ 85, 9, 79, 53, 75,-28, 49,-62,-25,-24,-89,-77,
13,-72,-54, 2,-95,-17,-80, -5, 8,-79, 59, 93,
-30,-77,-51,-79, 87,-35]
wins9 = [ 1, 72, 74,-20, 26, 49, 52,-25, 86,-72, 50, 97,
-50,-36,-74, -4, 65,-70, 78, 85, 25,-14,-93,-16,
-20,-24, 7, 28, -3, -5]

winsList =
[ wins1
, wins2
, wins3
, wins4
, wins5
, wins6
, wins7
, wins8
, wins9
]

wins = listArray ((1,1),(nx,nt)) $ concat winsList

adjList =
[ [1, 1, 0, 1, 0, 0, 0, 0, 0]
, [1, 1, 1, 0, 1, 0, 0, 0, 0]
, [0, 1, 1, 0, 0, 1, 0, 0, 0]
, [1, 0, 0, 1, 1, 0, 1, 0, 0]
, [0, 1, 0, 1, 1, 1, 0, 1, 0]
, [0, 0, 1, 0, 1, 1, 0, 0, 1]
, [0, 0, 0, 1, 0, 0, 1, 1, 0]
, [0, 0, 0, 0, 1, 0, 1, 1, 1]
, [0, 0, 0, 0, 0, 1, 0, 1, 1]
]

adj = listArray ((1,1),(nx,nx)) $ concat adjList

gamblor debugMode =
let f :: Int -> Int -> Maybe (Int, Int)
f 1 1 = Just (0, wins!(1,1))
f 1 x = Nothing
f t x =
let preds = [ (px, snd $ fromJust e) |
px <- [1..nx], adj!(px,x) == 1, let e = a!(t-1,px), isJust e ] (arbitraryPx, _) = head preds (pred, val) = maximumBy (compareBy snd) ([(arbitraryPx, 0)] ++ preds) in if null preds then Nothing else Just (pred, val + wins!(x,t)) a = listArray ((1,1),(nt,nx)) [ f t x | t <- [1..nt], x <- [1..nx] ] trace gambling (i@(t,x), Just (px,v)) = let v' = if gambling then v else 0 rest = if px == 0 then [] else trace (gambling && v/=0) ((t-1,px), a!(t-1,px)) in (i,v') : rest assocScore = snd . fromJust . snd validCells = filter (isJust . snd) $ assocs a bestAssoc = (maximumBy $ compareBy $ assocScore) validCells trail = reverse $ trace True $ bestAssoc fmt ((t,x),v) = let fmtn :: Int -> String
fmtn x =
let atx = a!(t,x)
cum = if isJust atx
then show $ snd $ fromJust atx
else “-”
in printf “%3d (%3d/%5s) ”
(x::Int)
(wins!(x,t)::Int)
cum
fmta :: Int -> String
fmta x’ = printf “%3s%13s” (if x == x’ then “^” else “”) “”
mkLine f = concat $ map f [1..nx]
in printf “%2d: ” t ++ mkLine fmtn ++ “\n” ++
printf “%2s ” “” ++ mkLine fmta ++ “\n”

fullDump = concat $ map fmt $ trail

synop =
let ((start,_),_) = last $ filter (\((t,x),v)->v==wins!(x,t)) trail
((stop,_),winnings) = last trail
n = start – 1
m = stop – start + 1
k = nt – stop
path = map (\((_,x),_) -> x) $ trail
in printf “winnings = %d, n = %d, m = %d, k = %d, path = %s”
(winnings::Int) (n::Int) (m::Int) (k::Int) (show path)

in seq (seqArray a) $
if debugMode then {-show trail-} fullDump else synop

main = putStrLn $ gamblor False

{-
result:
“winnings = 1745, n = 0, m = 30, k = 0, path = [1,4,7,4,1,1,1,1,2,2,1,1,4,1,4,5,5,5,6,9,6,5,8,5,6,5,4,7,8,5]”
-}
[/haskell]

Oh, one quick note about the following: my first attempt (Rec) ends up recursing. This is not a problem with the performance of the “DP” per se (since the subproblem results do get memoized), but rather with the laziness; it only occurs you try evaluating for n >= 9999 or something. The way around this is to unwind the schedule of thunk evaluation with seqArray, which I should add to my Haskell Commons library. Some day! Some day my libraries will see the light of that day.

[haskell]– See also the Python version.

module Main
where

import Data.Array

main = interact $ show . coinDenomOrig . read

fib :: Int -> Int
fib n =
let f i = if i >= 2 then a!(i-1) + a!(i-2) else 1
a = array (0,n) [ (i, f i) | i <- [0..n] ] in a!n coins = [1,5,10,25] coinDenomRec :: Int -> Int
coinDenomRec n =
let f i | i == 0 = 0
| otherwise = minimum [ f (i-j) + 1 | j <- coins, j <= i ] a = array (0,n) [ (i, f i) | i <- [0..n] ] in a!n coinDenomOrig :: Int -> Int
coinDenomOrig n =
let f i | i == 0 = 0
| otherwise = {-# SCC “f” #-} minimum [ a!(i-j) + 1 | j <- coins, j <= i ] a = array (0,n) [ (i, f i) | i <- [0..n] ] in a!n --seqArray a = foldr seq () [a ! k | k <- range (bounds a)] seqArray a = foldr seq () $ elems a coinDenom :: Int -> Int
coinDenom n =
let f i = {-# SCC “f” #-} minimum [ a!(i-j) + 1 | j <- coins, j <= i ] a = array (0,n) $ [ (0,0) ] ++ [ (i, f i) | i <- [1..n] ] in seqArray a `seq` a!n [/haskell]

[python]
def f(n):
coins = [1,5,10,25]
a = [0] * (n+1)
for i in xrange(1,n+1):
a[i] = min( a[i-j] + 1 for j in coins if j <= i ) return a[n] import sys print f(int(sys.stdin.read())) [/python]