commit 9ff044682fb3e49975c343940dadd3fdc8b09a67
parent 805baf63a74c43052fd80c0a6a43a32e6ad7c16b
Author: Jared Tobin <jared@jtobin.io>
Date: Fri, 31 Mar 2023 09:14:13 +0400
Miscellaneous additions.
Diffstat:
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
+
