okasaki

Okasaki's Purely Functional Data Structures
git clone git://git.jtobin.io/okasaki.git
Log | Files | Refs | LICENSE

Weighted.hs (2820B)

      1 {-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-}
      2 {-# LANGUAGE TemplateHaskell #-}
      3 
      4 module Okasaki.Heap.Leftist.Weighted (
      5     HeapF(..)
      6   , Heap(..)
      7 
      8   , lef
      9   , one
     10   , put
     11   , bot
     12   , cut
     13 
     14   , siz
     15   , wyt
     16 
     17   , mer
     18 
     19   , oil
     20   , gas
     21   ) where
     22 
     23 import Data.Eq.Deriving (deriveEq1)
     24 import Data.Fix hiding (cata, ana, hylo)
     25 import Data.Functor.Foldable
     26 import Data.Monoid
     27 import Okasaki.Orphans ()
     28 import Text.Show.Deriving
     29 
     30 -- todo
     31 --
     32 -- * prove right-spine of weight-biased leftist heap contains at most
     33 --   floor(log(n + 1)) elements
     34 
     35 data HeapF a r =
     36     LeafF
     37   | NodeF !(Sum Int) !a r r
     38   deriving (Eq, Functor, Foldable, Traversable, Show)
     39 
     40 $(deriveShow1 ''HeapF)
     41 $(deriveEq1 ''HeapF)
     42 
     43 type Slew a = Fix (HeapF a)
     44 
     45 newtype Heap a = Heap (Fix (HeapF a))
     46   deriving Show
     47 
     48 lef :: Heap a
     49 lef = Heap (Fix LeafF)
     50 
     51 uno :: a -> Slew a
     52 uno x = Fix (NodeF 1 x (Fix LeafF) (Fix LeafF))
     53 
     54 one :: a -> Heap a
     55 one x = Heap (uno x)
     56 
     57 siz :: Heap a -> Sum Int
     58 siz (Heap h) = case project h of
     59   LeafF -> mempty
     60   NodeF r _ _ _ -> r
     61 
     62 tax :: Slew a -> Sum Int
     63 tax = cata $ \case
     64   LeafF         -> mempty
     65   NodeF _ _ l r -> 1 <> l <> r
     66 
     67 wyt :: Heap a -> Sum Int
     68 wyt (Heap h) = tax h
     69 
     70 mer :: Ord a => Heap a -> Heap a -> Heap a
     71 mer (Heap l) (Heap r) = Heap (apo lag (l, r)) where
     72   lag (a, b) = case (project a, project b) of
     73     (c, LeafF) -> fmap Left c
     74     (LeafF, d) -> fmap Left d
     75     (NodeF p m c d, NodeF q n e f)
     76       | m <= n && tax c >= (tax b <> tax d) ->
     77           NodeF (p <> q) m (Left c) (Right (d, b))
     78       | m <= n ->
     79           NodeF (p <> q) m (Right (d, b)) (Left c)
     80       | m > n && tax e >= (tax a <> tax f) ->
     81           NodeF (p <> q) n (Left e) (Right (a, f))
     82       | otherwise ->
     83           NodeF (p <> q) n (Right (a, f)) (Left e)
     84 
     85 put :: Ord a => a -> Heap a -> Heap a
     86 put x = mer (one x)
     87 
     88 bot :: Heap a -> Maybe a
     89 bot (Heap h) = case project h of
     90   LeafF -> Nothing
     91   NodeF _ b _ _ -> Just b
     92 
     93 cut :: Ord a => Heap a -> Heap a
     94 cut (Heap h) = case project h of
     95   LeafF -> Heap h
     96   NodeF _ _ l r -> mer (Heap l) (Heap r)
     97 
     98 data BinF a r =
     99     EmpF
    100   | SinF !a
    101   | BinF r r
    102   deriving Functor
    103 
    104 gas :: Ord a => [a] -> Heap a
    105 gas = hylo alg lag where
    106   lag s = case project s of
    107     Nil        -> EmpF
    108     Cons h []  -> SinF h
    109     Cons {}    ->
    110       let (l, r) = splitAt (length s `div` 2) s
    111       in  BinF l r
    112 
    113   alg = \case
    114     EmpF     -> lef
    115     SinF a   -> one a
    116     BinF l r -> mer l r
    117 
    118 oil :: Ord a => [a] -> Heap a
    119 oil = cata $ \case
    120   Nil      -> lef
    121   Cons h t -> put h t
    122 
    123 -- test
    124 
    125 -- (5) 1
    126 --   |      \
    127 -- (3) 3   (1) 2
    128 --   |  \    | \
    129 -- (2) 4 L   L  L
    130 --   |  \
    131 -- (1) 5 L
    132 --   |  \
    133 --   L   L
    134 
    135 test0 :: Heap Int
    136 test0 = gas [1..5]
    137 
    138 -- (5) 1
    139 --   |   \
    140 -- (4) 2  L
    141 --   |   \
    142 -- (3) 3  L
    143 --   |   \
    144 -- (2) 4  L
    145 --   |   \
    146 -- (1) 5  L
    147 --   |   \
    148 --   L    L
    149 
    150 test1 :: Heap Int
    151 test1 = oil [1..5]