Last active
August 4, 2025 14:28
-
-
Save LSLeary/87f6b079072e3996653bba48b6f5a111 to your computer and use it in GitHub Desktop.
A heap on poset keys. Neither the performance nor stability are good, but I doubt we can do much better.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE RoleAnnotations, DerivingStrategies, LambdaCase #-} | |
| module Heap ( | |
| Poset(..), Prefix(..), | |
| Heap, size, | |
| empty, singleton, | |
| insert, (<+>), fromList, | |
| pop, assocs, | |
| ) where | |
| -- base | |
| import Data.String (IsString(..)) | |
| import Control.Monad (guard) | |
| class Eq a => Poset a where | |
| (<|=|>) :: a -> a -> Maybe Ordering | |
| infix 5 <|=|> | |
| newtype Prefix a = Prefix [a] | |
| deriving newtype (Read, Show, Eq, Functor, Foldable) | |
| instance Eq a => Poset (Prefix a) where | |
| Prefix [ ] <|=|> Prefix [ ] = Just EQ | |
| Prefix [ ] <|=|> Prefix (_:_ ) = Just LT | |
| Prefix (_:_ ) <|=|> Prefix [ ] = Just GT | |
| Prefix (x:xs) <|=|> Prefix (y:ys) = do | |
| guard (x == y) | |
| Prefix xs <|=|> Prefix ys | |
| instance a ~ Char => IsString (Prefix a) where | |
| fromString = Prefix | |
| type role Heap nominal representational | |
| data Heap k a | |
| = Empty | |
| -- Invariants: The first field is the size of the heap | |
| -- No key in the child heaps is less than k | |
| | Branch {-# UNPACK #-} !Word !(Heap k a) !k a !(Heap k a) | |
| deriving Functor | |
| instance Poset k => Foldable (Heap k) where | |
| foldMap f h = foldMap f (snd <$> assocs h) | |
| length = fromIntegral . size | |
| size :: Heap k a -> Word | |
| size = \case | |
| Empty -> 0 | |
| Branch sz _ _ _ _ -> sz | |
| empty :: Heap k a | |
| empty = Empty | |
| singleton :: k -> a -> Heap k a | |
| singleton k x = Branch 1 Empty k x Empty | |
| insert :: Poset k => k -> a -> Heap k a -> Heap k a | |
| insert k x = \case | |
| Empty -> singleton k x | |
| Branch s l k' y r -> case k <|=|> k' of | |
| Just LT | size l < size r -> Branch (succ s) (insert k' y l) k x r | |
| | otherwise -> Branch (succ s) l k x (insert k' y r) | |
| _ | size l < size r -> Branch (succ s) (insert k x l) k' y r | |
| | otherwise -> Branch (succ s) l k' y (insert k x r) | |
| (<+>) :: Poset k => Heap k a -> Heap k a -> Heap k a | |
| h1 <+> h2 = case h1 of | |
| Empty -> h2 | |
| Branch s1 l1 k1 x1 r1 -> case h2 of | |
| Empty -> h1 | |
| Branch s2 l2 k2 x2 r2 -> case k1 <|=|> k2 of | |
| Nothing | s1 < s2 -> l1 <+> r1 <+> insert k1 x1 h2 | |
| | otherwise -> l2 <+> r2 <+> insert k2 x2 h1 | |
| Just LT -> insert k2 x2 (zipped k1 x1) | |
| _ -> insert k1 x1 (zipped k2 x2) | |
| where | |
| zipped k x = Branch (s1 + s2 - 1) (l1 <+> l2) k x (r1 <+> r2) | |
| infixr 6 <+> | |
| fromList :: Poset k => [(k, a)] -> Heap k a | |
| fromList = foldl' (flip $ uncurry insert) Empty | |
| pop :: Poset k => Heap k a -> Maybe (k, a, Heap k a) | |
| pop Empty = Nothing | |
| pop (Branch _ l k x r) = Just (k, x, l <+> r) | |
| assocs :: Poset k => Heap k a -> [(k, a)] | |
| assocs p = case pop p of | |
| Nothing -> [] | |
| Just (k, a, q) -> (k, a):assocs q |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment