commit9ff044682fb3e49975c343940dadd3fdc8b09a67parent805baf63a74c43052fd80c0a6a43a32e6ad7c16bAuthor:Jared Tobin <jared@jtobin.io>Date:Fri, 31 Mar 2023 09:14:13 +0400 Miscellaneous additions.Diffstat:

A | bench/Main.hs | | | 4 | ++++ |

M | lib/Okasaki/Heap/Binomial.hs | | | 55 | +++++++++++++++++++++++++++++++++++++++++++++---------- |

A | lib/Okasaki/Heap/Leftist/CPS.hs | | | 176 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |

M | okasaki.cabal | | | 16 | ++++++++++++++++ |

A | test/Heap/Binomial.hs | | | 24 | ++++++++++++++++++++++++ |

5 files changed, 265 insertions(+), 10 deletions(-)diff --git a/bench/Main.hs b/bench/Main.hs@@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = pure ()diff --git a/lib/Okasaki/Heap/Binomial.hs b/lib/Okasaki/Heap/Binomial.hs@@ -1,15 +1,21 @@ {-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Okasaki.Heap.Binomial where import Data.Eq.Deriving (deriveEq1) import Data.Fix hiding (cata, ana, hylo) +import Data.Foldable (foldl') +import Data.Functor.Base (NonEmptyF(..)) import Data.Functor.Foldable +import Data.List.NonEmpty (NonEmpty(..), (<|)) +import qualified Data.List.NonEmpty as NE import Text.Show.Deriving -data TreeF a r = NodeF Int a [Tree a] - deriving (Functor, Foldable, Traversable) +data TreeF a r = NodeF !Int a [r] + deriving (Eq, Show, Functor, Foldable, Traversable) type Tree a = Fix (TreeF a) @@ -17,6 +23,7 @@ $(deriveShow1 ''TreeF) $(deriveEq1 ''TreeF) newtype Heap a = Heap [Tree a] + deriving Show lef :: Heap a lef = Heap [] @@ -25,19 +32,47 @@ nod :: Int -> a -> [Tree a] -> Tree a nod r a t = Fix (NodeF r a t) lin :: Ord a => Tree a -> Tree a -> Tree a -lin s@(project -> NodeF r a c) t@(project -> NodeF _ b d) +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) ran :: Tree a -> Int ran (project -> NodeF r _ _) = r -pat :: Ord a => Tree a -> Heap a -> Heap a -pat s (Heap ts) = Heap $ case project ts of - Nil -> embed (Cons s (embed Nil)) - Cons h t - | ran s < ran h -> embed (Cons s ts) - | otherwise -> embed (Cons (lin s h) t) +-- arbitrary recursion +-- +-- NB can't figure out how to express what seems like a very trivial recursion +-- scheme +-- +-- we want to fold the list top-down and then recurse on the *entire* +-- folded list, not the rest of it. i guess this is the issue. +-- +pet :: Ord a => Tree a -> Heap a -> Heap a +pet a (Heap as) = Heap (loop a as) where + loop s ts = case ts of + [] -> pure s + (h : t) + | ran s < ran h -> s : ts + | otherwise -> loop (lin s h) t put :: Ord a => a -> Heap a -> Heap a -put a = pat (nod 0 a (embed Nil)) +put a (Heap as) = pet a ((nod 0 a []) :| as) + +poot :: Ord a => a -> Heap a -> Heap a +poot a = pet (nod 0 a []) + +mer :: Ord a => Heap a -> Heap a -> Heap a +mer (Heap l) (Heap r) = Heap (apo lag (l, r)) where + lag (p, q) = case (project p, project q) of + (u, Nil) -> fmap Left u + (Nil, u) -> fmap Left u + (Cons h s, Cons i t) + | ran h < ran i -> Cons h (Right (s, r)) + | ran i < ran h -> Cons i (Right (l, t)) + | otherwise -> Cons (lin h i) (Right (s, t)) + -- NB "pat (lin h i) (Right (s, t))" + -- + -- pat has not been properly applied in the above case, but possible + -- things are merged correctly. test that ranks are strictly + -- increasing, etc.diff --git a/lib/Okasaki/Heap/Leftist/CPS.hs b/lib/Okasaki/Heap/Leftist/CPS.hs@@ -0,0 +1,176 @@ +{-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Okasaki.Heap.Leftist.CPS where + +import Data.Fix hiding (cata, ana, hylo) +import Data.Functor.Foldable +import Data.Monoid +import Okasaki.Orphans () + +-- NB arguably better to use induction +-- +-- exercise 3.1: prove right spine contains at most floor(log(n + 1)) +-- elements +-- +-- * observe that rightmost-weighted binary tree satisfying leftist +-- property is balanced +-- * observe that right spine length is maximized in balanced case +-- * observe that tree has depth floor(log(n + 1)) in balanced case. +-- * therefore, right spine has at most floor(log(n + 1)) elements. +-- (QED) + +newtype HeapF a r = HeapF (forall e. e -> (Sum Int -> a -> r -> r -> e) -> e) + deriving Functor + +type Heap a = Fix (HeapF a) + +lefF :: HeapF a r +lefF = HeapF const + +lef :: Heap a +lef = Fix lefF + +oneF :: a -> HeapF a (Heap b) +oneF x = HeapF (\_ c -> c 1 x lef lef) + +one :: a -> Heap a +one = Fix . oneF + +ran :: Heap a -> Sum Int +ran (project -> HeapF c) = c mempty b where + b r _ _ _ = r + +-- mer :: Ord a => Heap a -> Heap a -> Heap a +-- mer l = sor . mix l + +-- mix :: Ord a => Heap a -> Heap a -> Heap a +-- mix l r = 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 _ m c d, NodeF _ n e f) +-- | m <= n -> NodeF (ran d <> ran b) m (Left c) (Right (d, b)) +-- | otherwise -> NodeF (ran a <> ran f) n (Left e) (Right (a, f)) + +-- sor :: Heap a -> Heap a +-- sor = cata $ \case +-- LeafF -> lef +-- NodeF _ m l r -> set m l r +-- +-- set :: a -> Heap a -> Heap a -> Heap a +-- set m l r +-- | ran l >= ran r = Fix (NodeF (1 <> ran r) m l r) +-- | otherwise = Fix (NodeF (1 <> ran l) m r l) +-- +-- put :: Ord a => a -> Heap a -> Heap a +-- put x = mer (one x) +-- +-- -- exercise 3.2: direct insert +-- pat :: Ord a => a -> Heap a -> Heap a +-- pat x h = case project h of +-- LeafF -> one x +-- NodeF _ m a b -> +-- let (u, l) +-- | x <= m = (x, m) +-- | otherwise = (m, x) +-- +-- in uncurry (set u) (pot l a b) +-- where +-- pot :: Ord a => a -> Heap a -> Heap a -> (Heap a, Heap a) +-- pot l a b = case (project a, project b) of +-- (_, LeafF) -> (a, one l) +-- (LeafF, _) -> (b, one l) +-- (NodeF _ c _ _, NodeF _ d _ _) +-- | c > d -> (pat l a, b) +-- | otherwise -> (a, pat l b) +-- +-- bot :: Heap a -> Maybe a +-- bot 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 +-- +-- -- exercise 3.3: hylo gas +-- data BinF a r = +-- EmpF +-- | SinF !a +-- | BinF r r +-- deriving Functor +-- +-- gas :: Ord a => [a] -> Heap a +-- gas = hylo alg lag where +-- lag s = case project s of +-- Nil -> EmpF +-- Cons h [] -> SinF h +-- Cons {} -> +-- let (l, r) = splitAt (length s `div` 2) s +-- in BinF l r +-- +-- alg = \case +-- EmpF -> lef +-- SinF a -> one a +-- BinF l r -> mer l r +-- +-- wyt :: Heap a -> Int +-- wyt = getSum . cata alg where +-- alg = \case +-- LeafF -> mempty +-- NodeF _ _ l r -> 1 <> l <> r +-- +-- -- reference +-- +-- nodF :: a -> Heap a -> Heap a -> HeapF a (Heap a) +-- nodF x l r +-- | ran l >= ran r = NodeF (1 <> ran r) x l r +-- | otherwise = NodeF (1 <> ran l) x r l +-- +-- nod :: a -> Heap a -> Heap a -> Heap a +-- nod x l r = Fix (nodF x l r) +-- +-- mux :: Ord a => Heap a -> Heap a -> Heap a +-- mux l r = case (project l, project r) of +-- (_, LeafF) -> l +-- (LeafF, _) -> r +-- (NodeF _ m a b, NodeF _ n c d) +-- | m <= n -> nod m a (mux b r) +-- | otherwise -> nod n c (mux l d) +-- +-- oil :: Ord a => [a] -> Heap a +-- oil = cata $ \case +-- Nil -> lef +-- Cons h t -> put h t +-- +-- -- test +-- +-- -- (2) 1 +-- -- | \ +-- -- (1) 2 (1) 3 +-- -- | \ | \ +-- -- L L (1) 4 L +-- -- | \ +-- -- (1) 5 L +-- -- | \ +-- -- L L +-- +-- test0 :: Heap Int +-- test0 = gas [1..5] +-- +-- -- (1) 1 +-- -- | \ +-- -- (1) 2 L +-- -- | \ +-- -- (1) 3 L +-- -- | \ +-- -- (1) 4 L +-- -- | \ +-- -- (1) 5 L +-- -- | \ +-- -- L L +-- +-- test1 :: Heap Int +-- test1 = oil [1..5]diff --git a/okasaki.cabal b/okasaki.cabal@@ -34,8 +34,10 @@ library , Okasaki.Tree.CPS build-depends: base + , comonad , data-fix , deriving-compat + , free , recursion-schemes Test-suite tests @@ -66,3 +68,17 @@ Test-suite tests , recursion-schemes , tasty , tasty-quickcheck + +benchmark bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + default-language: Haskell2010 + ghc-options: + -rtsopts -O2 + build-depends: + base + , criterion + , deepseq + , okasaki +diff --git a/test/Heap/Binomial.hs b/test/Heap/Binomial.hs@@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Heap.Binomial where + +import qualified Okasaki.Heap.Binomial as B +import Test.QuickCheck +import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck (testProperty) + +-- binomial trees, heaps both have invariants + +-- tree + +-- * tree of rank r should have 2 ^ r nodes +-- * tree of rank r isbinomial a node with r children, with each child +-- t_i having rank r - i +-- * children are maintained in decreasing order of rank +-- * elements are stored in heap order + +-- heap + +-- * no two trees have same rank +-- * list is in increasing order of rank +