Skip to content
This repository was archived by the owner on Oct 4, 2020. It is now read-only.

Added Foldable/Traversable Instances. #12

Merged
merged 1 commit into from
Oct 22, 2014
Merged

Added Foldable/Traversable Instances. #12

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
14 changes: 10 additions & 4 deletions README.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -5,14 +5,14 @@
### Types

data Edge k where
Edge :: k -> k -> Edge k
Edge :: k -> k -> Edge

data Graph k v where
Graph :: [v] -> [Edge k] -> Graph k v
Graph :: [v] -> [Edge k] -> Graph

data SCC v where
AcyclicSCC :: v -> SCC v
CyclicSCC :: [v] -> SCC v
AcyclicSCC :: v -> SCC
CyclicSCC :: [v] -> SCC


### Type Class Instances
Expand Down Expand Up @@ -46,10 +46,14 @@

instance eqMap :: (P.Eq k, P.Eq v) => P.Eq (Map k v)

instance foldableMap :: Foldable (Map k)

instance functorMap :: P.Functor (Map k)

instance showMap :: (P.Show k, P.Show v) => P.Show (Map k v)

instance traversableMap :: (P.Ord k) => Traversable (Map k)


### Values

Expand Down Expand Up @@ -148,6 +152,8 @@

instance showStrMap :: (P.Show a) => P.Show (StrMap a)

instance traversableStrMap :: Traversable StrMap


### Values

Expand Down
86 changes: 48 additions & 38 deletions src/Data/Map.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@
-- Based on http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf
--

module Data.Map
module Data.Map
( Map(),
showTree,
empty,
Expand All @@ -25,15 +25,16 @@ module Data.Map
unions,
map
) where

import qualified Prelude as P

import qualified Data.Array as A
import Data.Maybe
import Data.Maybe
import Data.Tuple
import Data.Foldable (foldl)

data Map k v
import Data.Foldable (foldl, foldMap, foldr, Foldable)
import Data.Traversable (traverse, Traversable)

data Map k v
= Leaf
| Two (Map k v) k v (Map k v)
| Three (Map k v) k v (Map k v) k v (Map k v)
Expand All @@ -43,29 +44,38 @@ instance eqMap :: (P.Eq k, P.Eq v) => P.Eq (Map k v) where
(/=) m1 m2 = P.not (m1 P.== m2)

instance showMap :: (P.Show k, P.Show v) => P.Show (Map k v) where
show m = "fromList " P.++ P.show (toList m)
show m = "fromList " P.++ P.show (toList m)

instance functorMap :: P.Functor (Map k) where
(<$>) _ Leaf = Leaf
(<$>) f (Two left k v right) = Two (f P.<$> left) k (f v) (f P.<$> right)
(<$>) f (Three left k1 v1 mid k2 v2 right) = Three (f P.<$> left) k1 (f v1) (f P.<$> mid) k2 (f v2) (f P.<$> right)

showTree :: forall k v. (P.Show k, P.Show v) => Map k v -> String

instance foldableMap :: Foldable (Map k) where
foldl f z m = foldl f z (values m)
foldr f z m = foldr f z (values m)
foldMap f m = foldMap f (values m)

instance traversableMap :: (P.Ord k) => Traversable (Map k) where
traverse f ms = foldr (\x acc -> union P.<$> x P.<*> acc) (P.pure empty) ((P.(<$>) (uncurry singleton)) P.<$> (traverse f P.<$> toList ms))
sequence = traverse P.id

showTree :: forall k v. (P.Show k, P.Show v) => Map k v -> String
showTree Leaf = "Leaf"
showTree (Two left k v right) =
"Two (" P.++ showTree left P.++
") (" P.++ P.show k P.++
") (" P.++ P.show v P.++
showTree (Two left k v right) =
"Two (" P.++ showTree left P.++
") (" P.++ P.show k P.++
") (" P.++ P.show v P.++
") (" P.++ showTree right P.++ ")"
showTree (Three left k1 v1 mid k2 v2 right) =
"Three (" P.++ showTree left P.++
") (" P.++ P.show k1 P.++
") (" P.++ P.show v1 P.++
showTree (Three left k1 v1 mid k2 v2 right) =
"Three (" P.++ showTree left P.++
") (" P.++ P.show k1 P.++
") (" P.++ P.show v1 P.++
") (" P.++ showTree mid P.++
") (" P.++ P.show k2 P.++
") (" P.++ P.show v2 P.++
") (" P.++ P.show k2 P.++
") (" P.++ P.show v2 P.++
") (" P.++ showTree right P.++ ")"

empty :: forall k v. Map k v
empty = Leaf

Expand All @@ -75,15 +85,15 @@ isEmpty _ = false

singleton :: forall k v. k -> v -> Map k v
singleton k v = Two Leaf k v Leaf

checkValid :: forall k v. Map k v -> Boolean
checkValid tree = A.length (A.nub (allHeights tree)) P.== 1
where
allHeights :: forall k v. Map k v -> [Number]
allHeights Leaf = [0]
allHeights (Two left _ _ right) = A.map (\n -> n P.+ 1) (allHeights left P.++ allHeights right)
allHeights (Three left _ _ mid _ _ right) = A.map (\n -> n P.+ 1) (allHeights left P.++ allHeights mid P.++ allHeights right)
allHeights (Three left _ _ mid _ _ right) = A.map (\n -> n P.+ 1) (allHeights left P.++ allHeights mid P.++ allHeights right)

lookup :: forall k v. (P.Ord k) => k -> Map k v -> Maybe v
lookup _ Leaf = Nothing
lookup k (Two _ k1 v _) | k P.== k1 = Just v
Expand All @@ -104,15 +114,15 @@ data TreeContext k v
| ThreeLeft k v (Map k v) k v (Map k v)
| ThreeMiddle (Map k v) k v k v (Map k v)
| ThreeRight (Map k v) k v (Map k v) k v

fromZipper :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
fromZipper [] tree = tree
fromZipper (TwoLeft k1 v1 right : ctx) left = fromZipper ctx (Two left k1 v1 right)
fromZipper (TwoRight left k1 v1 : ctx) right = fromZipper ctx (Two left k1 v1 right)
fromZipper (ThreeLeft k1 v1 mid k2 v2 right : ctx) left = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (ThreeMiddle left k1 v1 k2 v2 right : ctx) mid = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (ThreeRight left k1 v1 mid k2 v2 : ctx) right = fromZipper ctx (Three left k1 v1 mid k2 v2 right)

data KickUp k v = KickUp (Map k v) k v (Map k v)

insert :: forall k v. (P.Ord k) => k -> v -> Map k v -> Map k v
Expand All @@ -127,39 +137,39 @@ insert = down []
down ctx k v (Three left k1 v1 mid k2 _ right) | k P.== k2 = fromZipper ctx (Three left k1 v1 mid k v right)
down ctx k v (Three left k1 v1 mid k2 v2 right) | k P.< k1 = down (ThreeLeft k1 v1 mid k2 v2 right P.: ctx) k v left
down ctx k v (Three left k1 v1 mid k2 v2 right) | k1 P.< k P.&& k P.<= k2 = down (ThreeMiddle left k1 v1 k2 v2 right P.: ctx) k v mid
down ctx k v (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k v right
down ctx k v (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k v right

up :: forall k v. (P.Ord k) => [TreeContext k v] -> KickUp k v -> Map k v
up [] (KickUp left k v right) = Two left k v right
up (TwoLeft k1 v1 right : ctx) (KickUp left k v mid) = fromZipper ctx (Three left k v mid k1 v1 right)
up (TwoRight left k1 v1 : ctx) (KickUp mid k v right) = fromZipper ctx (Three left k1 v1 mid k v right)
up (ThreeLeft k1 v1 c k2 v2 d : ctx) (KickUp a k v b) = up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
up (ThreeMiddle a k1 v1 k2 v2 d : ctx) (KickUp b k v c) = up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
up (ThreeRight a k1 v1 b k2 v2 : ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))
up (ThreeRight a k1 v1 b k2 v2 : ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))

delete :: forall k v. (P.Ord k) => k -> Map k v -> Map k v
delete = down []
where
down :: forall k v. (P.Ord k) => [TreeContext k v] -> k -> Map k v -> Map k v
down ctx _ Leaf = fromZipper ctx Leaf
down ctx k (Two Leaf k1 _ Leaf) | k P.== k1 = up ctx Leaf
down ctx k (Two left k1 _ right) | k P.== k1 =
down ctx k (Two left k1 _ right) | k P.== k1 =
let max = maxNode left
in removeMaxNode (TwoLeft max.key max.value right P.: ctx) left
down ctx k (Two left k1 v1 right) | k P.< k1 = down (TwoLeft k1 v1 right P.: ctx) k left
down ctx k (Two left k1 v1 right) = down (TwoRight left k1 v1 P.: ctx) k right
down ctx k (Three Leaf k1 _ Leaf k2 v2 Leaf) | k P.== k1 = fromZipper ctx (Two Leaf k2 v2 Leaf)
down ctx k (Three Leaf k1 v1 Leaf k2 _ Leaf) | k P.== k2 = fromZipper ctx (Two Leaf k1 v1 Leaf)
down ctx k (Three left k1 _ mid k2 v2 right) | k P.== k1 =
down ctx k (Three left k1 _ mid k2 v2 right) | k P.== k1 =
let max = maxNode left
in removeMaxNode (ThreeLeft max.key max.value mid k2 v2 right P.: ctx) left
down ctx k (Three left k1 v1 mid k2 _ right) | k P.== k2 =
let max = maxNode mid
in removeMaxNode (ThreeMiddle left k1 v1 max.key max.value right P.: ctx) mid
down ctx k (Three left k1 v1 mid k2 v2 right) | k P.< k1 = down (ThreeLeft k1 v1 mid k2 v2 right P.: ctx) k left
down ctx k (Three left k1 v1 mid k2 v2 right) | k1 P.< k P.&& k P.< k2 = down (ThreeMiddle left k1 v1 k2 v2 right P.: ctx) k mid
down ctx k (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k right
down ctx k (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k right

up :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
up [] tree = tree
up (TwoLeft k1 v1 Leaf : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
Expand All @@ -179,27 +189,27 @@ delete = down []
up (ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e : ctx) d = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
up (ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e) : ctx) b = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
up (ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 : ctx) e = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))

maxNode :: forall k v. (P.Ord k) => Map k v -> { key :: k, value :: v }
maxNode (Two _ k v Leaf) = { key: k, value: v }
maxNode (Two _ _ _ right) = maxNode right
maxNode (Three _ _ _ _ k v Leaf) = { key: k, value: v }
maxNode (Three _ _ _ _ _ _ right) = maxNode right

removeMaxNode :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
removeMaxNode ctx (Two Leaf _ _ Leaf) = up ctx Leaf
removeMaxNode ctx (Two left k v right) = removeMaxNode (TwoRight left k v P.: ctx) right
removeMaxNode ctx (Three Leaf k1 v1 Leaf _ _ Leaf) = up (TwoRight Leaf k1 v1 P.: ctx) Leaf
removeMaxNode ctx (Three left k1 v1 mid k2 v2 right) = removeMaxNode (ThreeRight left k1 v1 mid k2 v2 P.: ctx) right

alter :: forall k v. (P.Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
alter f k m = case f (k `lookup` m) of
Nothing -> delete k m
Just v -> insert k v m

update :: forall k v. (P.Ord k) => (v -> Maybe v) -> k -> Map k v -> Map k v
update f k m = alter (maybe Nothing f) k m
update f k m = alter (maybe Nothing f) k m

toList :: forall k v. Map k v -> [Tuple k v]
toList Leaf = []
toList (Two left k v right) = toList left P.++ [Tuple k v] P.++ toList right
Expand Down
21 changes: 13 additions & 8 deletions src/Data/StrMap.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -34,18 +34,19 @@ module Data.StrMap
freezeST,
runST
) where

import qualified Prelude as P

import Control.Monad.Eff (Eff(), runPure)
import qualified Control.Monad.ST as ST
import qualified Data.Array as A
import Data.Maybe
import Data.Function
import Data.Tuple
import Data.Foldable (Foldable, foldl, foldr, for_)
import Data.Function
import Data.Maybe
import Data.Monoid
import Data.Monoid.All
import Data.Tuple
import Data.Traversable (Traversable, traverse)
import qualified Control.Monad.ST as ST
import qualified Data.Array as A
import qualified Data.StrMap.ST as SM

foreign import data StrMap :: * -> *
Expand Down Expand Up @@ -128,6 +129,10 @@ instance foldableStrMap :: Foldable StrMap where
foldr f z m = foldr f z (values m)
foldMap f = foldMap (P.const f)

instance traversableStrMap :: Traversable StrMap where
traverse f ms = foldr (\x acc -> union P.<$> x P.<*> acc) (P.pure empty) ((P.(<$>) (uncurry singleton)) P.<$> (traverse f P.<$> toList ms))
sequence = traverse P.id

-- Unfortunately the above are not short-circuitable (consider using purescript-machines)
-- so we need special cases:

Expand Down Expand Up @@ -213,10 +218,10 @@ alter f k m = case f (k `lookup` m) of
Just v -> insert k v m

update :: forall a. (a -> Maybe a) -> String -> StrMap a -> StrMap a
update f k m = alter (maybe Nothing f) k m
update f k m = alter (maybe Nothing f) k m

fromList :: forall a. [Tuple String a] -> StrMap a
fromList l = pureST (do
fromList l = pureST (do
s <- SM.new
for_ l (\(Tuple k v) -> SM.poke s k v)
P.return s)
Expand Down