commit 463167df18c0f3b7abe9668755b818f6177c4132
parent 0c3f691b03ab6c1b2cbeb40b2ba69d5b78e04ae4
Author: Jared Tobin <jared@jtobin.io>
Date: Sun, 5 Mar 2023 21:24:26 +0400
Add maps.
Diffstat:
4 files changed, 104 insertions(+), 30 deletions(-)
diff --git a/lib/Okasaki/Map.hs b/lib/Okasaki/Map.hs
@@ -0,0 +1,43 @@
+{-# OPTIONS_GHC -Wall -fno-warn-unused-top-binds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Okasaki.Map (
+ Map(..)
+ ) where
+
+import qualified Okasaki.Tree as T
+
+data Per a b = Per !a b
+
+instance (Show a, Show b) => Show (Per a b) where
+ show (Per a b) = show (a, b)
+
+instance Eq a => Eq (Per a b) where
+ Per a _ == Per c _ = a == c
+
+instance Ord a => Ord (Per a b) where
+ compare (Per a _) (Per b _) = compare a b
+
+-- exercise 2.6 (use tree to implement a finite map)
+newtype Map k a = Map (T.Tree (Per k a))
+ deriving Show
+
+non :: Map k a
+non = Map T.lef
+
+-- NB does not replace elements
+put :: (Ord k, Eq a) => k -> a -> Map k a -> Map k a
+put k a (Map m) = Map $
+ let per = Per k a
+ in T.rub per m
+
+get :: Ord k => k -> Map k a -> Maybe a
+get k (Map m) = do
+ las <- T.spy (Per k undefined) m -- NB we only care about keys
+ case las of
+ Per s v
+ | s == k -> pure v
+ | otherwise -> Nothing
+
diff --git a/lib/Okasaki/Tree.hs b/lib/Okasaki/Tree.hs
@@ -12,8 +12,15 @@ module Okasaki.Tree (
, lef
, nod
+ , spy
+
, put
+ , pat
+ , rub
+
, has
+ , haz
+
, gas
) where
@@ -23,12 +30,11 @@ import Data.Functor.Foldable
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 =
LeafF
- | NodeF r a r
+ | NodeF r !a r
deriving (Functor, Show)
$(deriveShow1 ''TreeF)
@@ -42,13 +48,10 @@ lef = Fix LeafF
nod :: a -> Tree a -> Tree a -> Tree a
nod x l r = Fix (NodeF l x r)
-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)
+ 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)
@@ -58,17 +61,43 @@ put x = apo lag where
-- figure out the speed/memory profiles compared to the standard
-- versions
+spy :: Ord a => a -> Tree a -> Maybe a
+spy x t = getLast (cata alg t) where
+ alg = \case
+ LeafF -> mempty
+ NodeF l e r
+ | x < e -> l
+ | otherwise -> Last (Just e) <> r
+
-- 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
+haz x t = case spy x t of
+ Nothing -> False
+ Just s -> s == x
+
+-- exercise 2.3 (no unnecessary copying)
+pat :: Ord a => a -> Tree a -> Tree a
+pat x t = tug id t where
+ tug k s = case project s of
+ LeafF -> k (nod x lef lef)
+ NodeF l e r -> case compare x e of
+ EQ -> t
+ LT -> tug (\a -> k (nod e a r)) l
+ GT -> tug (\a -> k (nod e l a)) r
+
+-- exercise 2.4 (no unnecessary copying, max d + 1 comparisons)
+rub :: Ord a => a -> Tree a -> Tree a
+rub x t = tug Nothing id t where
+ tug c k s = case project s of
+ LeafF -> case c of
+ Nothing -> k (nod x lef lef)
+ Just a
+ | a == x -> t
+ | otherwise -> k (nod x lef lef)
+
+ NodeF l e r
+ | x < e -> tug c (\a -> k (nod e a r)) l
+ | otherwise -> tug (pure e) (\a -> k (nod e l a)) r
-- exercise 2.5a (construct balanced binary trees of depth n)
dap :: Ord a => a -> Int -> Tree a
diff --git a/lib/Okasaki/Tree/CPS.hs b/lib/Okasaki/Tree/CPS.hs
@@ -13,6 +13,8 @@ module Okasaki.Tree.CPS (
, nod
, nodF
+ , spy
+
, put
, pet
, has
@@ -29,7 +31,6 @@ module Okasaki.Tree.CPS (
) where
import Data.Fix hiding (cata, ana, hylo)
-import Prelude hiding (sin)
import Data.Functor.Foldable
import Data.Monoid
import Okasaki.Orphans ()
@@ -51,14 +52,11 @@ 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
-
non :: Tree a -> Bool
non (project -> TreeF c) = c True b where
b _ _ _ = False
--- exercise 2.3 (no unnecessary copying) (?)
+-- 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
@@ -79,17 +77,19 @@ has x = cata alg where
LT -> l
GT -> r
+spy :: Ord a => a -> Tree a -> Last a
+spy x = cata alg where
+ alg (TreeF c) = c mempty b
+
+ b l e r
+ | x < e = l
+ | otherwise = Last (Just e) <> 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
+haz x t = case getLast (spy x t) of
+ Nothing -> False
+ Just s -> s == x
-- exercise 2.4 (no unnecessary copying, max d + 1 comparisons)
pet :: Ord a => a -> Tree a -> Tree a
@@ -114,6 +114,7 @@ dap x n = ana lag (n, lef) where
| 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
diff --git a/okasaki.cabal b/okasaki.cabal
@@ -15,7 +15,8 @@ library
other-modules:
Okasaki.Orphans
exposed-modules:
- Okasaki.Stack
+ Okasaki.Map
+ , Okasaki.Stack
, Okasaki.Tree
, Okasaki.Tree.CPS
build-depends:
