okasaki

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

Class.hs (2931B)

      1 {-# OPTIONS_GHC -Wall #-}
      2 
      3 module Okasaki.Heap.Class where
      4 
      5 import Data.Kind (Type)
      6 import Data.Fix (Fix(..))
      7 import qualified Okasaki.Heap.Binomial as B
      8 import qualified Okasaki.Heap.Leftist as L
      9 import qualified Okasaki.Heap.Leftist.Weighted as W
     10 
     11 -- exercise 3.7: generic explicit-min heap
     12 class Heap (h :: Type -> Type) where
     13   data Pile h :: Type -> Type
     14 
     15   via :: Ord a => h a -> Pile h a
     16   bot :: Ord a => Pile h a -> Maybe a
     17   put :: Ord a => a -> Pile h a -> Pile h a
     18   cut :: Ord a => Pile h a -> Pile h a
     19   mer :: Ord a => Pile h a -> Pile h a -> Pile h a
     20   out :: Pile h a -> h a
     21 
     22 instance Heap B.Heap where
     23   data Pile B.Heap a =
     24       Nib
     25     | Bin a (B.Heap a)
     26     deriving Show
     27 
     28   via = \case
     29     B.Heap [] -> Nib
     30     h -> let b = B.bot h
     31          in  case b of
     32                Nothing -> Nib
     33                Just a  -> Bin a h
     34 
     35   bot = \case
     36     Nib     -> Nothing
     37     Bin a _ -> Just a
     38 
     39   put a = \case
     40     Nib -> Bin a (B.put a B.lef)
     41     Bin m h
     42       | a < m     -> Bin a (B.put a h)
     43       | otherwise -> Bin m (B.put a h)
     44 
     45   cut h = case h of
     46     Nib -> Nib
     47     Bin _ t ->
     48       let c = B.cut t
     49       in  case B.bot c of
     50             Nothing -> Nib
     51             Just a  -> Bin a c
     52 
     53   mer h l = case (h, l) of
     54     (Nib, _) -> l
     55     (_, Nib) -> h
     56     (Bin a s, Bin b t) -> Bin (min a b) (B.mer s t)
     57 
     58   out = \case
     59     Nib -> B.lef
     60     Bin _ h -> h
     61 
     62 instance Heap L.Heap where
     63   data Pile L.Heap a =
     64       Nil
     65     | Lib a (L.Heap a)
     66     deriving Show
     67 
     68   via = \case
     69     L.Heap (Fix L.LeafF) -> Nil
     70     h -> let b = L.bot h
     71          in  case b of
     72                Nothing -> Nil
     73                Just a  -> Lib a h
     74 
     75   bot = \case
     76     Nil     -> Nothing
     77     Lib a _ -> Just a
     78 
     79   put a = \case
     80     Nil -> Lib a (L.put a L.lef)
     81     Lib m h
     82       | a < m     -> Lib a (L.put a h)
     83       | otherwise -> Lib m (L.put a h)
     84 
     85   cut h = case h of
     86     Nil -> Nil
     87     Lib _ t ->
     88       let c = L.cut t
     89       in  case L.bot c of
     90             Nothing -> Nil
     91             Just a  -> Lib a c
     92 
     93   mer h l = case (h, l) of
     94     (Nil, _) -> l
     95     (_, Nil) -> h
     96     (Lib a s, Lib b t) -> Lib (min a b) (L.mer s t)
     97 
     98   out = \case
     99     Nil -> L.lef
    100     Lib _ h -> h
    101 
    102 instance Heap W.Heap where
    103   data Pile W.Heap a =
    104       Net
    105     | Win a (W.Heap a)
    106     deriving Show
    107 
    108   via = \case
    109     W.Heap (Fix W.LeafF) -> Net
    110     h -> let b = W.bot h
    111          in  case b of
    112                Nothing -> Net
    113                Just a  -> Win a h
    114 
    115   bot = \case
    116     Net     -> Nothing
    117     Win a _ -> Just a
    118 
    119   put a = \case
    120     Net -> Win a (W.put a W.lef)
    121     Win m h
    122       | a < m     -> Win a (W.put a h)
    123       | otherwise -> Win m (W.put a h)
    124 
    125   cut h = case h of
    126     Net -> Net
    127     Win _ t ->
    128       let c = W.cut t
    129       in  case W.bot c of
    130             Nothing -> Net
    131             Just a  -> Win a c
    132 
    133   mer h l = case (h, l) of
    134     (Net, _) -> l
    135     (_, Net) -> h
    136     (Win a s, Win b t) -> Win (min a b) (W.mer s t)
    137 
    138   out = \case
    139     Net -> W.lef
    140     Win _ h -> h
    141