okasaki

commit 657522b34361b0f2d89ae967cacdee7f4d42319e
parent 2326d315b77e448afe4a2f404411d0758cfc1e83
Author: Jared Tobin <jared@jtobin.io>
Date:   Fri,  7 Apr 2023 15:15:46 +0400

Add newtype to weight-biased leftist heap.

Diffstat:
M
lib/Okasaki/Heap/Class.hs
 | 
44
+++++++++++++++++++++++++++++++++++++++++---
M
lib/Okasaki/Heap/Leftist/Weighted.hs
 | 
39
+++++++++++++++++++++++++--------------

2 files changed, 66 insertions(+), 17 deletions(-)
diff --git a/lib/Okasaki/Heap/Class.hs b/lib/Okasaki/Heap/Class.hs
@@ -6,9 +6,7 @@ import Data.Kind (Type)
 import Data.Fix (Fix(..))
 import qualified Okasaki.Heap.Binomial as B
 import qualified Okasaki.Heap.Leftist as L
-
--- NB needs to be newtyped to be made a proper instance
--- import qualified Okasaki.Heap.Leftist.Weighted as W
+import qualified Okasaki.Heap.Leftist.Weighted as W
 
 -- exercise 3.7: generic explicit-min heap
 class Heap (h :: Type -> Type) where
@@ -101,3 +99,43 @@ instance Heap L.Heap where
     Nil -> L.lef
     Lib _ h -> h
 
+instance Heap W.Heap where
+  data Pile W.Heap a =
+      Net
+    | Win a (W.Heap a)
+    deriving Show
+
+  via = \case
+    W.Heap (Fix W.LeafF) -> Net
+    h -> let b = W.bot h
+         in  case b of
+               Nothing -> Net
+               Just a  -> Win a h
+
+  bot = \case
+    Net     -> Nothing
+    Win a _ -> Just a
+
+  put a = \case
+    Net -> Win a (W.put a W.lef)
+    Win m h
+      | a < m     -> Win a (W.put a h)
+      | otherwise -> Win m (W.put a h)
+
+  cut h = case h of
+    Net -> Net
+    Win _ t ->
+      let c = W.cut t
+      in  case W.bot c of
+            Nothing -> Net
+            Just a  -> Win a c
+
+  mer h l = case (h, l) of
+    (Net, _) -> l
+    (_, Net) -> h
+    (Win a s, Win b t) -> Win (min a b) (W.mer s t)
+
+  out = \case
+    Net -> W.lef
+    Win _ h -> h
+
diff --git a/lib/Okasaki/Heap/Leftist/Weighted.hs b/lib/Okasaki/Heap/Leftist/Weighted.hs
@@ -3,7 +3,7 @@
 
 module Okasaki.Heap.Leftist.Weighted (
     HeapF(..)
-  , Heap
+  , Heap(..)
 
   , lef
   , one
@@ -14,6 +14,8 @@ module Okasaki.Heap.Leftist.Weighted (
   , siz
   , wyt
 
+  , mer
+
   , oil
   , gas
   ) where
@@ -38,35 +40,44 @@ data HeapF a r =
 $(deriveShow1 ''HeapF)
 $(deriveEq1 ''HeapF)
 
-type Heap a = Fix (HeapF a)
+type Slew a = Fix (HeapF a)
+
+newtype Heap a = Heap (Fix (HeapF a))
+  deriving Show
 
 lef :: Heap a
-lef = Fix LeafF
+lef = Heap (Fix LeafF)
+
+uno :: a -> Slew a
+uno x = Fix (NodeF 1 x (Fix LeafF) (Fix LeafF))
 
 one :: a -> Heap a
-one x = Fix (NodeF 1 x lef lef)
+one x = Heap (uno x)
 
 siz :: Heap a -> Sum Int
-siz h = case project h of
+siz (Heap h) = case project h of
   LeafF -> mempty
   NodeF r _ _ _ -> r
 
-wyt :: Heap a -> Sum Int
-wyt = cata $ \case
+tax :: Slew a -> Sum Int
+tax = cata $ \case
   LeafF         -> mempty
   NodeF _ _ l r -> 1 <> l <> r
 
+wyt :: Heap a -> Sum Int
+wyt (Heap h) = tax h
+
 mer :: Ord a => Heap a -> Heap a -> Heap a
-mer l r = apo lag (l, r) where
+mer (Heap l) (Heap r) = Heap (apo lag (l, r)) where
   lag (a, b) = case (project a, project b) of
     (c, LeafF) -> fmap Left c
     (LeafF, d) -> fmap Left d
     (NodeF p m c d, NodeF q n e f)
-      | m <= n && wyt c >= (wyt b <> wyt d) ->
+      | m <= n && tax c >= (tax b <> tax d) ->
           NodeF (p <> q) m (Left c) (Right (d, b))
       | m <= n ->
           NodeF (p <> q) m (Right (d, b)) (Left c)
-      | m > n && wyt e >= (wyt a <> wyt f) ->
+      | m > n && tax e >= (tax a <> tax f) ->
           NodeF (p <> q) n (Left e) (Right (a, f))
       | otherwise ->
           NodeF (p <> q) n (Right (a, f)) (Left e)
@@ -75,14 +86,14 @@ put :: Ord a => a -> Heap a -> Heap a
 put x = mer (one x)
 
 bot :: Heap a -> Maybe a
-bot h = case project h of
+bot (Heap h) = case project h of
   LeafF -> Nothing
   NodeF _ b _ _ -> Just b
 
 cut :: Ord a => Heap a -> Heap a
-cut h = case project h of
-  LeafF -> h
-  NodeF _ _ l r -> mer l r
+cut (Heap h) = case project h of
+  LeafF -> Heap h
+  NodeF _ _ l r -> mer (Heap l) (Heap r)
 
 data BinF a r =
     EmpF