Decomposable Dequeue

DecomposableDequeue.hs

module DecomposableDequeue (DecomposableDequeue, emptyDecomposableDequeue, pushFront, pushBack, popFront, popBack, measure) where
import qualified Data.Dequeue as D

emptyDecomposableDequeue :: (x->f->f)->f->(b->x->b)->b->(f->b->y)->DecomposableDequeue x f b y
emptyDecomposableDequeue fpush fid bpush bid comb = DecomposableDequeue comb (flip fpush) bpush fid bid D.empty [] []

measure :: DecomposableDequeue x f b y -> y
measure deq = combine deq (peek (idf deq) (frontStack deq)) (peek (idb deq) (backStack deq))
 where peek a b
        | null b    = a
        | otherwise = head b

data DecomposableDequeue x f b y = DecomposableDequeue {
            combine :: f->b->y,
            pushf :: f->x->f,
            pushb :: b->x->b,
            idf :: f,
            idb :: b,
            list :: D.BankersDequeue x,
            backStack :: [b],
            frontStack :: [f]
            }

push :: (f->x->f)->f->[f]->x->[f]
push f fi xs a
 | null xs   = f fi a:xs
 | otherwise = f (head xs) a:xs

empty :: DecomposableDequeue x f b y -> Bool
empty (DecomposableDequeue _ _ _ _ _ _ x y) = null x && null y

pushFront :: DecomposableDequeue x f b y -> x -> DecomposableDequeue x f b y
pushFront deq a = deq {list       = D.pushFront (list deq) a,
                       frontStack = push (pushf deq) (idf deq) (frontStack deq) a}

pushBack :: DecomposableDequeue x f b y -> x -> DecomposableDequeue x f b y
pushBack deq a = deq {list      = D.pushBack (list deq) a, 
                      backStack = push (pushb deq) (idb deq) (backStack deq) a}

popFront :: DecomposableDequeue a l r b -> (Maybe a, DecomposableDequeue a l r b)
popFront deq
 | empty deq             = (Nothing, deq)
 | null (frontStack deq) = popFront (rebuild 1 deq)
 | otherwise             = (fst firstElem, deq {list       = snd firstElem, 
                                              frontStack = tail (frontStack deq)})
 where firstElem = D.popFront (list deq)

popBack :: DecomposableDequeue a l r b -> (Maybe a, DecomposableDequeue a l r b)
popBack deq
 | empty deq             = (Nothing, deq)
 | null (backStack deq)  = popBack (rebuild 0 deq)
 | otherwise             = (fst lastElem, deq {list     = snd lastElem, 
                                                backStack = tail (backStack deq)})
 where lastElem = D.popBack (list deq)

rebuild :: Int -> DecomposableDequeue a l r b -> DecomposableDequeue a l r b
rebuild offset deq = foldl pushFront (foldl pushBack newDD bk) fr
  where n = m `div` 2 + offset
        m = D.length s
        (fr,bk) = (reverse (D.takeFront n s), reverse (D.takeBack (m - n) s))
        s       = list deq
        newDD   = deq {list = D.empty, backStack = [], frontStack = []}

KnapsackSolver.hs

import DecomposableDequeue
import Data.Array

data Object = Object {val :: Int,
                      cost :: Int}
data Table  = Table {bound :: Int,
                     value :: Int -> Int}

knapsackEmptyTable :: Int -> Table
knapsackEmptyTable n = Table n (buildTable (replicate (n+1) 0))

buildTable :: [Int] -> Int -> Int 
buildTable xs i
  | i < 0     = minBound
  | otherwise = cache!i
  where cache = listArray (0, length xs) xs

knapsackPush :: Table -> Object -> Table
knapsackPush t o = Table (bound t) (buildTable [max (value t x) (value t (x- cost o) + val o) | x <- [0..bound t]])

knapsackCombine :: Table -> Table -> Int
knapsackCombine t1 t2 = maximum [value t1 x + value t2 (n-x)|x<-[0..n]]
  where n = bound t1

knapsackDeque :: Int -> DecomposableDequeue Object Table Table Int
knapsackDeque n = emptyDecomposableDequeue (flip knapsackPush) (knapsackEmptyTable n) knapsackPush (knapsackEmptyTable n) knapsackCombine

MaxSumSubarray.hs

import DecomposableDequeue
--(best sum so far starting from beginning, sum from beginning, best sum end at current position, best sum so far)
maxSubarrayEmpty :: (Num a, Ord a) => (a, a, a, a)
maxSubarrayEmpty = (0,0,0,0)

maxSubarrayPush :: (Num a, Ord a) => (a, a, a, a) -> a ->  (a, a, a, a)
maxSubarrayPush (a,b,c,d) x = (max a (b+x), b+x, max 0 (c+x), max d c+x)

maxSubarrayCombine ::  (Num a, Ord a) => (a, a, a, a) -> (a, a, a, a) -> a
maxSubarrayCombine (a,_,_,d) (a',_,_,d') = maximum [a+a',d,d']

maxSubarrayDeque :: (Num a, Ord a) => DecomposableDequeue a (a,a,a,a) (a,a,a,a) a
maxSubarrayDeque = emptyDecomposableDequeue (flip maxSubarrayPush) maxSubarrayEmpty maxSubarrayPush maxSubarrayEmpty maxSubarrayCombine

MonoidSumDequeue.hs

import DecomposableDequeue
import Data.Monoid

monoidDequeue :: (Monoid a) => DecomposableDequeue a a a a
monoidDequeue = emptyDecomposableDequeue mappend mempty mappend mempty mappend