commit 5ce46e27f97643e2ebdc64a467894a2aca27696c
parent 0d2742da34d275aa453a7c2418bb7a37e4d46cd5
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 4 Mar 2023 22:59:41 +0400
Tons of misc stuff.
Diffstat:
5 files changed, 405 insertions(+), 58 deletions(-)
diff --git a/lib/Okasaki/Orphans.hs b/lib/Okasaki/Orphans.hs
@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Okasaki.Orphans where
+
+import Data.Functor.Const
+import Data.Functor.Foldable
+import qualified Data.Monoid as M
+
+type instance Base (M.Last a) = Const (M.Last a)
+
+instance Corecursive (M.Last a) where
+ embed (Const s) = s
+
+instance Recursive (M.Last a) where
+ project = Const
+
diff --git a/lib/Okasaki/Stack.hs b/lib/Okasaki/Stack.hs
@@ -10,19 +10,19 @@
module Okasaki.Stack (
StackF(..)
, Stack
- , empty
- , push
+ , nil
+ , put
, pop
- , fromList
- , toList
- , isEmpty
+ , gas
+ , tap
+ , non
, cat
- , update
- , suffixes
+ , jab
+ , suf
) where
-import Prelude hiding (head, tail)
+import Prelude hiding (map)
import Data.Fix (Fix(..))
import Data.Functor.Foldable as RS
import Text.Show.Deriving
@@ -36,46 +36,65 @@ $(deriveShow1 ''StackF)
type Stack a = Fix (StackF a)
-empty :: Stack a
-empty = Fix NilF
+-- | O(1)
+nil :: Stack a
+nil = Fix NilF
-push :: a -> Stack a -> Stack a
-push h t = Fix (ConsF h t)
+-- | O(1)
+put :: a -> Stack a -> Stack a
+put h t = Fix (ConsF h t)
+-- | O(1)
pop :: Stack a -> Maybe (a, Stack a)
pop s = case project s of
NilF -> Nothing
ConsF h t -> Just (h, t)
-fromList :: [a] -> Stack a
-fromList = ana coalg where
- coalg = \case
- [] -> NilF
- (h : t) -> ConsF h t
+-- | O(n) for n = length input
+gas :: [a] -> Stack a
+gas = ana $ \case
+ [] -> NilF
+ (h : t) -> ConsF h t
-toList :: Stack a -> [a]
-toList = ana coalg where
- coalg s = case project s of
+-- | O(n) for n = length input
+map :: (a -> b) -> Stack a -> Stack b
+map f = ana lag where
+ lag s = case project s of
+ NilF -> NilF
+ ConsF h t -> ConsF (f h) t
+
+-- | O(n) for n = length input
+run :: (a -> b -> b) -> b -> Stack a -> b
+run f o = cata $ \case
+ NilF -> o
+ ConsF h t -> f h t
+
+-- | O(n) for n = length input
+tap :: Stack a -> [a]
+tap = ana lag where
+ lag s = case project s of
NilF -> Nil
ConsF h t -> Cons h t
-isEmpty :: Stack a -> Bool
-isEmpty s = case project s of
+-- | O(1)
+non :: Stack a -> Bool
+non s = case project s of
NilF -> True
_ -> False
+-- | O(n) for n = length l
cat :: Stack a -> Stack a -> Stack a
-cat l r = apo coalg (project l) where
- coalg = \case
+cat l r = apo lag (project l) where
+ lag = \case
+ NilF -> fmap Left (project r)
ConsF h t -> case project t of
NilF -> ConsF h (Left r)
rest -> ConsF h (Right rest)
- NilF -> fmap Left (project r)
-
-update :: Int -> a -> Stack a -> Stack a
-update idx x s = apo coalg (idx, s) where
- coalg (j, stack) = case project stack of
+-- | O(n)
+jab :: Int -> a -> Stack a -> Stack a
+jab n x s = apo lag (n, s) where
+ lag (j, tac) = case project tac of
NilF -> NilF
ConsF h t ->
if j <= 0
@@ -83,19 +102,21 @@ update idx x s = apo coalg (idx, s) where
else ConsF h (Right (pred j, t))
-- exercise 2.1
-suffixes :: Stack a -> Stack (Stack a)
-suffixes = ana coalg where
- coalg stack = case project stack of
+
+-- | O(n) for n = length input
+suf :: Stack a -> Stack (Stack a)
+suf = ana lag where
+ lag tac = case project tac of
NilF -> NilF
ConsF _ t -> ConsF t t
-- test
test0 :: Stack Int
-test0 = fromList [1..3]
+test0 = gas [1..3]
test1 :: Stack Int
-test1 = fromList [4..7]
+test1 = gas [4..7]
test2 :: Stack Int
-test2 = update 3 100 (cat test0 test1)
+test2 = jab 3 100 (cat test0 test1)
diff --git a/lib/Okasaki/Tree.hs b/lib/Okasaki/Tree.hs
@@ -4,20 +4,27 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
module Okasaki.Tree (
TreeF(..)
, Tree
- , leaf
- , node
+ , lef
+ , nod
- , insert
- , member
- , fromList
+ , put
+ , has
+ , gas
) where
-import Data.Fix (Fix(..), unFix)
+import Data.Eq.Deriving (deriveEq1)
+import Data.Fix hiding (cata, ana, hylo)
import Data.Functor.Foldable
+import Data.Maybe (fromMaybe)
+import Data.Monoid
+import Okasaki.Orphans ()
+import qualified Okasaki.Tree.CPS as CPS
+import Prelude hiding (sin)
import Text.Show.Deriving
data TreeF a r =
@@ -26,44 +33,146 @@ data TreeF a r =
deriving (Functor, Show)
$(deriveShow1 ''TreeF)
+$(deriveEq1 ''TreeF)
type Tree a = Fix (TreeF a)
-leaf :: Tree a
-leaf = Fix LeafF
+lef :: Tree a
+lef = Fix LeafF
-node :: a -> Tree a -> Tree a -> Tree a
-node x l r = Fix (NodeF l x r)
+nod :: a -> Tree a -> Tree a -> Tree a
+nod x l r = Fix (NodeF l x r)
-insert :: Ord a => a -> Tree a -> Tree a
-insert x = apo coalg where
- coalg input = case unFix input of
- LeafF -> NodeF (Left leaf) x (Left leaf)
+sin :: a -> Tree a
+sin x = nod x lef lef
+
+put :: Ord a => a -> Tree a -> Tree a
+put x = apo lag where
+ lag pin = case project pin of
+ LeafF -> NodeF (Left lef) x (Left lef)
NodeF l e r -> case compare x e of
EQ -> NodeF (Left l) e (Left r)
LT -> NodeF (Right l) e (Left r)
GT -> NodeF (Left l) e (Right r)
-member :: Ord a => a -> Tree a -> Bool
-member x = cata $ \case
+-- NB would be interesting to benchmark these without optimizations to
+-- figure out the speed/memory profiles compared to the standard
+-- versions
+
+-- exercise 2.2 (max d + 1 comparisons)
+haz :: Ord a => a -> Tree a -> Bool
+haz x t = case getLast (rec t) of
+ Nothing -> False
+ Just s -> s == x
+ where
+ rec = cata $ \case
+ LeafF -> mempty
+ NodeF l e r
+ | x < e -> l
+ | otherwise -> Last (Just e) <> r
+
+-- exercise 2.3 (no unnecessary copying)
+
+-- NB a moment's thought implies this is max d + 1 comparisons already
+
+pat :: Ord a => a -> Tree a -> Tree a
+pat x t = case project t of
+ LeafF -> nod x lef lef
+ NodeF _ e _ -> rub e id t
+ where
+ rub v k s = case project s of
+ LeafF
+ | v == x -> s
+ | otherwise -> k (nod x lef lef)
+
+ NodeF l e r
+ | x < e -> rub v (\a -> k (nod e a r)) l
+ | otherwise -> rub e (\a -> k (nod e l a)) r
+
+-- exercise 2.4 (no unnecessary copying, max d + 1 comparisons)
+--
+-- same question as 2.3
+
+pet :: Ord a => a -> Tree a -> Tree a
+pet x t = fromMaybe t (go t Nothing) where
+ go s acc = case project s of
+ NodeF l e r ->
+ if x < e
+ then fmap (\a -> embed (NodeF a e r)) (go l acc)
+ else fmap (\a -> embed (NodeF l e a)) (go r (pure e))
+ LeafF -> case acc of
+ Nothing -> pure (sin x)
+ Just e ->
+ if e == x
+ then Nothing
+ else pure (sin x)
+
+-- exercise 2.5a (construct balanced binary trees of depth n)
+dap :: Ord a => a -> Int -> Tree a
+dap x n = ana lag (n, lef) where
+ lag (j, t)
+ | j <= 0 = LeafF
+ | otherwise =
+ let s = (pred j, t)
+ in NodeF s x s
+
+-- exercise 2.5b (construct mostly-balanced binary trees of size n)
+sap :: Ord a => a -> Int -> Tree a
+sap x n = ana lag (n, lef) where
+ lag (j, t)
+ | j <= 0 = LeafF
+ | odd j =
+ let s = (j `quot` 2, t)
+ in NodeF s x s
+ | otherwise =
+ let l = j `quot` 2
+ r = pred (j `quot` 2)
+ in NodeF (l, t) x (r, t)
+
+gas :: Ord a => [a] -> Tree a
+gas = cata $ \case
+ Nil -> lef
+ Cons h t -> put h t
+
+dep :: Integral b => Tree a -> b
+dep = getSum . cata alg where
+ alg = \case
+ LeafF -> mempty
+ NodeF l _ r -> Sum 1 <> max l r
+
+wyt :: Integral b => Tree a -> b
+wyt = getSum . cata alg where
+ alg = \case
+ LeafF -> mempty
+ NodeF l _ r -> Sum 1 <> l <> r
+
+has :: Ord a => a -> Tree a -> Bool
+has x = cata $ \case
LeafF -> False
NodeF l e r -> case compare x e of
EQ -> True
LT -> l
GT -> r
-fromList :: Ord a => [a] -> Tree a
-fromList = foldr insert leaf
+ver :: CPS.Tree a -> Tree a
+ver = ana lag where
+ lag (project -> CPS.TreeF c) = c LeafF NodeF
+
+rev :: Tree a -> CPS.Tree a
+rev = ana lag where
+ lag pin = case project pin of
+ LeafF -> CPS.lefF
+ NodeF l e r -> CPS.nodF e l r
test0 :: Num a => Tree a
-test0 = node 1 leaf leaf
+test0 = nod 1 lef lef
-- 1
-- | \
-- L L
test1 :: Num a => Tree a
-test1 = node 2 (node 1 leaf leaf) (node 3 leaf leaf)
+test1 = nod 2 (nod 1 lef lef) (nod 3 lef lef)
-- 2
-- | \
@@ -72,7 +181,7 @@ test1 = node 2 (node 1 leaf leaf) (node 3 leaf leaf)
-- L L L L
test2 :: (Ord a, Num a) => Tree a
-test2 = insert 0 test1
+test2 = put 0 test1
-- 2
-- | \
@@ -83,7 +192,7 @@ test2 = insert 0 test1
-- L L
test3 :: (Ord a, Num a) => Tree a
-test3 = insert 5 test1
+test3 = put 5 test1
-- 2
-- | \
@@ -94,7 +203,7 @@ test3 = insert 5 test1
-- L L
test4 :: (Ord a, Num a) => Tree a
-test4 = insert 4 test3
+test4 = put 4 test3
-- 2
-- | \
diff --git a/lib/Okasaki/Tree/CPS.hs b/lib/Okasaki/Tree/CPS.hs
@@ -0,0 +1,195 @@
+{-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Okasaki.Tree.CPS (
+ TreeF(..)
+ , Tree
+ , lef
+ , lefF
+ , nod
+ , nodF
+
+ , put
+ , pet
+ , has
+ , haz
+ , gas
+ , wyt
+ , dep
+
+ , test0
+ , test1
+ , test2
+ , test3
+ , test4
+ ) where
+
+import Data.Fix hiding (cata, ana, hylo)
+import Prelude hiding (sin)
+import Data.Functor.Foldable
+import Data.Monoid
+import Okasaki.Orphans ()
+
+newtype TreeF a r = TreeF (forall e. e -> (r -> a -> r -> e) -> e)
+ deriving Functor
+
+type Tree a = Fix (TreeF a)
+
+lefF :: TreeF a r
+lefF = TreeF const
+
+nodF :: a -> r -> r -> TreeF a r
+nodF x l r = TreeF (\_ c -> c l x r)
+
+lef :: Tree a
+lef = Fix lefF
+
+nod :: a -> Tree a -> Tree a -> Tree a
+nod x l r = Fix (nodF x l r)
+
+sin :: a -> Tree a
+sin x = nod x lef lef
+
+empty :: Tree a -> Bool
+empty (project -> TreeF c) = c True b where
+ b _ _ _ = False
+
+-- exercise 2.3 (no unnecessary copying) (?)
+put :: Ord a => a -> Tree a -> Tree a
+put x = apo lag where
+ lag (project -> TreeF c) = c a b
+
+ a = nodF x (Left lef) (Left lef)
+
+ b l e r = case compare x e of
+ EQ -> nodF e (Left l) (Left r)
+ LT -> nodF e (Right l) (Left r)
+ GT -> nodF e (Left l) (Right r)
+
+has :: Ord a => a -> Tree a -> Bool
+has x = cata alg where
+ alg (TreeF c) = c False b
+
+ b l e r = case compare x e of
+ EQ -> True
+ LT -> l
+ GT -> r
+
+-- exercise 2.2 (max d + 1 comparisons)
+haz :: Ord a => a -> Tree a -> Bool
+haz x t = case getLast (cata alg t) of
+ Nothing -> False
+ Just s -> s == x
+ where
+ alg (TreeF c) = c mempty b
+
+ b l e r
+ | x < e = l
+ | otherwise = Last (Just e) <> r
+
+-- exercise 2.4 (no unnecessary copying, max d + 1 comparisons)
+pet :: Ord a => a -> Tree a -> Tree a
+pet x t = apo lag (Nothing, t) where
+ lag (s, project -> TreeF c) = c (a s) (b s)
+
+ a = \case
+ Nothing -> nodF x (Left lef) (Left lef)
+ Just s
+ | s == x -> lefF
+ | otherwise -> nodF x (Left lef) (Left lef)
+
+ b s l e r
+ | x < e = nodF e (Right (s, l)) (Left r)
+ | otherwise = nodF e (Left l) (Right (Just e, r))
+
+-- exercise 2.5a (construct balanced binary trees of depth n)
+dap :: Ord a => a -> Int -> Tree a
+dap x n = ana lag (n, lef) where
+ lag (j, t)
+ | j <= 0 = lefF
+ | otherwise =
+ let s = (pred j, t)
+ in nodF x s s
+-- exercise 2.5b (construct mostly-balanced binary trees of size n)
+sap :: Ord a => a -> Int -> Tree a
+sap x n = ana lag (n, lef) where
+ lag (j, t)
+ | j <= 0 = lefF
+ | odd j =
+ let s = (j `quot` 2, t)
+ in nodF x s s
+ | otherwise =
+ let l = j `quot` 2
+ r = pred (j `quot` 2)
+ in nodF x (l, t) (r, t)
+
+gas :: Ord a => [a] -> Tree a
+gas = cata $ \case
+ Nil -> lef
+ Cons h t -> put h t
+
+dep :: Integral b => Tree a -> b
+dep = getSum . cata alg where
+ alg (TreeF c) = c mempty b
+ b l _ r = Sum 1 <> max l r
+
+wyt :: Integral b => Tree a -> b
+wyt = getSum . cata alg where
+ alg (TreeF c) = c mempty b
+ b l _ r = Sum 1 <> l <> r
+
+test0 :: Num a => Tree a
+test0 = nod 1 lef lef
+
+-- 1
+-- | \
+-- L L
+
+test1 :: Num a => Tree a
+test1 = nod 2 (nod 1 lef lef) (nod 3 lef lef)
+
+-- 2
+-- | \
+-- 1 3
+-- | \ | \
+-- L L L L
+
+test2 :: (Ord a, Num a) => Tree a
+test2 = pet 0 test1
+
+-- 2
+-- | \
+-- 1 3
+-- | \ | \
+-- 0 L L L
+-- | \
+-- L L
+
+test3 :: (Ord a, Num a) => Tree a
+test3 = pet 5 test1
+
+-- 2
+-- | \
+-- 1 3
+-- | \ | \
+-- L L L 5
+-- | \
+-- L L
+
+test4 :: (Ord a, Num a) => Tree a
+test4 = pet 4 test3
+
+-- 2
+-- | \
+-- 1 3
+-- | \ | \
+-- L L L 5
+-- | \
+-- 4 L
+-- | \
+-- L L
+
diff --git a/okasaki.cabal b/okasaki.cabal
@@ -12,12 +12,16 @@ cabal-version: >= 1.10
library
default-language: Haskell2010
hs-source-dirs: lib
+ other-modules:
+ Okasaki.Orphans
exposed-modules:
Okasaki.Stack
, Okasaki.Tree
+ , Okasaki.Tree.CPS
build-depends:
base
, data-fix
, deriving-compat
, recursion-schemes
+ , free
