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

From HaskellWiki
Jump to: navigation, search
(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