okasaki

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

Leftist.hs (3977B)

      1 {-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-}
      2 {-# LANGUAGE TemplateHaskell #-}
      3 
      4 module Okasaki.Heap.Leftist (
      5     HeapF(..)
      6   , Heap(..)
      7 
      8   , lef
      9   , one
     10   , put
     11   , pat
     12   , bot
     13   , cut
     14   , wyt
     15 
     16   , sor
     17   , set
     18   , ran
     19   , mer
     20 
     21   , oil
     22   , gas
     23   ) where
     24 
     25 import Data.Eq.Deriving (deriveEq1)
     26 import Data.Fix hiding (cata, ana, hylo)
     27 import Data.Functor.Foldable
     28 import Data.Monoid
     29 import Okasaki.Orphans ()
     30 import Text.Show.Deriving
     31 
     32 -- NB arguably better to use induction
     33 --
     34 -- exercise 3.1: prove right spine contains at most floor(log(n + 1))
     35 --               elements
     36 --
     37 -- * observe that rightmost-weighted binary tree satisfying leftist
     38 --   property is balanced
     39 -- * observe that right spine length is maximized in balanced case
     40 -- * observe that tree has depth floor(log(n + 1)) in balanced case.
     41 -- * therefore, right spine has at most floor(log(n + 1)) elements.
     42 --   (QED)
     43 
     44 data HeapF a r =
     45     LeafF
     46   | NodeF !(Sum Int) !a r r
     47   deriving (Eq, Functor, Foldable, Traversable, Show)
     48 
     49 $(deriveShow1 ''HeapF)
     50 $(deriveEq1 ''HeapF)
     51 
     52 type Slew a = Fix (HeapF a)
     53 
     54 newtype Heap a = Heap (Slew a)
     55   deriving Show
     56 
     57 lef :: Heap a
     58 lef = Heap (Fix LeafF)
     59 
     60 uno :: a -> Slew a
     61 uno x = Fix (NodeF 1 x (Fix LeafF) (Fix LeafF))
     62 
     63 one :: a -> Heap a
     64 one x = Heap (uno x)
     65 
     66 nar :: Slew a -> Sum Int
     67 nar h = case project h of
     68   LeafF -> mempty
     69   NodeF r _ _ _ -> r
     70 
     71 ran :: Heap a -> Sum Int
     72 ran (Heap h) = nar h
     73 
     74 mer :: Ord a => Heap a -> Heap a -> Heap a
     75 mer l = sor . mix l
     76 
     77 mix :: Ord a => Heap a -> Heap a -> Heap a
     78 mix (Heap l) (Heap r) = Heap (apo lag (l, r)) where
     79   lag (a, b) = case (project a, project b) of
     80     (c, LeafF) -> fmap Left c
     81     (LeafF, d) -> fmap Left d
     82     (NodeF _ m c d, NodeF _ n e f)
     83       | m <= n    -> NodeF (nar d <> nar b) m (Left c) (Right (d, b))
     84       | otherwise -> NodeF (nar a <> nar f) n (Left e) (Right (a, f))
     85 
     86 sor :: Heap a -> Heap a
     87 sor (Heap h) = Heap (cata alg h) where
     88   alg = \case
     89     LeafF -> Fix LeafF
     90     NodeF _ m l r -> set m l r
     91 
     92 set :: a -> Slew a -> Slew a -> Slew a
     93 set m l r
     94   | nar l >= nar r = Fix (NodeF (1 <> nar r) m l r)
     95   | otherwise      = Fix (NodeF (1 <> nar l) m r l)
     96 
     97 put :: Ord a => a -> Heap a -> Heap a
     98 put x = mer (one x)
     99 
    100 -- exercise 3.2: direct insert
    101 pat :: Ord a => a -> Heap a -> Heap a
    102 pat p (Heap t) = Heap (pet p t) where
    103   pet x h = case project h of
    104     LeafF -> uno x
    105     NodeF _ m a b ->
    106       let (u, l)
    107             | x <= m    = (x, m)
    108             | otherwise = (m, x)
    109 
    110       in  uncurry (set u) (pot l a b)
    111 
    112   pot :: Ord a => a -> Slew a -> Slew a -> (Slew a, Slew a)
    113   pot l a b = case (project a, project b) of
    114     (_, LeafF) -> (a, uno l)
    115     (LeafF, _) -> (b, uno l)
    116     (NodeF _ c _ _, NodeF _ d _ _)
    117       | c > d     -> (pet l a, b)
    118       | otherwise -> (a, pet l b)
    119 
    120 bot :: Heap a -> Maybe a
    121 bot (Heap h) = case project h of
    122   LeafF -> Nothing
    123   NodeF _ b _ _ -> Just b
    124 
    125 cut :: Ord a => Heap a -> Heap a
    126 cut (Heap h) = case project h of
    127   LeafF -> Heap h
    128   NodeF _ _ l r -> mer (Heap l) (Heap r)
    129 
    130 -- exercise 3.3: hylo gas
    131 data BinF a r =
    132     EmpF
    133   | SinF !a
    134   | BinF r r
    135   deriving Functor
    136 
    137 gas :: Ord a => [a] -> Heap a
    138 gas = hylo alg lag where
    139   lag s = case project s of
    140     Nil        -> EmpF
    141     Cons h []  -> SinF h
    142     Cons {}    ->
    143       let (l, r) = splitAt (length s `div` 2) s
    144       in  BinF l r
    145 
    146   alg = \case
    147     EmpF     -> lef
    148     SinF a   -> one a
    149     BinF l r -> mer l r
    150 
    151 oil :: Ord a => [a] -> Heap a
    152 oil = cata $ \case
    153   Nil      -> lef
    154   Cons h t -> put h t
    155 
    156 wyt :: Heap a -> Int
    157 wyt (Heap h) = getSum (cata alg h) where
    158   alg = \case
    159     LeafF -> mempty
    160     NodeF _ _ l r -> 1 <> l <> r
    161 
    162 -- test
    163 
    164 -- (2) 1
    165 --   |     \
    166 -- (1) 2   (1) 3
    167 --   |  \    |    \
    168 --   L   L (1) 4   L
    169 --           |    \
    170 --         (1) 5   L
    171 --           |    \
    172 --           L     L
    173 
    174 test0 :: Heap Int
    175 test0 = gas [1..5]
    176 
    177 -- (1) 1
    178 --   |   \
    179 -- (1) 2  L
    180 --   |   \
    181 -- (1) 3  L
    182 --   |   \
    183 -- (1) 4  L
    184 --   |   \
    185 -- (1) 5  L
    186 --   |   \
    187 --   L    L
    188 
    189 test1 :: Heap Int
    190 test1 = oil [1..5]