--import Data.List (minimumBy, findIndex)
import Data.List (minimumBy, findIndex, find)
import Data
.Maybe (fromJust
) import Data.Array
extendr ind xs =
then []
else [(sum toKeep
, toKeep
)]
extendl ind xs =
then []
else [(sum toKeep
, toKeep
)]
scanOne xs = scanOne' 1 [] where
len = length xs
scanOne' ind result
| ind == len = result
in scanOne' (ind + 1) (temp:result)
unlink ind x =
let splitToUnlink = splitAt ind (snd x)
left = (sum (fst splitToUnlink), fst splitToUnlink)
right = (sum (snd splitToUnlink), snd splitToUnlink)
in [left] ++ [right]
removeExtras currentMin xs = removeExtras' xs 0 [] where
removeExtras' [] numRemoved result = (result, numRemoved)
removeExtras' (y:ys) numRemoved result =
then let scanned
= filter (\z
-> fst z
>= currentMin
) $ scanOne
(snd y
) then removeExtras' ys numRemoved (result ++ [y])
else let removed = unlink (snd $ head scanned) y
in removeExtras' ys (numRemoved + 1) (result ++ removed)
else removeExtras' ys numRemoved (result ++ [y])
maximize ind currentMin xs =
if ind == 0
then maximizeR' maximizeR
then maximizeL' maximizeL
else maximizeRL
where splitxs = splitAt ind xs
maximizeR' variables
= let vs
= fst variables
in if snd variables
<= currentMin
then (xs, 0)
maximizeL' variables = let vs = fst variables in
if snd variables <= currentMin
then (xs, 0)
else (init (fst splitxs)
++ [(sum (fst $ snd vs), fst $ snd vs)]
++ [(sum (fst vs), fst vs)]
++ tail (snd splitxs)
, snd variables)
maximizeRL =
let leftRight = [maximizeL, maximizeR]
best = max (snd $ head leftRight) (snd $ last leftRight)
in if best /=0 && best <= currentMin
then (xs, 0)
else if snd (head leftRight) >= snd (last leftRight)
then maximizeL' (head leftRight
) else maximizeR' (last leftRight)
maximizeR =
if numVariations == 0
then (([], ([],[])), 0)
else let variationsR = map (\x -> splitAt x right) [1..numVariations]
variations = map (\x -> minimum [sum (left ++ fst x), sum (snd x)]) variationsR
maxVariations = maximum variations
splitInd = fromJust (findIndex (==maxVariations) variations)
splitR = variationsR!!splitInd
newLeft = left ++ fst splitR
in ((newLeft, splitR), maxVariations)
where left = snd $ head $ snd splitxs
right = snd $ head $ tail $ snd splitxs
lenRight = length right
numVariations =
lenRight - length (foldr (\a b -> if sum b >= currentMin then b else a:b) [] right)
maximizeL =
if numVariations == 0
then (([], ([],[])), 0)
else let variationsL = map (\x -> splitAt x left) [lenLeft-1, lenLeft - 2..lenLeft - numVariations]
variations = map (\x -> minimum [sum (fst x), sum (snd x ++ right)]) variationsL
maxVariations = maximum variations
splitInd = fromJust (findIndex (==maxVariations) variations)
splitL = variationsL!!splitInd
newRight = snd splitL ++ right
in ((newRight, splitL), maxVariations)
where splitxs = splitAt ind xs
right = snd $ head $ snd splitxs
left = snd $ last $ fst splitxs
lenLeft = length left
numVariations =
lenLeft - length (foldl (\a b -> if sum a >= currentMin then a else b:a) [] left)
maxDiff m xs = extend (zip (map sum differences) differences) where
differences = map (:[]) $ tail $ zipWith (-) xs ([0] ++ init xs)
extend ys =
let count = sum (map (\x -> length (snd x) - 1) ys)
lastInd = length ys - 1
lowestElem = minimumBy (\a b -> compare (fst a) (fst b)) ys
lowestSum = fst lowestElem
lowestInd = fromJust (findIndex (==lowestElem) ys)
in if count < m
then if lowestInd == 0
then extend (extendr lowestInd ys)
else if lowestInd == lastInd
then extend (extendl lowestInd ys)
else if fst (ys!!(lowestInd - 1)) <= fst (ys!!(lowestInd + 1))
then extend (extendl lowestInd ys)
else extend (extendr lowestInd ys)
else let maximized = maximize lowestInd lowestSum ys
in if snd maximized == 0
then let removed = removeExtras lowestSum ys
in putStrLn (
show (foldr (\a b -> (head b - fst a) : b) [last xs] (fst removed))
++ "\nMinimum Difference: " ++ show lowestSum
++ "\n" ++ show (m - snd removed) ++ " Removals"
++ "\nOriginal Differences, Grouped:\n" ++ show (fst removed))
else extend (fst maximized)
-- __j_random_hacker's stuff begins here
-- My algorithm from http://stackoverflow.com/a/15478409/47984.
-- Oddly it seems to be much faster when I *don't* try to use memoisation!
-- (I don't really understand how memoisation in Haskell works yet...)
jrhMaxDiff m xs
= fst $ fromJust
$ find
(\
(x
, y
) -> snd x
> snd y
) resultPairsDesc
where
inf = 1000000
f i j =
-- rawF i j =
if i == n - 1
then if j == 0
then inf
else 0
else maximum [g i j d
| d
<- [0 .. min j
(n
- i
- 2)]] -- f i j = (array ((0, 0), (n, m)) [((ii, jj), rawF ii jj) | ii <- [0 .. n], jj <- [0 .. m]]) ! (i, j)
g i j d
= min ((xs
!! (i
+ d
+ 1)) - (xs
!! i
)) (f
(i
+ d
+ 1) (j
- d
)) resultsDesc
= map (\i
-> (i
, f
0 i
)) $ reverse [0 .. m
] resultPairsDesc
= zip resultsDesc
(concat [(tail resultsDesc
), [(-1, -1)]])
-- All following code is for looking for different results between my and groovy's algorithms.
-- The same as groovy's maxDiff, but returning only a (numDeletions, lowestSum) pair instead of printing out this (and more) info.
pureMaxDiff m xs
= extend
(zip (map sum differences
) differences
) where extend ys =
lowestSum
= fst lowestElem
lowestInd = fromJust (findIndex (==lowestElem) ys)
in if count < m
then if lowestInd == 0
then extend (extendr lowestInd ys)
else if lowestInd == lastInd
then extend (extendl lowestInd ys)
else if fst (ys
!!(lowestInd
- 1)) <= fst (ys
!!(lowestInd
+ 1)) then extend (extendl lowestInd ys)
else extend (extendr lowestInd ys)
else let maximized = maximize lowestInd lowestSum ys
then let removed = removeExtras lowestSum ys
in ((m
- snd removed
), lowestSum
) else extend
(fst maximized
)
-- Generate a list of all length-n lists containing numbers in the range 0 - d.
upto 0 _ = [[]]
upto n d
= concat $ map (\x
-> (map (\y
-> (x : y
)) (upto
(n
- 1) d
))) [0 .. d
]
-- Generate a list of all length-maxN or shorter lists containing numbers in the range 0 - maxD.
generateAllDiffCombos
:: Int -> Int -> [[Int]]generateAllDiffCombos 1 maxD = [[x] | x <- [0 .. maxD]]
generateAllDiffCombos maxN maxD =
(generateAllDiffCombos (maxN - 1) maxD) ++ (upto maxN maxD)
diffsToNums xs
= scanl (+) 0 xs
generateAllCombos maxN maxD
= map diffsToNums
$ generateAllDiffCombos maxN maxD
-- generateAllCombos causes pureMaxDiff to produce an error with (1, [0, 0]) and (1, [0, 0, 0]) among others,
-- so filter these out to look for more "interesting" differences.
--generateMostCombos maxN maxD = filter (\x -> length x /= 2) $ generateAllCombos maxN maxD
generateMostCombos maxN maxD
= filter (\x
-> length x
> 4) $ generateAllCombos maxN maxD
-- Try running both algorithms on every list of length up to maxN having gaps of
-- size up to maxD, allowing up to maxDel deletions (this is the M parameter).
compareAllCombos maxN maxD maxDel =
find
(\
(x
, jrh
, grv
) -> jrh
/= grv
) $ map (\x
-> (x
, jrhMaxDiff maxDel x
, pureMaxDiff maxDel x
)) $ generateMostCombos maxN maxD
-- show $ map (\x -> (x, jrhMaxDiff maxDel x, pureMaxDiff maxDel x)) $ generateMostCombos maxN maxD