2
\$\begingroup\$

A previous solution of this code has been posted on Code Review before.
This solution is more complicated then that one, but more performant (see the below)

Why is this another Question instead of a answer on the original Question?

  • This solution works fundamentally different then the original.
    It feels big enough of a shift to warrant a new question
  • I want feedback on this solution, more-so then can be achieved in a answer on a question

Problem Summary

You are given a list of stones' weights (positive integer numbers);
While there are at least two stones in the list, take the two heaviest stones and smash them together;

if the weights were equal, both stones are destroyed;
otherwise the lighter stone gets destroyed and the heavier is reduced in size to the difference of the two values.
You now need to consider this "remainder" stone as well as all the other stones

The process ends when there is one or no stones in the list, and the result is either the last remaining stone, or zero if there are no stones left.

Personal Constraints

  • Idiomatic Haskell
  • Performant
  • Time Complexity Similar to C++ Priority Queue (Similar speed is a bonus)
  • Base Lib

The code

foldLastStone :: (Num a, Ord a) => [a] -> a
foldLastStone = process . revSort
  where
    revCompare = flip compare
    revSort    = sortBy revCompare
    revInsert  = insertBy revCompare

    process []  = 0
    process [x] = x
    process ls = process $ foldl foldStone [] ls

    foldStone [] x  = [x]
    foldStone [r] x
      | r == x    = []
      | r > x     = [r - x]
      | otherwise = [x,r]
    foldStone rls@(r:rr:rs) x   -- x >=< (r >= rr)
      | x == r    = (rr:rs)                      -- (x == r) >= rr
      | x < rr    = xLessThanRR                  -- x < (rr <= r)
      | x < r     = revInsert (r - x) $ rr:rs    -- r > (x >= rr)
      | otherwise = (x:rls)                      -- x > (r >= rr)
      where
        xLessThanRR
          | r == rr   = foldStone rs x                        -- x < (rr == r)
          | otherwise = foldStone (revInsert (r - rr) rs) x   -- x < (rr < r)

Explanation

init

foldLastStone :: (Num a, Ord a) => [a] -> a
foldLastStone = process . revSort

signature and composing process with our ascending sort

helpers

revCompare = flip compare
revSort    = sortBy revCompare
revInsert  = insertBy revCompare

idiomatic ascending sort and ascending insert

process

base cases:
process []  = 0
process [x] = x
main processing
process ls = process $ foldl foldStone [] ls

Takes an ordered list (from either the initial revSort or the output from the stoneFold) and then recursively applies the folding operation, until one value or no values remain.

foldStone

The main logic for working on the list of stones.
The idea is to get the biggest stone in the r position,
at every iteration we compare this stone to the candidate: x, and the next biggest stone in the remainders: rr
If the candidate is bigger, it is placed in the r position for the next iteration.

This will return a list (ascending ordered) that contains any remaining stones that have not been processed.

Base case:

We move the candidate x into the r position for the next iteration

foldStone [] x  = [x]
Case with only one item in the remainders

Simplified processing as there is only one r and one x

foldStone [r] x
  | r == x    = []       -- the rocks are destroyed
  | r > x     = [r - x]  -- r was, in fact, the biggest
  | otherwise = [x,r]    -- x is bigger
Main process

comments indicate how the different stones compare at this step in the checking e.g. at the start the x candidate can be GT, LT or EQ to both the r or the rr; r could be GT or EQ to rr, but can not be LT

foldStone rls@(r:rr:rs) x     -- x >=< (r >= rr)
  | x == r    = (rr:rs)       -- (x == r) >= rr -- neXt and Remainder are destroyed, RReSt are returned
  | x < rr    = xLessThanRR   -- x < (rr <= r)
  | x < r     = revInsert (r - x) $ rr:rs    -- r > (x >= rr) -- Remainder was bigger than neXt, calculate new remainder and put into the correct position in the RReSt
  | otherwise = (x:rls)       -- x > (r >= rr)  -- neXt was biggest, add to head of the RestLiSt
  where
    xLessThanRR  -- You could replace this branch with `foldStone (foldStone (r:rs) rr) x` but there would be a wasted check: rr=<r so the second check would be wasted as rr=>rrr will always hold; rr==r or rr<r so we check those
      | r == rr   = foldStone rs x -- foldStone rs x   -- x < (rr == r)  -- the RemaindeRs destroyed, neXt is processed with the ReSt
      | otherwise = foldStone (revInsert (r - rr) rs) x  -- x < (rr < r)  -- the RemaindeRs will leave another remainder,  neXt is processed with the new list

This solution works by keeping a smaller list of all the remainder stones available to the folding step.

We compare the candidate x with the biggest remainder r and the next remainder rr

From the sorting, we know x is the largest stone available in the main list.
From the revInsert we know that the r has to be the largest stone in the remainder list.
r might also be the largest stone.

  1. If x == r, these stones will be destroyed, and we return the rest of the remainders to the next iteration
  2. If x < rr, this indicates that we should process r and rr
    1. if r == rr they are destroyed and we instead process x with rs
    2. otherwise we have to work out the new remainder of r - rr, put that in the correct position in the remainder list (rs) and then process x with the new remainder list.
  3. If x < r then we return a new remainder list with the new remainder (r - x) in the correct position
  4. otherwise we now know x is a bigger stone, and we put it at the head of the whole remainder list for the next iteration

Performance

Checked against the C++ implementation using PriorityQueue

Linear [1..n]

code time array size
cpp (-O3) ~0.01 1 000 000
cpp (-O3) ~0.1s 2 000 000
cpp (-O3) ~0.5s 4 000 000
cpp (-O3) ~1s 8 000 000
cpp (-O3) ~1.2s 10 000 000
cpp (-O3) ~3.1s 20 000 000
cpp (-O3) ~5.7s 40 000 000
cpp (-O3) ~10.1s 80 000 000
cpp (-O3) ~12.2s 100 000 000
cpp (-O3) ~26.0s 200 000 000
cpp (-O3) ~55.7s 400 000 000
cpp (-O3) ~110.5s 800 000 000
haskell (-O2) ~0.2s 1 000 000
haskell (-O2) ~0.4s 2 000 000
haskell (-O2) ~0.7s 4 000 000
haskell (-O2) ~1.3s 8 000 000
haskell (-O2) ~1.5s 10 000 000
haskell (-O2) ~3.2s 20 000 000
haskell (-O2) ~6.5s 40 000 000
haskell (-O2) ~12.3s 80 000 000
haskell (-O2) ~16s 100 000 000
haskell (-O2) ~66.5s (Hit > 15GB/16GB Memory) 200 000 000
haskell (-O2) DNF (OS killed the process) 400 000 000

Observed time complexity shows something like O(n) for both solutions.

Sadly the Haskell solution was held back by memory. At the 200M mark, it exhausted my 16GB of Ram and started thrashing my pagefile. At 400M something went awry and my OS killed the process.
The C++ solution had constant memory usage and got up to about 6GB for the 800M run, while Haskell had used in excess of 15GB for the big linear lists.

Something about this solution has to keep A LOT of working memory on the linear lists.

Random lists of size n

code time array size
cpp (-O3) ~0.1s 1 000 000
cpp (-O3) ~4.8s 10 000 000
cpp (-O3) ~45.2s 100 000 000
haskell (-O2) ~2.2s 1 000 000
haskell (-O2) ~23.2s 10 000 000
haskell (-O2) ~251.7s 100 000 000

Still basically O(n) for both, and for both an order of magnitude slow down.
Haskell was just effected harder:
c++: ~4x slower then linear
haskell: 23x slower then linear

I observed the memory being used in a "stepping" pattern for the random lists, as apposed to the all-then-nothing of the linear.
It would "step" up a few GB then "float" for a bit (a little up a little down) then step up another few GB until the halfway point.
After the halfway point it would do the reverse, "stepping" down, floating, and stepping down again until it finished.

Testing

This solution is a little wonky and proving that it is valid took the most amount of time.

Case-By-Case

I used permutations to get all the permutations of [W,x,y,z] and then split it into two blocks: [?,?] [?,?]

This is the representation of a given iteration with left hand side being the "Main List" and the right hand side being the "Remainder List".

They are ordered [->] [<-] meaning the center should always have the largest values.

These lists "are" bigger then shown, e.g [...,?,?] [?,?,...] but the only values that matter are the 4 in the center.

technically only the [..,?] [?,?,...] positions matter, but including the additional one is illustrative

The values used are W, x, y and z with the values being W > x > y > z

A break down of the operation are shown on the right hand side of the Case.

We are only testing for valid operations, it is assumed the remainder as a result of a (-) operation will be placed correctly.

For clarity, after the first operation, we usually add a ? on the "Main List" side.

SHOULD BE IMPOSSIBLE marks a state case that should be impossible to achieve, because of how we construct the lists.

Case [Main->] [<-Remainder] -- Breakdown
---------------------------
Case [W,x] [y,z] -- SHOULD BE IMPOSSIBLE (W > x)
Case [x,W] [y,z] -> [?,x] [W,y,z] ->  W - x  -> [?] [y,z] ->  y - z
Case [y,x] [W,z] -> W - x -> [?,y] [z] -> [?] [y,z] -> y - z
Case [x,y] [W,z] -- SHOULD BE IMPOSSIBLE (x > y)
Case [y,W] [x,z] -> [?,y] [W,x.z] ->  W - x  -> [?,y] [z] -> [?] [y,z] ->  y - z 
Case [W,y] [x,z] -- SHOULD BE IMPOSSIBLE (W > y)
Case [z,y] [x,W] -- SHOULD BE IMPOSSIBLE (x < W)
Case [y,z] [x,W] -- SHOULD BE IMPOSSIBLE (x < W)
Case [y,x] [z,W] -- SHOULD BE IMPOSSIBLE (z < W)
Case [z,x] [y,W] -- SHOULD BE IMPOSSIBLE (y < W)
Case [x,z] [y,W] -- SHOULD BE IMPOSSIBLE (y < W)
Case [x,y] [z,W] -- SHOULD BE IMPOSSIBLE (z < W)
Case [z,W] [x,y] -> [?,z] [W,x,y] ->  W - x  -> [?,z] [y] ->  y - z
Case [W,z] [x,y] -- SHOULD BE IMPOSSIBLE (W > z)
Case [W,x] [z,y] -- SHOULD BE IMPOSSIBLE (W > x)
Case [z,x] [W,y] -> W - x -> [?,z] [y] ->  y - z
Case [x,z] [W,y] -- SHOULD BE IMPOSSIBLE (x > z)
Case [x,W] [z,y] -- SHOULD BE IMPOSSIBLE (z < y)
Case [z,W] [y,x] -- SHOULD BE IMPOSSIBLE (y < x)
Case [W,z] [y,x] -- SHOULD BE IMPOSSIBLE (W > z)
Case [W,y] [z,x] -- SHOULD BE IMPOSSIBLE (W > y)
Case [z,y] [W,x] -> W - x -> [z,y] [] -> [?,z] [y] -> y - z
Case [y,z] [W,x] -- SHOULD BE IMPOSSIBLE (y > z)
Case [y,W] [z,x] -- SHOULD BE IMPOSSIBLE (z < x)

Here follows the valid cases where we have duplicate W values

Case [Main->] [<-Remainder] -- Breakdown
---------------------------
Case [W,W] [x,y] -> [?,W] [W,x,y] ->  W - W  -> [?] [x,y] ->  x - y
Case [y,W] [W,x] -> W - W -> [?,y] [x] -> x - y
Case [x,W] [W,y] -> W - W -> [?,x] [y] -> [?] [x,y] -> x - y
Case [y,x] [W,W] -> W - W -> [?,y] [x] -> x - y

Test Vectors

I also ran it against some test lists.


testLists = [[1,3,5,7,9,11], [10,9,8,3,2],[100,50,40,45,44,18,7,6,1], [1,9,15,1005,6,1,7,863,31,546,879,122], [10,9,8,3,2], [1..100], [100,99..1], [1,3..100], [1,4..100], (take 100 [1,1..]), (take 100 [2,2..]), (take 100 [7,7..]), (intersperse 7 (take 50 [2,2..])), (intersperse 2 (take 50 [7,7..]))]

-- sequence $ replicate 10 $ (sequence $ replicate 50 $ randomRIO (1,30::Int))
randBigLists = [[67,14,69,38,100,89,51,79,35,46,21,45,6,43,8,67,12,7,15,33,57,62,36,33,15],[13,14,62,79,3,17,60,10,59,2,37,41,35,66,1,89,87,46,30,46,53,91,62,34,68],[17,84,75,27,72,89,43,74,45,62,59,98,28,13,79,4,76,61,22,51,33,10,42,71,34],[98,98,67,23,75,71,57,71,41,99,26,101,89,62,22,64,8,92,88,77,29,92,14,25,92],[100,44,16,39,95,57,34,55,53,36,44,98,24,15,82,54,24,5,15,44,5,96,22,74,86],[81,90,6,15,62,18,13,51,101,71,16,6,5,12,91,26,31,36,73,95,41,31,98,81,43],[33,48,15,4,14,87,57,48,23,53,5,16,83,34,97,5,95,83,6,91,3,17,56,82,80],[4,17,9,40,61,96,68,55,65,71,79,58,65,66,71,57,37,84,100,59,30,26,28,51,42],[76,93,71,21,90,21,45,38,3,63,72,31,7,80,4,62,27,25,50,95,88,17,7,96,83],[67,63,69,86,13,99,83,64,7,71,32,51,100,98,56,92,3,46,72,30,5,58,54,47,92]]

-- 10 50@(1,30)
randMediumLists = [[28,28,11,8,20,5,25,18,18,16,15,15,12,13,20,16,10,25,26,14,26,5,7,10,20,17,4,4,25,6,1,23,29,4,1,8,30,4,9,12,11,27,25,18,24,13,10,1,2,25],[23,29,29,15,19,11,3,10,25,10,14,10,2,14,14,14,10,5,19,4,27,1,23,16,17,2,11,11,1,27,7,2,14,30,4,17,1,1,17,8,24,18,30,23,9,29,17,8,13,21],[14,30,20,27,13,21,15,19,11,25,23,20,3,20,3,2,8,27,19,18,4,24,1,2,14,14,27,23,3,12,21,28,20,30,18,5,23,12,21,22,23,10,18,19,25,30,14,14,9,22],[22,14,11,29,20,8,14,29,21,28,7,27,28,14,11,12,7,12,13,14,25,17,8,22,20,15,24,11,30,11,6,18,18,12,27,18,24,19,1,23,5,23,15,20,16,7,29,19,13,14],[6,15,8,4,5,19,24,14,21,12,14,25,20,17,20,10,14,2,9,29,30,21,13,29,14,8,10,5,20,25,25,20,4,26,30,29,28,7,2,1,3,23,28,22,22,27,6,1,4,20],[23,7,16,3,5,7,20,8,22,24,20,9,26,25,8,19,4,28,28,23,24,30,13,2,1,5,16,26,5,25,13,10,30,25,27,10,23,7,7,22,3,28,16,3,16,21,27,7,10,8],[16,9,21,10,28,29,26,30,19,14,7,17,10,24,23,22,27,10,22,14,14,29,26,25,18,20,6,6,8,11,27,14,12,15,15,16,13,10,13,26,7,14,24,6,12,19,8,22,8,6],[18,19,19,19,19,29,27,14,2,8,12,29,21,25,10,15,4,14,27,7,22,25,22,2,18,3,8,10,16,7,12,3,20,26,29,20,4,29,25,13,10,7,25,4,13,5,14,26,29,10],[6,8,1,10,26,15,11,13,6,4,21,12,14,20,1,25,29,11,24,1,1,5,10,15,6,12,18,13,24,25,10,5,11,4,13,28,28,27,8,16,7,5,14,25,7,6,11,22,17,5],[19,5,21,2,9,29,18,23,3,1,26,5,29,10,22,14,27,26,16,10,8,17,16,4,1,30,27,14,5,30,19,4,21,4,18,29,17,27,14,13,20,7,14,26,28,29,30,9,29,18]]

-- 10 25@(1,5) + 10 26@(1,5)
randSmallLists = [[4,3,1,4,3,5,3,3,2,3,2,3,4,3,2,1,5,1,2,1,1,1,5,5,3],[5,5,5,3,5,4,1,1,1,3,1,5,2,5,4,5,3,1,3,4,3,3,4,4,2],[3,5,4,5,2,5,4,4,1,4,3,4,5,5,4,4,2,2,1,2,4,5,3,1,2],[3,2,2,5,4,2,3,3,3,5,3,4,2,3,1,4,3,3,1,5,1,4,4,3,1],[1,5,4,2,4,2,5,3,3,5,3,5,2,5,1,4,1,1,2,1,4,5,5,3,2],[2,3,3,4,3,1,2,5,3,5,2,2,1,1,3,2,2,5,5,1,1,3,2,5,3],[4,5,1,5,5,4,5,1,2,5,4,1,2,3,1,3,5,4,3,5,1,3,5,5,1],[4,4,3,3,1,1,1,3,1,2,2,2,4,3,1,5,4,2,1,4,4,5,4,4,5],[1,1,5,3,4,3,1,3,2,3,2,3,3,2,3,2,2,1,4,4,1,5,2,2,3],[4,3,1,1,3,1,5,2,3,2,3,4,3,5,5,5,4,1,4,2,1,5,3,4,2],[4,5,1,4,1,3,3,5,2,5,5,2,1,2,4,1,2,5,1,4,2,5,2,2,3,2],[5,1,5,4,5,1,3,1,4,5,2,3,2,3,5,3,1,3,4,1,1,5,1,4,2,2],[5,5,4,5,1,1,5,5,3,3,2,4,5,3,4,2,3,1,1,1,1,5,1,5,2,1],[2,1,4,5,5,3,3,4,1,2,3,5,4,3,1,2,4,4,2,2,5,1,3,2,2,3],[1,4,5,5,2,2,3,3,5,1,3,3,2,4,2,5,3,3,2,4,4,5,4,2,4,3],[3,2,2,3,3,3,1,5,3,3,5,1,5,5,1,5,5,5,3,1,3,3,4,2,3,2],[3,4,5,4,5,5,2,2,2,4,4,3,4,4,2,1,3,5,5,4,2,2,2,2,1,1],[1,5,5,3,2,3,3,3,2,5,2,3,5,5,2,3,2,5,1,5,2,4,5,5,2,1],[1,5,1,5,2,1,1,2,1,3,1,4,4,1,4,2,1,4,3,3,1,2,2,3,3,5],[3,1,5,3,1,2,5,2,3,2,5,4,1,1,5,3,3,5,1,2,2,3,3,2,1,3]]

Using the external Heap Package

Please consider the below as Supplemental
I wanted to include this because of the interesting performance numbers below

import qualified Data.Heap as Heap

heapLastStone :: [Int] -> Int
heapLastStone ls = proccess $ (Heap.fromList ls :: Heap.MaxHeap Int)
  where
    proccess hs
      | Heap.null hs     = 0               -- none left
      | length vals == 1 = head vals       -- if there is only one value in the heap. There is a length check on the heap itself, but it's actually slightly slower (!)
      | n == 0           = proccess hrest  -- if the rocks were destroyed
      | otherwise        = proccess hmore  -- if there is a remainder
      where n      = calc vals             -- caluclates the diff of x - y
            splith = Heap.splitAt 2 hs     -- return top 2 values from heap ([x,y],heap...)
            vals   = fst splith            -- [x,y]
            hrest  = snd splith            -- heap...
            hmore  = Heap.insert n hrest   -- will insert new value into heap

    calc [] = 0
    calc [x] = x
    calc [x,y] = x - y
code time array size
haskell (-O2) ~2.9s 1 000 000
haskell (-O2) ~26.3s 10 000 000
haskell (-O2) ~251.4s 100 000 000

These numbers look almost IDENTICAL to the numbers for the folding solution (!)

This is probably serendipity but might point to something else.

As for memory usage, it was the same +15GB for the 100M but the usage pattern was different, it slowly increased, then slowly decreased as the time progressed.

\$\endgroup\$

0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Browse other questions tagged or ask your own question.