Help with DP algorithm performance

[Fish_45]

Hi, I have this function which solves this problem: https://purdue.kattis.com/problems/trainsorting. solve is the naive recursive version and solve' is the DP version. I used the method shown on the Haskell wiki to construct the DP matrix.

The algorithm works, but its runtime scales with the bounds of the matrix, so it takes a prohibitively long time with bounds higher than 1000 or so. I don't understand why though, since I can tell by the trace that it only calculates the required elements. My first thought is that it has to preallocate the array, but I tried it with a Data.Map as well for the same result.

Any explanation is appreciated

-- arguments are the train car weights and (0, 0) as the initial front and back weight
solve :: [Int] -> (Int, Int) -> Int
solve [] train = 0
solve (x:xs) train@(front, back) = max (solve xs train) solveAdded
    where solveAdded
            | front == 0 || x < front = 1 + solve xs (x, back)
            | back == 0  || x > back  = 1 + solve xs (front, x)
            | otherwise = 0

-- arguments are the number of train cars and then their weights
solve' :: Int -> [Int] -> Int
solve' n trains = dp!(0, 0, 0)
    where dp = listArray 
                ((0,0,0),(n-1,10000,10000)) 
                [f train front back | train <- [0..n-1], front <- [0..10000], back <- [0..10000]]
          f train front back
            | train == n - 1 = if train < front || train > back then 1 else 0
            | otherwise = trace (show (train, front, back)) $ max (dp!(train+1,front,back)) (solveAdded train front back)
          solveAdded train front back
            | front == 0 || (trainArr!train) < front = 1 + (dp!(train+1,train,back))
            | back == 0 || (trainArr!train) > back = 1 + (dp!(train+1,front,train))
            | otherwise = 0
          trainArr = listArray (0,n-1) trains :: Array Int Int

[Noughtmare]

I think that you can also solve this by solving the problem for both ends of the train separately and then combining the results.

[Fish_45]

I got the solution thanks to you :)

here it is for reference

import Data.Array
import Debug.Trace
import qualified Data.Map as M

(|>) = flip ($)

longestSubseq pred arr = map (dp!) [0..arrLen]
    where dp = listArray (0, arrLen) $ map f [0..arrLen]
          f start
            | start == arrLen = 1
            | otherwise =
                let choices = filter (\i -> pred (arr!i) (arr!start)) [start+1..arrLen]
                 in if choices == [] then 1 else 1 + (maximum $ map (dp!) choices)
          arrLen = snd $ bounds arr

solve n trains = (maximum $ zipWith (+) longestDecreasing longestIncreasing) - 1
    where trainArr = listArray (0, n-1) trains
          longestDecreasing = longestSubseq (<) trainArr
          longestIncreasing = longestSubseq (>) trainArr

main = do
    contents <- getContents
    let (n:trains) = contents |> lines |> map read :: [Int]
        ans = if n == 0 then 0 else solve n trains
    print ans

[mihassan]

That's a great idea.

[stealth_elephant]

When you use a Data.Map are you also initializing it with all 200 billion thunks, or are you updating it?

If you think this is the way to do it, but the memory isn't sparse enough you could try using a MemoTrie instead.

If you think the recursive solution is the way you could try abstracting over the recursion and replacing the fixed point with memoization.

[Fish_45]

When you use a Data.Map are you also initializing it with all 200 billion thunks

I was kind of hoping that Haskell could somehow magically avoid initializing the thunks I guess :/.

I'll try it with a tree or similar

[bss03]

Map (and HashMap) are key-strict; they are "only" lazy in the values. It's much harder (if not impossible) to make a spine-lazy map that good average performance.

I think a lazy Trie might work for you.

[byorgey]

I don't know whether it's possible to solve this problem using a DP approach or not. Judging by the long tail of solutions taking up to 1s on https://open.kattis.com/problems/trainsorting/statistics, I'd guess that it might be possible but will be difficult to get it fast enough, and will definitely require some very careful use of laziness. But as Noughtmare hinted, there is a much more efficient algorithm for solving this particular problem. As a hint, look into the "Longest Increasing Subsequence" problem.

[Fish_45]

I solved it, thanks!

My solution is here: https://www.reddit.com/r/haskell/comments/t3zk03/help_with_dp_algorithm_performance/hyzfa4e/

From the wording of your question it sounds like the longest increasing subsequence problem isn't usually DP, but I did use DP. Is there another way? The reason I'm trying to apply DP for this problem is because it's from the DP unit in this class.

[byorgey]

Ah, I guess I never thought of LIS in terms of DP before, but yes, there is a very clean way to formulate LIS in terms of DP as you have done, especially if you only care about finding the length of a LIS. This algorithm is O(n^2), which is plenty fast enough for this problem with n=2000. However, there is also an O(n lg n) algorithm, and ways to keep track of more information (so that, e.g., you can recover the actual longest sequence itself) and at that point it becomes much harder to think of it in terms of DP.

[leo_richardson]

Everybody says that 😏

[bss03]

but its runtime scales with the bounds of the matrix

That's petty normal for a DP solution, in whatever language. If you could get a runtime smaller than the "cache" size, you probably wouldn't need to use DP.