okasaki

commit e95b660dcc16ee7033490c0b2cb714308fa87a5d
parent f857cb080adef27071a1817b6e49a8249d41a531
Author: Jared Tobin <jared@jtobin.io>
Date:   Wed,  5 Apr 2023 21:28:22 +0400

Remove redundant binomial heap rank info.

Diffstat:
M
lib/Okasaki/Heap/Binomial.hs
 | 
49
++++++++++++++++++++++++++++---------------------

1 file changed, 28 insertions(+), 21 deletions(-)
diff --git a/lib/Okasaki/Heap/Binomial.hs b/lib/Okasaki/Heap/Binomial.hs
@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Okasaki.Heap.Binomial where
@@ -7,11 +8,12 @@ import Data.Eq.Deriving (deriveEq1)
 import Data.Fix hiding (cata, ana, hylo)
 import Data.Foldable (toList)
 import Data.Functor.Foldable
+import Data.List (sortOn)
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Maybe (fromMaybe)
 import Text.Show.Deriving
 
-data TreeF a r = NodeF !Int a [r]
+data TreeF a r = NodeF a [r]
   deriving (Eq, Show, Functor, Foldable, Traversable)
 
 type Tree a = Fix (TreeF a)
@@ -19,28 +21,32 @@ type Tree a = Fix (TreeF a)
 $(deriveShow1 ''TreeF)
 $(deriveEq1 ''TreeF)
 
-newtype Heap a = Heap [Tree a]
+-- exercise 3.6: remove redundant rank info
+data Bush a = Bush {-# UNPACK #-} !Int !(Tree a)
+  deriving Show
+
+newtype Heap a = Heap [Bush a]
   deriving Show
 
 lef :: Heap a
 lef = Heap []
 
-nod :: Int -> a -> [Tree a] -> Tree a
-nod r a t = Fix (NodeF r a t)
+nod :: a -> [Tree a] -> Tree a
+nod a t = Fix (NodeF a t)
 
-lin :: Ord a => Tree a -> Tree a -> Tree a
-lin s@(project -> NodeF r a c) t@(project -> NodeF q b d)
-  | r /= q    = error "(okasaki, binomial): internal error"
-  | a <= b    = nod (succ r) a (t : c)
-  | otherwise = nod (succ r) b (s : d)
+lin :: Ord a => Bush a -> Bush a -> Bush a
+lin (Bush i s@(project -> NodeF a c)) (Bush j t@(project -> NodeF b d))
+  | i /= j    = error "(okasaki, binomial): internal error"
+  | a <= b    = Bush (succ i) (nod a (t : c))
+  | otherwise = Bush (succ i) (nod b (s : d))
 
-ran :: Tree a -> Int
-ran (project -> NodeF r _ _) = r
+ran :: Bush a -> Int
+ran (Bush i _) = i
 
-roo :: Tree a -> a
-roo (project -> NodeF _ a _) = a
+roo :: Bush a -> a
+roo (Bush _ (project -> NodeF a _)) = a
 
-pet :: Ord a => Tree a -> [Tree a] -> [Tree a]
+pet :: Ord a => Bush a -> [Bush a] -> [Bush a]
 pet a as = toList $ cata alg as (a :| as)
   where
     alg l n@(t :| ts) = case l of
@@ -51,7 +57,7 @@ pet a as = toList $ cata alg as (a :| as)
 
 put :: Ord a => a -> Heap a -> Heap a
 put a (Heap as) = Heap $
-  pet (nod 0 a []) as
+  pet (Bush 0 (nod a [])) as
 
 mer :: Ord a => Heap a -> Heap a -> Heap a
 mer (Heap a) (Heap b) = Heap $ mor a b where
@@ -63,7 +69,7 @@ mer (Heap a) (Heap b) = Heap $ mor a b where
       | ran i < ran h -> i : mor l s
       | otherwise     -> pet (lin h i) (mor t s)
 
-out :: Ord a => Heap a -> Maybe (Tree a, Heap a)
+out :: Ord a => Heap a -> Maybe (Bush a, Heap a)
 out (Heap as) = case as of
   []       -> Nothing
   (h : []) -> Just (h, lef)
@@ -79,20 +85,21 @@ bot h = do
   pure $ roo a
 
 -- exercise 3.5: direct bot
-bed :: Heap a -> Maybe a
-bed (Heap a) = case a of
+bed :: Ord a => Heap a -> Maybe a
+bed (Heap a) = case sortOn roo a of
   []      -> Nothing
   (h : _) -> Just (roo h)
 
 cut :: Ord a => Heap a -> Heap a
 cut h = fromMaybe lef $ do
-  (project -> NodeF _ _ s, t) <- out h
-  pure $ mer (Heap (reverse s)) t
+  (Bush i (project -> NodeF _ s), t) <- out h
+  let p = fmap (Bush (pred i)) s
+  pure $ mer (Heap (reverse p)) t
 
 -- reference
 
 -- arbitrary recursion
-pyt :: Ord a => Tree a -> Heap a -> Heap a
+pyt :: Ord a => Bush a -> Heap a -> Heap a
 pyt a (Heap as) = Heap (loop a as) where
   loop s ts = case ts of
     [] -> pure s