Cannot understand why this Haskell code works so fast - haskell

Question

In my attempt to learn Haskell,
i have written the following piece of code to solve a classic optimization problem.
The problem at hand is to compute the sales maximizing prices, where the price is monotonically increasing,
given a sequence of i buyers, each of which will buy at a maximup price of v_i.
In mathematical terms:
given [v_i] , find [p_i] s.t. p_{i+1} >= p_i that maximises \sum_i q(v_i,p_i)
where q(a,b)=0, if b>a, q(a,b)=b b<=a
I have implemented the following code, solving the problem using what i think is a top-down dynamic programming approach.
The algorithm decides at each step whether it will increase the price, by maximising all over the remaining sequence
maxP::Int->[Int]->(Int,Int)
maxP p [] = (0,p)
maxP p q
| a<p = (fst (maxP p (tail q)),p)
| a==p = (p+fst (maxP p (tail q)),p)
| otherwise =(maximum l,p+argmax l)
where a=head q
pc=[p..a]
l=zipWith (+) pc $ map (fst) ( map ((flip maxP) (tail q)) pc )
The code is -as expected when using Haskell- an almost 1-1 implementation of a DP algorithm.
The code returns the ( Sales Sum,Price Level)
And, in order to have all the price sequence, a function is called for all [v_i]
maxPI::Int->[Int]->[Int]->[Int]
maxPI a [] b = reverse b
maxPI a c b = maxPI q (tail c) (q:b)
where (p,q) = maxP a c
I have also implemented helper functions
argmax::[Int]->Int
argmax x = mP x (-1) 0 0
mP::[Int]->Int->Int->Int->Int
mP [] maxi pos cpos = pos
mP a maxi pos cpos
| ((head a)> maxi) = mP (tail a) (head a) cpos (cpos+1)
|otherwise = mP (tail a) maxi pos (cpos+1)
Obviously, the function could (should) be optimized, to use only one run of the algorithm over the list
But my question is that, even without the aforemention optimization, the algorithm runs surprisingly fast.
So my question is the following:
Why this algorithm works so fast?
Am i simply mis-understanding the complexity of the DP algortihm?
Does Haskell employs a by default memoization of the function maxP?
Furthermore, i dislike my Haskell-ness of my code. Could you please make any suggestions?
I was expecting a much slower performance

Answer 1

I don't know why your intuition about how fast it should be is wrong. But I'll answer the concrete questions you have that don't require me to live inside your head:
Does Haskell employs a by default memoization of the function maxP?
Haskell, the language, has no opinion on whether maxP should be memoized or not by language implementations. GHC, the most popular implementation, will not memoize maxP as it is written here.
i dislike my Haskell-ness of my code. Could you please make any suggestions?
I have a few suggestions. The most obvious one is to use pattern-matching instead of head and tail. Like this:
maxP::Int->[Int]->(Int,Int)
maxP p [] = (0,p)
maxP p (a:as)
| a<p = (fst (maxP p as),p)
| a==p = (p+fst (maxP p as),p)
| otherwise =(maximum l,p+argmax l)
where pc=[p..a]
l=zipWith (+) pc $ map (fst) ( map ((flip maxP) as) pc )
maxPI::Int->[Int]->[Int]->[Int]
maxPI a [] b = reverse b
maxPI a c#(_:ct) b = maxPI q ct (q:b)
where (p,q) = maxP a c
mP::[Int]->Int->Int->Int->Int
mP [] maxi pos cpos = pos
mP (a:as) maxi pos cpos
| (a> maxi) = mP as a cpos (cpos+1)
|otherwise = mP as maxi pos (cpos+1)
You have quite a few extraneous parentheses. Sometimes that can be useful for readability, but they're not really doing it for me in this situation.
- l=zipWith (+) pc $ map (fst) ( map ((flip maxP) as) pc )
+ l=zipWith (+) pc $ map fst (map (flip maxP as) pc)
- | (a> maxi) = mP as a cpos (cpos+1)
+ | a>maxi = mP as a cpos (cpos+1)
In maxP, you can use compare to compute all three guards at once.
maxP::Int->[Int]->(Int,Int)
maxP p [] = (0,p)
maxP p (a:as) = case compare a p of
LT -> (fst (maxP p as),p)
EQ -> (p+fst (maxP p as),p)
GT -> (maximum l,p+argmax l)
where pc=[p..a]
l=zipWith (+) pc $ map fst (map (flip maxP as) pc)
Your computation of l can be done more clearly with a single map, or via list comprehension.
- where pc=[p..a]
- l=zipWith (+) pc $ map fst (map (flip maxP as) pc)
+ where l=map (\p' -> p'+fst (maxP p' as)) [p..a] -- OR
+ where l=[p'+fst (maxP p' as) | p' <- [p..a]]
You could consider computing the index of the maximum value and the maximum value itself in the same traversal, and reuse existing library functions, like this:
GT -> (maxv,p+maxi)
where l=[p'+fst (maxP p' as) | p' <- [p..a]]
(maxv, maxi) = maximum (zip l [0..])
This argmax will return the latest maximum, unlike your solution, which returns the earliest maximum. I'm not sure whether that matters. If it does, you could use Arg to avoid using the index in the comparison or Down to use it "the other way".
You mention fst (maxP _ as) a couple times. Might be worth doing a DRY thing there.
maxP::Int->[Int]->(Int,Int)
maxP p [] = (0,p)
maxP p (a:as) = case compare a p of
LT -> (go p,p)
EQ -> (p+go p,p)
GT -> (maxv,p+maxi)
where l=[p'+go p' | p' <- [p..a]]
(maxv, maxi) = maximum (zip l [0..])
go p' = fst (maxP p' as)
Actually, reading more carefully, it occurs to me that the whole p+maxi computation you're doing is just to recover the p' value you already have in hand! So, better:
GT -> maximum [(p'+go p', p') | p' <- [p..a]]
I keep twisting myself in knots over this last bit. Is that the same as maximum [maxP p' as | p' <- [p..a]]? Anyway, at this point, it's clear now that the EQ and GT cases are actually doing the same thing. So let's merge them. We'll move back to guards now, actually, hah!
maxP::Int->[Int]->(Int,Int)
maxP p [] = (0,p)
maxP p (a:as)
| a<p = (go p,p)
| otherwise = maximum [(p'+go p', p') | p' <- [p..a]]
where go p' = fst (maxP p' as)
In maxPI, there's no real reason to build up the list backwards and reverse when you can just build it forwards to begin with.
maxPI::Int->[Int]->[Int]
maxPI a [] = []
maxPI a c#(_:ct) = q:maxPI q ct
where (p,q) = maxP a c
This can probably be done as a scan, though I'm a bit less confident of this transformation.
maxPI::Int->[Int]->[Int]
maxPI a cs = scanl (\a' cs' -> snd (maxP a' cs')) a (tails cs)
I'm not sure I love that change, but it's one to be aware of. All told, that leaves us with this code:
maxP::Int->[Int]->(Int,Int)
maxP p [] = (0,p)
maxP p (a:as)
| a<p = (go p,p)
| otherwise = maximum [(p'+go p', p') | p' <- [p..a]]
where go p' = fst (maxP p' as)
maxPI::Int->[Int]->[Int]
maxPI a cs = scanl (\a' cs' -> snd (maxP a' cs')) a (tails cs)
This feels like pretty idiomatic Haskell to me. If you want to go up from here, you need to start thinking about algorithmic changes, not style changes.
Here's what it might look like to tweak this algorithm so that it shares computations appropriately, i.e. is a dynamic programming solution. First we define a type for tracking the info we're interested in, namely, a minimal price the current solution applies for, the payout we can get assuming we always pay more than the minimum, and the actual prices we should offer to get that payout.
import Data.List
data Path = Path
{ payout :: Int
, minPrice :: Int
, prices :: [Int]
} deriving (Eq, Ord, Read, Show)
We'll name some simple operations on these table entries. The first is to extend the current table entry under the assumption that we demand the minimum price from the current customer, given the maximum price the current customer is willing to pay.
demandMin :: Int -> Path -> Path
demandMin maxPrice path = path
{ payout = payout path + if curPrice <= maxPrice then curPrice else 0
, prices = curPrice : prices path
} where
curPrice = minPrice path
The second operation expresses our preference on payouts. It takes two entries in our table and picks the one with a better payout. If we were being robust, we'd also take the smaller minimum price, but we're going to arrange that the first argument always has the smaller minimum, so we can cheat and always take that.
maxPayout :: Path -> Path -> Path
maxPayout p p' = if payout p >= payout p' then p else p' { minPrice = minPrice p }
With these operations in place, we can write our table-update operator. Each column of our table has an entry for each possible minimum price, and we will assume the incoming column has them in order of lowest minimum price to highest. Given that, we can fill in the next column to the left by, for each row, taking the better of demanding the current minimum price or whatever excellent plan the row below came up with. Like this:
maxPayouts :: Int -> [Path] -> [Path]
maxPayouts maxPrice = scanr1 maxPayout . map (demandMin maxPrice)
Now, to run the algorithm, we can just initialize our rightmost column, then iteratively fill in columns to the left, finally taking the top-left element of the table as our answer. We have to set up the assumed invariant that rows come in sorted order, but otherwise there is almost no code to write here. So:
top :: [Int] -> Path
top prices = head $ foldr maxPayouts [Path 0 price [] | price <- sort prices] prices
Try it in ghci:
> top [1,2]
Path {payout = 3, startingPrice = 1, prices = [1,2]}
> top [1,3]
Path {payout = 4, startingPrice = 1, prices = [1,3]}
> top [2,1]
Path {payout = 2, startingPrice = 1, prices = [1,1]}
> top [3,1]
Path {payout = 3, startingPrice = 1, prices = [3,3]}
> top [1,5,3]
Path {payout = 7, startingPrice = 1, prices = [1,3,3]}
> top [1,7,3]
Path {payout = 8, startingPrice = 1, prices = [1,7,7]}
(Generally you will not care about the startingPrice field, but it's easier to just return it than to make a fresh data type that doesn't have it to return.)
It scales well; for example, top [5,10..1000] returns essentially instantly for me even without compiling or optimizing. Theoretically it should scale approximately as O(n^2), with n the length of the input list, although I didn't attempt to verify this empirically.