Ticket #3909: Skew.hs

File Skew.hs, 2.9 KB (added by LouisWasserman, 4 years ago)

Quickie implementation of skew heaps, a variation on leftist heaps that Wikipedia suggests is almost always better. This tests as inferior (in almost every way) to binomial heaps, and also offers worse runtimes (amortized O(log n) insert, for instance), so I don't particularly think it'll supplant binomial or pairing heaps

Line 
1module Data.PQueue.Skew (SkewQueue, union, singleton, insert, fromList, unions, foldrAsc, toAscList, toList) where
2
3import GHC.Exts
4import Data.Foldable hiding (toList)
5import Prelude hiding (foldr, foldl)
6
7data SHeap a = SHeap a (MSHeap a) (MSHeap a)
8data MSHeap a = Nil | SJust {-# UNPACK #-} !(SHeap a)
9
10data SkewQueue a = SkewQueue {-# UNPACK #-} !Int (MSHeap a)
11
12instance Foldable SkewQueue where
13        foldr f z (SkewQueue _ t) = foldr f z t
14        foldl f z (SkewQueue _ t) = foldl f z t
15
16instance Foldable SHeap where
17        foldr f z (SHeap x l r) = x `f` foldr f (foldr f z r) l
18        foldl f z (SHeap x l r) = foldl f (foldl f (z `f` x) l) r
19
20instance Foldable MSHeap where
21        foldr _ z Nil = z
22        foldr f z (SJust t) = foldr f z t
23        foldl _ z Nil = z
24        foldl f z (SJust t) = foldl f z t
25
26union :: Ord a => SkewQueue a -> SkewQueue a -> SkewQueue a
27SkewQueue n1 q1 `union` SkewQueue n2 q2 = SkewQueue (n1 + n2) (meld' (<=) q1 q2)
28
29singleton :: a -> SkewQueue a
30singleton = SkewQueue 1 . SJust . tip
31
32tip :: a -> SHeap a
33tip x = SHeap x Nil Nil
34
35insert :: Ord a => a -> SkewQueue a -> SkewQueue a
36insert = union . singleton
37
38data ViewQ a = EmptyQ           -- ^ empty queue
39        | a :^ SkewQueue a      -- ^ the top (minimum) of the queue and the rest of the queue
40
41extract :: Ord a => SkewQueue a -> ViewQ a
42extract (SkewQueue _ Nil) = EmptyQ
43extract (SkewQueue n (SJust (SHeap x l r))) =
44        x :^ SkewQueue n (meld' (<=) l r)
45
46instance Functor SHeap where
47        fmap f (SHeap x l r) = SHeap (f x) (fmap f l) (fmap f r)
48
49instance Functor MSHeap where
50        fmap _ Nil = Nil
51        fmap f (SJust t) = SJust (fmap f t)
52
53instance Functor SkewQueue where
54        fmap f (SkewQueue n t) = SkewQueue n (fmap f t)
55
56unions :: Ord a => [SkewQueue a] -> SkewQueue a
57unions = left 0 []
58        where   left n ts0 (SkewQueue n' t':ts) = n `seq` case t' of
59                        Nil     -> left n ts0 ts
60                        SJust t' -> left (n + n') (t':ts0) ts
61                left n ts0 [] = SkewQueue n (melds ts0)
62
63fromList :: Ord a => [a] -> SkewQueue a
64fromList xs = SkewQueue (length xs) (melds (map tip xs))
65
66{-# INLINE toAscList #-}
67toAscList :: Ord a => SkewQueue a -> [a]
68toAscList q = build (\ c n -> foldrAsc c n q)
69
70foldrAsc :: Ord a => (a -> b -> b) -> b -> SkewQueue a -> b
71foldrAsc f z (SkewQueue _ t) = ascFoldR t where
72        ascFoldR Nil = z
73        ascFoldR (SJust (SHeap x l r)) = x `f` ascFoldR (meld' (<=) l r)
74
75melds :: Ord a => [SHeap a] -> MSHeap a
76melds [] = Nil
77melds [t] = SJust t
78melds (t1:t2:ts) = melds (t1 `cat` t2 : melds' ts) where
79        cat = meld (<=)
80        melds' (t1:t2:ts) = t1 `cat` t2 : melds' ts
81        melds' ts = ts
82
83meld :: (a -> a -> Bool) -> SHeap a -> SHeap a -> SHeap a
84meld (<=) t1@(SHeap x1 l1 r1) t2@(SHeap x2 l2 r2)
85        | x1 <= x2      = SHeap x1 (meld' (<=) r1 (SJust t2)) l1
86        | otherwise     = SHeap x2 (meld' (<=) r2 (SJust t1)) l2
87
88meld' :: (a -> a -> Bool) -> MSHeap a -> MSHeap a -> MSHeap a
89meld' _ Nil t2 = t2
90meld' _ t1 Nil = t1
91meld' (<=) (SJust t1) (SJust t2) = SJust (meld (<=) t1 t2)
92
93{-# INLINE toList #-}
94toList :: SkewQueue a -> [a]
95toList q = build (\ c nil -> foldr c nil q)