fork download
copy 
  1. --import Data.List (minimumBy, findIndex)
  2. import Data.List (minimumBy, findIndex, find)
  3. import Data.Maybe (fromJust)
  4. import Data.Array
  5.  
  6. extendr ind xs = 
  7.   let splitxs = splitAt ind xs
  8.       from = snd (head $ snd splitxs)
  9.       toMove = last from
  10.       toKeep = init from
  11.       left = if null toKeep
  12.                 then []
  13.                 else [(sum toKeep, toKeep)]
  14.       right = toMove : snd (head $ tail $ snd splitxs)
  15.   in fst splitxs ++ left ++ [(sum right, right)] ++ tail (tail $ snd splitxs)
  16.  
  17. extendl ind xs = 
  18.   let splitxs = splitAt ind xs
  19.       from = snd (head $ snd splitxs)
  20.       toMove = head from
  21.       toKeep = tail from
  22.       right = if null toKeep
  23.                 then []
  24.                 else [(sum toKeep, toKeep)]
  25.       left = snd (last $ fst splitxs) ++ [toMove]
  26.   in init (fst splitxs) ++ [(sum left, left)] ++ right ++ tail (snd splitxs)
  27.  
  28. scanOne xs = scanOne' 1 [] where
  29.   len = length xs
  30.   scanOne' ind result
  31.     | ind == len = result
  32.     | otherwise  =
  33.         let splitxs = splitAt ind xs
  34.             temp = (min (sum $ fst splitxs) (sum $ snd splitxs), ind)
  35.         in scanOne' (ind + 1) (temp:result)
  36.  
  37. unlink ind x =
  38.   let splitToUnlink = splitAt ind (snd x)
  39.       left = (sum (fst splitToUnlink), fst splitToUnlink)
  40.       right = (sum (snd splitToUnlink), snd splitToUnlink)
  41.       in [left] ++ [right]
  42.  
  43. removeExtras currentMin xs = removeExtras' xs 0 [] where
  44.   removeExtras' []     numRemoved result = (result, numRemoved)
  45.   removeExtras' (y:ys) numRemoved result =
  46.     if fst y - minimum (snd y) >= currentMin
  47.        then let scanned = filter (\z -> fst z >= currentMin) $ scanOne (snd y)
  48.             in if null scanned 
  49.                   then removeExtras' ys numRemoved (result ++ [y])
  50.                   else let removed = unlink (snd $ head scanned) y
  51.                        in removeExtras' ys (numRemoved + 1) (result ++ removed)
  52.        else removeExtras' ys numRemoved (result ++ [y])
  53.  
  54. maximize ind currentMin xs =
  55.   if ind == 0
  56.      then maximizeR' maximizeR
  57.      else if ind == length xs - 1
  58.              then maximizeL' maximizeL
  59.              else maximizeRL
  60.     where splitxs = splitAt ind xs
  61.           maximizeR' variables = let vs = fst variables in 
  62.             if snd variables <= currentMin 
  63.                then (xs, 0) 
  64.                else (fst splitxs
  65.                      ++ [(sum (fst vs), fst vs)] 
  66.                      ++ [(sum (snd $ snd vs), snd $ snd vs)] 
  67.                      ++ drop 2 (snd splitxs)
  68.                      , snd variables)
  69.           maximizeL' variables = let vs = fst variables in
  70.             if snd variables <= currentMin 
  71.                then (xs, 0) 
  72.                else (init (fst splitxs)
  73.                      ++ [(sum (fst $ snd vs), fst $ snd vs)] 
  74.                      ++ [(sum (fst vs), fst vs)] 
  75.                      ++ tail (snd splitxs)
  76.                      , snd variables)
  77.           maximizeRL = 
  78.             let leftRight = [maximizeL, maximizeR]
  79.                 best = max (snd $ head leftRight) (snd $ last leftRight)
  80.             in if best /=0 && best <= currentMin 
  81.                   then (xs, 0) 
  82.                   else if snd (head leftRight) >= snd (last leftRight)
  83.                           then maximizeL' (head leftRight)
  84.                           else maximizeR' (last leftRight)
  85.           maximizeR = 
  86.             if numVariations == 0 
  87.                then (([], ([],[])), 0)
  88.                else let variationsR = map (\x -> splitAt x right) [1..numVariations]
  89.                         variations = map (\x -> minimum [sum (left ++ fst x), sum (snd x)]) variationsR
  90.                         maxVariations = maximum variations
  91.                         splitInd = fromJust (findIndex (==maxVariations) variations)
  92.                         splitR = variationsR!!splitInd
  93.                         newLeft = left ++ fst splitR
  94.                     in ((newLeft, splitR), maxVariations)
  95.               where left = snd $ head $ snd splitxs 
  96.                     right = snd $ head $ tail $ snd splitxs
  97.                     lenRight = length right
  98.                     numVariations = 
  99.                       lenRight - length (foldr (\a b -> if sum b >= currentMin then b else a:b) [] right)
  100.           maximizeL = 
  101.             if numVariations == 0 
  102.                then (([], ([],[])), 0) 
  103.                else let variationsL = map (\x -> splitAt x left) [lenLeft-1, lenLeft - 2..lenLeft - numVariations]
  104.                         variations = map (\x -> minimum [sum (fst x), sum (snd x ++ right)]) variationsL
  105.                         maxVariations = maximum variations
  106.                         splitInd = fromJust (findIndex (==maxVariations) variations)
  107.                         splitL = variationsL!!splitInd
  108.                         newRight = snd splitL ++ right
  109.                     in ((newRight, splitL), maxVariations)
  110.               where splitxs = splitAt ind xs
  111.                     right = snd $ head $ snd splitxs 
  112.                     left = snd $ last $ fst splitxs
  113.                     lenLeft = length left
  114.                     numVariations = 
  115.                       lenLeft - length (foldl (\a b -> if sum a >= currentMin then a else b:a) [] left)
  116.  
  117. maxDiff m xs = extend (zip (map sum differences) differences) where 
  118.   differences = map (:[]) $ tail $ zipWith (-) xs ([0] ++ init xs)
  119.   extend ys = 
  120.         let count = sum (map (\x -> length (snd x) - 1) ys)
  121.             lastInd = length ys - 1
  122.             lowestElem = minimumBy (\a b -> compare (fst a) (fst b)) ys
  123.             lowestSum = fst lowestElem
  124.             lowestInd = fromJust (findIndex (==lowestElem) ys)
  125.         in if count < m 
  126.               then if lowestInd == 0
  127.                       then extend (extendr lowestInd ys) 
  128.                       else if lowestInd == lastInd
  129.                               then extend (extendl lowestInd ys) 
  130.                               else if fst (ys!!(lowestInd - 1)) <= fst (ys!!(lowestInd + 1))
  131.                                       then extend (extendl lowestInd ys) 
  132.                                       else extend (extendr lowestInd ys) 
  133.               else let maximized = maximize lowestInd lowestSum ys
  134.                    in if snd maximized == 0 
  135.                          then let removed = removeExtras lowestSum ys
  136.                               in putStrLn (
  137.                                    show (foldr (\a b -> (head b - fst a) : b) [last xs] (fst removed))
  138.                                    ++ "\nMinimum Difference: " ++ show lowestSum
  139.                                    ++ "\n" ++ show (m - snd removed) ++ " Removals"
  140.                                    ++ "\nOriginal Differences, Grouped:\n" ++ show (fst removed))
  141.                          else extend (fst maximized)
  142.  
  143. -- __j_random_hacker's stuff begins here
  144.  
  145. -- My algorithm from http://stackoverflow.com/a/15478409/47984.
  146. -- Oddly it seems to be much faster when I *don't* try to use memoisation!
  147. -- (I don't really understand how memoisation in Haskell works yet...)
  148. jrhMaxDiff m xs = fst $ fromJust $ find (\(x, y) -> snd x > snd y) resultPairsDesc
  149.   where
  150.     inf = 1000000
  151.     n = length xs
  152.     f i j =
  153. --    rawF i j =
  154.       if i == n - 1
  155.          then if j == 0
  156.                  then inf
  157.                  else 0
  158.          else maximum [g i j d | d <- [0 .. min j (n - i - 2)]]
  159. --    f i j = (array ((0, 0), (n, m)) [((ii, jj), rawF ii jj) | ii <- [0 .. n], jj <- [0 .. m]]) ! (i, j)
  160.     g i j d = min ((xs !! (i + d + 1)) - (xs !! i)) (f (i + d + 1) (j - d))
  161.     resultsDesc = map (\i -> (i, f 0 i)) $ reverse [0 .. m]
  162.     resultPairsDesc = zip resultsDesc (concat [(tail resultsDesc), [(-1, -1)]])
  163.  
  164. -- All following code is for looking for different results between my and groovy's algorithms.
  165.  
  166. -- The same as groovy's maxDiff, but returning only a (numDeletions, lowestSum) pair instead of printing out this (and more) info.
  167. pureMaxDiff m xs = extend (zip (map sum differences) differences) where 
  168.   differences = map (:[]) $ tail $ zipWith (-) xs ([0] ++ init xs)
  169.   extend ys = 
  170.         let count = sum (map (\x -> length (snd x) - 1) ys)
  171.             lastInd = length ys - 1
  172.             lowestElem = minimumBy (\a b -> compare (fst a) (fst b)) ys
  173.             lowestSum = fst lowestElem
  174.             lowestInd = fromJust (findIndex (==lowestElem) ys)
  175.         in if count < m 
  176.               then if lowestInd == 0
  177.                       then extend (extendr lowestInd ys) 
  178.                       else if lowestInd == lastInd
  179.                               then extend (extendl lowestInd ys) 
  180.                               else if fst (ys!!(lowestInd - 1)) <= fst (ys!!(lowestInd + 1))
  181.                                       then extend (extendl lowestInd ys) 
  182.                                       else extend (extendr lowestInd ys) 
  183.               else let maximized = maximize lowestInd lowestSum ys
  184.                    in if snd maximized == 0 
  185.                          then let removed = removeExtras lowestSum ys
  186.                               in ((m - snd removed), lowestSum)
  187.                          else extend (fst maximized)
  188.  
  189. -- Generate a list of all length-n lists containing numbers in the range 0 - d.
  190. upto :: Int -> Int -> [[Int]]
  191. upto 0 _ = [[]]
  192. upto n d = concat $ map (\x -> (map (\y -> (x : y)) (upto (n - 1) d))) [0 .. d]
  193.  
  194. -- Generate a list of all length-maxN or shorter lists containing numbers in the range 0 - maxD.
  195. generateAllDiffCombos :: Int -> Int -> [[Int]]
  196. generateAllDiffCombos 1 maxD = [[x] | x <- [0 .. maxD]]
  197. generateAllDiffCombos maxN maxD =
  198.   (generateAllDiffCombos (maxN - 1) maxD) ++ (upto maxN maxD)
  199.  
  200. diffsToNums xs = scanl (+) 0 xs
  201.  
  202. generateAllCombos maxN maxD = map diffsToNums $ generateAllDiffCombos maxN maxD
  203.  
  204. -- generateAllCombos causes pureMaxDiff to produce an error with (1, [0, 0]) and (1, [0, 0, 0]) among others,
  205. -- so filter these out to look for more "interesting" differences.
  206. --generateMostCombos maxN maxD = filter (\x -> length x /= 2) $ generateAllCombos maxN maxD
  207. generateMostCombos maxN maxD = filter (\x -> length x > 4) $ generateAllCombos maxN maxD
  208.  
  209. -- Try running both algorithms on every list of length up to maxN having gaps of
  210. -- size up to maxD, allowing up to maxDel deletions (this is the M parameter).
  211. compareAllCombos maxN maxD maxDel =
  212.   find (\(x, jrh, grv) -> jrh /= grv) $ map (\x -> (x, jrhMaxDiff maxDel x, pureMaxDiff maxDel x)) $ generateMostCombos maxN maxD
  213. --  show $ map (\x -> (x, jrhMaxDiff maxDel x, pureMaxDiff maxDel x)) $ generateMostCombos maxN maxD
  214.  
Compilation error #stdin compilation error #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
compilation info 
[1 of 1] Compiling Main             ( prog.hs, prog.o )

prog.hs:1:1: The function `main' is not defined in module `Main'
stdout
copy 
Standard output is empty
https://ideone.com/sTmqUO
language:
Haskell (ghc 8.4.4)
created:
11 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!