commit 7b9f03d8c8d5c603f3965992101232a2118d0cf8
parent 463167df18c0f3b7abe9668755b818f6177c4132
Author: Jared Tobin <jared@jtobin.io>
Date: Thu, 9 Mar 2023 20:18:11 +0400
Misc bunch of stuff.
Diffstat:
6 files changed, 296 insertions(+), 17 deletions(-)
diff --git a/lib/Okasaki/Heap/Leftist.hs b/lib/Okasaki/Heap/Leftist.hs
@@ -0,0 +1,168 @@
+{-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Okasaki.Heap.Leftist (
+ HeapF(..)
+ , Heap
+
+ , lef
+ , one
+ , put
+ , bot
+ , cut
+
+ , oil
+ , gas
+ ) where
+
+import Data.Eq.Deriving (deriveEq1)
+import Data.Fix hiding (cata, ana, hylo)
+import Data.Functor.Foldable
+import Data.Monoid
+import Okasaki.Orphans ()
+import Text.Show.Deriving
+
+data HeapF a r =
+ LeafF
+ | NodeF !Int !a r r
+ deriving (Eq, Functor, Foldable, Traversable, Show)
+
+$(deriveShow1 ''HeapF)
+$(deriveEq1 ''HeapF)
+
+type Heap a = Fix (HeapF a)
+
+data BinF a r =
+ EmpF
+ | SinF !a
+ | BinF r r
+ deriving (Eq, Functor, Foldable, Traversable, Show)
+
+type Bin a = Fix (BinF a)
+
+lef :: Heap a
+lef = Fix LeafF
+
+one :: a -> Heap a
+one x = Fix (NodeF 1 x lef lef)
+
+ran :: Heap a -> Int
+ran h = case project h of
+ LeafF -> 0
+ NodeF 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 0 m (Left c) (Right (d, b))
+ | otherwise -> NodeF 0 n (Left e) (Right (a, f))
+
+sor :: Heap a -> Heap a
+sor = cata $ \case
+ LeafF -> lef
+ NodeF _ m l r
+ | ran l >= ran r -> Fix (NodeF (succ (ran r)) m l r)
+ | otherwise -> Fix (NodeF (succ (ran l)) m r l)
+
+put :: Ord a => a -> Heap a -> Heap a
+put x = mer (one x)
+
+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
+--
+-- NB * characterise worst-case performance formally
+-- * constructed heap differs from foldr'd put; confirm this is ok
+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
+
+spy :: Ord a => a -> Heap a -> Maybe a
+spy x = getLast . cata alg where
+ alg = \case
+ LeafF -> mempty
+ NodeF _ e l r
+ | x < e -> l
+ | otherwise -> Last (Just e) <> r
+
+haz :: Ord a => a -> Heap a -> Bool
+haz x t = case spy x t of
+ Nothing -> False
+ Just s -> s == x
+
+-- reference
+
+nodF :: a -> Heap a -> Heap a -> HeapF a (Heap a)
+nodF x l r
+ | ran l >= ran r = NodeF (succ (ran r)) x l r
+ | otherwise = NodeF (succ (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/lib/Okasaki/Stack.hs b/lib/Okasaki/Stack.hs
@@ -1,11 +1,5 @@
{-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
module Okasaki.Stack (
StackF(..)
diff --git a/lib/Okasaki/Stack/CPS.hs b/lib/Okasaki/Stack/CPS.hs
@@ -0,0 +1,113 @@
+{-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-}
+
+module Okasaki.Stack.CPS (
+ StackF(..)
+ , Stack
+ , nil
+ , put
+ , pop
+ , jab
+ , non
+
+ , map
+ , run
+
+ , gas
+ , tap
+ , cat
+ , suf
+ ) where
+
+import Data.Fix hiding (cata, ana, hylo)
+import Data.Functor.Foldable
+import Prelude hiding (map)
+
+newtype StackF a r = StackF (forall e. e -> (a -> r -> e) -> e)
+ deriving Functor
+
+type Stack a = Fix (StackF a)
+
+nilF :: StackF a r
+nilF = StackF const
+
+putF :: a -> r -> StackF a r
+putF h t = StackF (\_ c -> c h t)
+
+-- | O(1)
+nil :: Stack a
+nil = Fix nilF
+
+-- | O(1)
+put :: a -> Stack a -> Stack a
+put h t = Fix (putF h t)
+
+-- | O(1)
+pop :: Stack a -> Maybe (a, Stack a)
+pop (project -> StackF c) = c Nothing b where
+ b h t = Just (h, t)
+
+-- | O(1)
+non :: Stack a -> Bool
+non (project -> StackF c) = c True (\_ _ -> False)
+
+-- | O(n) for n = length input
+gas :: [a] -> Stack a
+gas = ana $ \case
+ [] -> nilF
+ (h : t) -> putF h t
+
+-- | O(n) for n = length input
+tap :: Stack a -> [a]
+tap = ana lag where
+ lag (project -> StackF c) = c Nil Cons
+
+-- | O(n) for n = length input
+map :: (a -> b) -> Stack a -> Stack b
+map f = ana lag where
+ lag (project -> StackF c) = c nilF b
+ b h t = putF (f h) t
+
+-- | O(n) for n = length input
+run :: (a -> b -> b) -> b -> Stack a -> b
+run f o = cata $ \case
+ StackF c -> c o f
+
+-- | O(n) for n = length l
+cat :: Stack a -> Stack a -> Stack a
+cat l r = apo lag (project l) where
+ lag (StackF c) = c a b
+
+ a = fmap Left (project r)
+
+ b h (project -> StackF c) =
+ let d = putF h (Left r)
+ e f g = putF h (Right (putF f g))
+ in c d e
+
+-- | O(n)
+jab :: Int -> a -> Stack a -> Stack a
+jab n x s = apo lag (n, s) where
+ lag (j, project -> StackF c) = c nilF (b j)
+
+ b j h t
+ | j <= 0 = putF x (Left t)
+ | otherwise = putF h (Right (pred j, t))
+
+-- exercise 2.1
+
+-- | O(n) for n = length input
+suf :: Stack a -> Stack (Stack a)
+suf = ana lag where
+ lag (project -> StackF c) = c nilF b
+ b _ t = putF t t
+
+-- test
+
+test0 :: Stack Int
+test0 = gas [1..3]
+
+test1 :: Stack Int
+test1 = gas [4..7]
+
+test2 :: Stack Int
+test2 = jab 3 100 (cat test0 test1)
diff --git a/lib/Okasaki/Tree.hs b/lib/Okasaki/Tree.hs
@@ -62,7 +62,7 @@ put x = apo lag where
-- versions
spy :: Ord a => a -> Tree a -> Maybe a
-spy x t = getLast (cata alg t) where
+spy x = getLast . cata alg where
alg = \case
LeafF -> mempty
NodeF l e r
diff --git a/lib/Okasaki/Tree/CPS.hs b/lib/Okasaki/Tree/CPS.hs
@@ -1,9 +1,4 @@
{-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
module Okasaki.Tree.CPS (
TreeF(..)
diff --git a/okasaki.cabal b/okasaki.cabal
@@ -11,12 +11,22 @@ cabal-version: >= 1.10
library
default-language: Haskell2010
- hs-source-dirs: lib
+ default-extensions:
+ DeriveFoldable
+ DeriveFunctor
+ DeriveTraversable
+ LambdaCase
+ RankNTypes
+ TypeFamilies
+ ViewPatterns
+ hs-source-dirs:
+ lib
other-modules:
- Okasaki.Orphans
+ Okasaki.Orphans
exposed-modules:
- Okasaki.Map
- , Okasaki.Stack
+ Okasaki.Heap.Leftist
+ , Okasaki.Map
+ , Okasaki.Stack.CPS
, Okasaki.Tree
, Okasaki.Tree.CPS
build-depends:
@@ -24,5 +34,4 @@ library
, data-fix
, deriving-compat
, recursion-schemes
- , free
