# Difference between revisions of "The Monad.Reader/Discuss Issue11/FingerTreeIMap"

From HaskellWiki

Tomjaguarpaw (talk | contribs) (Deleting page that hasn't been updated for over 10 years) |
m (Reverted edits by Tomjaguarpaw (talk) to last revision by Dfplace) |
||

Line 1: | Line 1: | ||

+ | --[[User:Dfplace|Dfplace]] 16:19, 12 September 2008 (UTC) |
||

+ | |||

+ | <haskell> |
||

+ | {-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} |
||

+ | module IMap where |
||

+ | import Data.FingerTree |
||

+ | import Data.List hiding (insert,delete,lookup) |
||

+ | import Prelude hiding (lookup) |
||

+ | import Data.Monoid |
||

+ | |||

+ | data Elem a b = Elem a b |
||

+ | |||

+ | data Key k v = NoKey | Key k v |
||

+ | |||

+ | instance Eq k => Eq (Key k v) where |
||

+ | (Key j _) == (Key k _) = j == k |
||

+ | NoKey == NoKey = True |
||

+ | NoKey == (Key _ _) = False |
||

+ | (Key _ _) == NoKey = False |
||

+ | |||

+ | instance Ord k => Ord (Key k v) where |
||

+ | compare (Key j _) (Key k _) = compare j k |
||

+ | compare NoKey NoKey = EQ |
||

+ | compare (Key _ _) NoKey = GT |
||

+ | compare NoKey (Key _ _ ) = LT |
||

+ | |||

+ | instance Monoid v => Monoid (Key a v) where |
||

+ | mempty = NoKey |
||

+ | k `mappend` NoKey = k |
||

+ | NoKey `mappend` k = k |
||

+ | (Key _ x) `mappend` (Key k y) = Key k (x `mappend` y) |
||

+ | |||

+ | data IMap a b = IMap (FingerTree (Key a b) (Elem a b)) |
||

+ | |||

+ | instance (Monoid b) => Measured (Key a b) (Elem a b) where |
||

+ | measure (Elem x y) = Key x y |
||

+ | |||

+ | insert :: (Ord k, Monoid v) => k -> v -> IMap k v -> IMap k v |
||

+ | insert k v (IMap xs) = insert' $ viewl r |
||

+ | where |
||

+ | (l,r) = split (>= Key k undefined) xs |
||

+ | new = IMap ( l >< (Elem k v <| r)) |
||

+ | insert' ((Elem y _) :< r') |
||

+ | | k == y = IMap ( l >< (Elem k v <| r')) |
||

+ | | otherwise = new |
||

+ | insert' EmptyL = new |
||

+ | |||

+ | delete :: (Ord k, Monoid v) => k -> IMap k v -> IMap k v |
||

+ | delete x (IMap xs) = IMap (l >< r') |
||

+ | where |
||

+ | (l,r) = split (>= Key x undefined) xs |
||

+ | (_,r') = split (> Key x undefined) r |
||

+ | |||

+ | lookup :: (Monad m, Ord t, Monoid v) => t -> IMap t v -> m v |
||

+ | lookup x (IMap xs) = lookup' $ |
||

+ | viewl . snd $ |
||

+ | split (>= Key x undefined) xs |
||

+ | where |
||

+ | lookup' ((Elem y v) :< _) |
||

+ | | y == x = return v |
||

+ | | otherwise = fail "IMap.lookup failed" |
||

+ | lookup' EmptyL = fail "IMap.lookup failed" |
||

+ | |||

+ | getValue :: (Monoid v) => IMap k v -> v |
||

+ | getValue (IMap xs) = let (Key _ v) = measure xs in v |
||

+ | </haskell> |

## Latest revision as of 15:19, 6 February 2021

--Dfplace 16:19, 12 September 2008 (UTC)

```
{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}
module IMap where
import Data.FingerTree
import Data.List hiding (insert,delete,lookup)
import Prelude hiding (lookup)
import Data.Monoid
data Elem a b = Elem a b
data Key k v = NoKey | Key k v
instance Eq k => Eq (Key k v) where
(Key j _) == (Key k _) = j == k
NoKey == NoKey = True
NoKey == (Key _ _) = False
(Key _ _) == NoKey = False
instance Ord k => Ord (Key k v) where
compare (Key j _) (Key k _) = compare j k
compare NoKey NoKey = EQ
compare (Key _ _) NoKey = GT
compare NoKey (Key _ _ ) = LT
instance Monoid v => Monoid (Key a v) where
mempty = NoKey
k `mappend` NoKey = k
NoKey `mappend` k = k
(Key _ x) `mappend` (Key k y) = Key k (x `mappend` y)
data IMap a b = IMap (FingerTree (Key a b) (Elem a b))
instance (Monoid b) => Measured (Key a b) (Elem a b) where
measure (Elem x y) = Key x y
insert :: (Ord k, Monoid v) => k -> v -> IMap k v -> IMap k v
insert k v (IMap xs) = insert' $ viewl r
where
(l,r) = split (>= Key k undefined) xs
new = IMap ( l >< (Elem k v <| r))
insert' ((Elem y _) :< r')
| k == y = IMap ( l >< (Elem k v <| r'))
| otherwise = new
insert' EmptyL = new
delete :: (Ord k, Monoid v) => k -> IMap k v -> IMap k v
delete x (IMap xs) = IMap (l >< r')
where
(l,r) = split (>= Key x undefined) xs
(_,r') = split (> Key x undefined) r
lookup :: (Monad m, Ord t, Monoid v) => t -> IMap t v -> m v
lookup x (IMap xs) = lookup' $
viewl . snd $
split (>= Key x undefined) xs
where
lookup' ((Elem y v) :< _)
| y == x = return v
| otherwise = fail "IMap.lookup failed"
lookup' EmptyL = fail "IMap.lookup failed"
getValue :: (Monoid v) => IMap k v -> v
getValue (IMap xs) = let (Key _ v) = measure xs in v
```