module Data.LinearSplit (
Item (..),
Range (..),
lPartition,
ltPartition,
gPartition
) where
import Data.Array
import Data.List (nub, groupBy, inits)
data Item a b = Item {
item :: a,
weight :: b
} deriving (Eq, Show, Ord)
data Range a b = Range {
price :: b,
low :: a,
high :: a
} deriving (Eq, Show, Ord)
data Cell b = Cell {
cost :: b,
ind :: Int
} deriving (Eq, Show, Ord)
merge :: (Ord b) => b -> Item a b -> Item a b -> Bool
merge i x y = weight x <= i && weight y <= i
ranges :: (Ord b, Num b) => [[Item a b]] -> [Range a b]
ranges xss = map mkRange xss where
mkRange xs = Range (sum $ map weight xs) (item $ head xs) (item $ last xs)
gPartition :: (Ord b, Num b) => ([Item a b] -> Bool) -> Int -> [Item a b] -> [Range a b]
gPartition fun n = ranges . gPartition' fun n
gPartition' :: ([Item a b] -> Bool) -> Int -> [Item a b] -> [[Item a b]]
gPartition' f n xs
| n <= 0 = gPartition' f 1 xs
| otherwise = go n xs f where
go _ [] _ = []
go 1 ys _ = [ys]
go n ys f =
let cands = dropWhile f ((tail . inits) ys)
chunk = if null cands then ys else head cands
rest = drop (length chunk) ys
in chunk : go (n1) rest f
lPartition :: (Num b, Ord b) => Int -> [Item a b] -> [Range a b]
lPartition n = ranges . lPartition' n
ltPartition :: (Num b, Ord b) => Int -> [Item a b] -> b -> [Range a b]
ltPartition n xs threshold =
unshrink $ lPartition n (shrink (merge threshold) xs)
lPartition' :: (Num b, Ord b) => Int -> [Item a b] -> [[Item a b]]
lPartition' size items
| size <= 0 = lPartition' 1 items
| otherwise = slices dividers items where
dividers | noItems <= size = [0..noItems1]
| otherwise = nub $ reverse $ cells size $ valOf noItems size
cells 1 cell = [0]
cells k cell = ind cell : cells (k1) (valOf (ind cell) (k1))
table = array ((1,1), (noItems, size))
[
((m,n), cell m n) |
m <- [1..noItems],
n <- [1..size]
]
valOf m n
| m == 1 = Cell (weight $ itemsArr ! 1) 1
| n == 1 = Cell (prefSums ! m) 1
| otherwise = table ! (m,n)
cell m n = foldr1 min $ map maxCost [1..m] where
maxCost x = Cell (max (curCost x) $ newCost x) x
curCost x = cost $ valOf x (n1)
newCost x = prefSums ! m prefSums ! x
noItems = length items
itemsArr = listArray (1, noItems) items
prefSums = listArray (1, noItems) $ scanl1 (+) (map weight items)
slices xs items = map slice ls where
ls = zip xs (tail (xs ++ [length items]))
slice (lo, hi) = take (hilo) $ drop lo items
shrink :: Num b => (Item a b -> Item a b -> Bool) -> [Item a b] -> [Item (a,a) b]
shrink thr items = map mkItem' $ groupBy thr items where
mkItem' xs = Item (lo xs, hi xs) $ sum $ map weight xs
lo = item . head
hi = item . last
unshrink :: [Range (a,a) b] -> [Range a b]
unshrink = map (\(Range cost lo hi) -> Range cost (fst lo) (snd hi))