From 315cb18674266b201bd9eb48efb60edd1f30c41f Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Mon, 26 Apr 2010 15:13:51 +0900
Subject: [PATCH] improved Types.Data.Map

---
 Types/Data/List/Ops.hs |  32 ++++++
 Types/Data/Map.hs      | 242 +++++++++++++++++++++++++++++++++++++----
 Types/Data/Maybe.hs    |   2 +-
 rrdtool.cabal          |   1 +
 4 files changed, 255 insertions(+), 22 deletions(-)
 create mode 100644 Types/Data/List/Ops.hs

diff --git a/Types/Data/List/Ops.hs b/Types/Data/List/Ops.hs
new file mode 100644
index 0000000..137f226
--- /dev/null
+++ b/Types/Data/List/Ops.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE
+  TypeFamilies,
+  UndecidableInstances
+  #-}
+module Types.Data.List.Ops
+    ( App
+    , App2
+    , App3
+    , App4
+    , App5
+
+    , Map
+    , Foldl
+    )
+    where
+
+import Types.Data.List
+
+
+type family App  f a
+type family App2 f a b
+type family App3 f a b c
+type family App4 f a b c d
+type family App5 f a b c d e
+
+type family   Map f l
+type instance Map f Null        = Null
+type instance Map f (Cons x xs) = Cons (App f x) (Map f xs)
+
+type family   Foldl f z l
+type instance Foldl f z Null        = z
+type instance Foldl f z (Cons x xs) = Foldl f (App2 f z x) xs
diff --git a/Types/Data/Map.hs b/Types/Data/Map.hs
index 95fe59b..6cb61c6 100644
--- a/Types/Data/Map.hs
+++ b/Types/Data/Map.hs
@@ -5,8 +5,10 @@
   UndecidableInstances
   #-}
 module Types.Data.Map
-    ( Map
+    ( -- * Map class
+      Map
 
+      -- * Query
     , Null
     , Size
     , Lookup
@@ -16,15 +18,56 @@ module Types.Data.Map
     , Find
     , FindWithDefault
 
+      -- * Construction
     , Empty
     , Singleton
 
+      -- ** Insertion
     , Insert
+
+      -- ** Delete\/Update
+    , Delete
+    , Adjust
+    , AdjustWithKey
+    , UpdateWithKey
+
+      -- * Traversal
+      -- ** Map
+    , MapValue
+    , MapWithKey
+
+      -- ** Fold
+    , FoldrWithKey
+    , FoldlWithKey
+
+      -- * Conversion
+    , Keys
+    , Assocs
+
+      -- ** Lists
+    , ToList
+    , FromList
+
+      -- ** Ordered lists
+    , ToAscList
+    , ToDescList
+
+      -- * Min\/Max
+    , DeleteFindMin
+    , DeleteFindMax
+    , MinView
+    , MaxView
+    , MinViewWithKey
+    , MaxViewWithKey
     )
     where
 
+import qualified Types.Data.List as L
+import qualified Types.Data.List.Ops as L
+
 import Types.Data.Bool
 import Types.Data.List hiding (Null)
+import Types.Data.List.Ops hiding (Map)
 import Types.Data.Maybe
 import Types.Data.Num
 import Types.Data.Ord
@@ -46,25 +89,31 @@ type family   Size m
 type instance Size Tip             = D0
 type instance Size (Bin s k v l r) = s
 
+-- CompCase
+type CompCase a b ifLT ifGT ifEQ
+    = If (IsLT (Compare a b))
+         ifLT
+         (If (IsGT (Compare a b))
+             ifGT
+             ifEQ)
+
 -- Lookup
 type family   Lookup k m
 type instance Lookup k Tip              = Nothing
 type instance Lookup k (Bin s k' v l r)
-    = If (IsLT (Compare k k'))
-         (Lookup k l)
-         (If (IsGT (Compare k k'))
-             (Lookup k r)
-             (Just v))
+    = CompCase k k'
+               (Lookup k l)
+               (Lookup k r)
+               (Just v)
 
 -- LookupAssoc
 type family   LookupAssoc k m
 type instance LookupAssoc k Tip              = Nothing
 type instance LookupAssoc k (Bin s k' v l r)
-    = If (IsLT (Compare k k'))
-         (LookupAssoc k l)
-         (If (IsGT (Compare k k'))
-             (LookupAssoc k r)
-             (Just (Cons k v)))
+    = CompCase k k'
+               (LookupAssoc k l)
+               (LookupAssoc k r)
+               (Just (Cons k v))
 
 -- Member
 type Member k m = IsJust (Lookup k m)
@@ -89,35 +138,43 @@ type Singleton k v = Bin D1 k v Tip Tip
 type family   Insert k v m
 type instance Insert k v Tip              = Singleton k v
 type instance Insert k v (Bin s k' v' l r)
-    = If (IsLT (Compare k k'))
-         (Balance k' v' (Insert k v l) r)
-         (If (IsGT (Compare k k'))
-             (Balance k' v' l (Insert k v r))
-             (Bin s k v l r))
+    = CompCase k k'
+               (Balance k' v' (Insert k v l) r)
+               (Balance k' v' l (Insert k v r))
+               (Bin s k v l r)
+
+-- Delete
+type family   Delete k m
+type instance Delete k Tip              = Tip
+type instance Delete k (Bin s k' v l r)
+    = CompCase k k'
+               (Balance k' v (Delete k l) r)
+               (Balance k' v l (Delete k r))
+               (Glue l r)
 
 -- Balance
 type Delta = D5
 type Ratio = D2
 
 type Balance k v l r
-    = If (Size l :+: Size r :<: 1)
+    = If ((Size l :+: Size r) :<=: D1)
          (Bin (Size l :+: Size r :+: D1) k v l r)
-         (If (Size r :>=: Delta :*: Size l)
+         (If (Size r :>=: (Delta :*: Size l))
              (RotateL k v l r)
-             (If (Size l :>=: Delta :*: Size r)
+             (If (Size l :>=: (Delta :*: Size r))
                  (RotateR k v l r)
                  (Bin (Size l :+: Size r :+: D1) k v l r)))
 
 -- Rotate
 type family   RotateL k v l r
 type instance RotateL k v l (Bin s k' v' l' r')
-    = If (Size l' :<: Ratio :*: Size r')
+    = If (Size l' :<: (Ratio :*: Size r'))
          (SingleL k v l (Bin s k' v' l' r'))
          (DoubleL k v l (Bin s k' v' l' r'))
 
 type family   RotateR k v l r
 type instance RotateR k v (Bin s k' v' l' r') r
-    = If (Size r' :<: Ratio :*: Size l')
+    = If (Size r' :<: (Ratio :*: Size l'))
          (SingleR k v (Bin s k' v' l' r') r)
          (DoubleR k v (Bin s k' v' l' r') r)
 
@@ -142,3 +199,146 @@ type instance DoubleR k v (Bin s k' v' l (Bin s' k'' v'' l' r)) r'
 type Bin' k v l r
     = Bin (Size l :+: Size r :+: D1) k v l r
 
+-- Glue
+type Glue l r
+    = If (Null l)
+         r
+         (If (Null r)
+             l
+             (If (Size l :>: Size r)
+                 (GlueL (DeleteFindMax l) r)
+                 (GlueR l (DeleteFindMin r))))
+
+type family   GlueL dfm r
+type instance GlueL (Cons (Cons km m) l') r = Balance km m l' r
+
+type family   GlueR l dfm
+type instance GlueR l (Cons (Cons km m) r') = Balance km m l r'
+
+-- DeleteFindMin
+type family   DeleteFindMin m
+type instance DeleteFindMin (Bin s k v l r)
+    = If (Null l)
+         (Cons (Cons k v) r)
+         (DeleteFindMin' k v (DeleteFindMin l) r)
+
+type family   DeleteFindMin' k v dfm r
+type instance DeleteFindMin' k v (Cons km l') r
+    = Cons km (Balance k v l' r)
+
+-- DeleteFindMax
+type family   DeleteFindMax m
+type instance DeleteFindMax (Bin s k v l r)
+    = If (Null r)
+         (Cons (Cons k v) l)
+         (DeleteFindMax' k v l (DeleteFindMax r))
+
+type family   DeleteFindMax' k v l dfm
+type instance DeleteFindMax' k v l (Cons km r')
+    = Cons km (Balance k v l r')
+
+-- MinViewWithKey
+type MinViewWithKey m
+    = If (Null m)
+         Nothing
+         (Just (DeleteFindMin m))
+
+-- MaxViewWithKey
+type MaxViewWithKey m
+    = If (Null m)
+         Nothing
+         (Just (DeleteFindMax m))
+
+-- MinView
+type MinView m
+    = If (Null m)
+         Nothing
+         (Just (View' (DeleteFindMin m)))
+
+type family   View' m
+type instance View' (Cons (Cons k v) m') = Cons v m'
+
+-- MaxView
+type MaxView m
+    = If (Null m)
+         Nothing
+         (Just (View' (DeleteFindMax m)))
+
+-- Adjust
+type Adjust f k m
+    = AdjustWithKey (Adjust' f) k m
+
+data Adjust' f
+type instance App2 (Adjust' f) k v = App f v
+
+-- AdjustWithKey
+type AdjustWithKey f k m
+    = UpdateWithKey (AdjustWithKey' f) k m
+
+data AdjustWithKey' f
+type instance App2 (AdjustWithKey' f) k v = Just (App2 f k v)
+
+-- UpdateWithKey
+type family   UpdateWithKey f k m
+type instance UpdateWithKey f k Tip              = Tip
+type instance UpdateWithKey f k (Bin s k' v l r)
+    = CompCase k k'
+               (Balance k' v (UpdateWithKey f k l) r)
+               (Balance k' v l (UpdateWithKey f k r))
+               (If (IsJust (App2 f k' v))
+                   (Bin s k' (FromJust (App2 f k' v)) l r)
+                   (Glue l r))
+
+-- Map
+type MapValue f m = MapWithKey (MapValue' f) m
+
+data MapValue' f
+type instance App2 (MapValue' f) k v = App f v
+
+-- MapWithKey
+type family   MapWithKey f m
+type instance MapWithKey f Tip             = Tip
+type instance MapWithKey f (Bin s k v l r)
+    = Bin s k (App2 f k v) (MapWithKey f l) (MapWithKey f r)
+
+-- FoldrWithKey
+type family   FoldrWithKey f z m
+type instance FoldrWithKey f z Tip             = z
+type instance FoldrWithKey f z (Bin s k v l r)
+    = FoldrWithKey f (App3 f k v (FoldrWithKey f z r)) l
+
+-- FoldlWithKey
+type family   FoldlWithKey f z m
+type instance FoldlWithKey f z Tip             = z
+type instance FoldlWithKey f z (Bin s k v l r)
+    = FoldlWithKey f (App3 f (FoldlWithKey f z l) k v) r
+
+-- Keys
+type Keys m = L.Map Key' (Assocs m)
+
+data Key'
+type instance App Key' (Cons k v) = k
+
+-- Assocs
+type Assocs m = ToList m
+
+-- ToList
+type ToList m = ToAscList m
+
+-- FromList
+type FromList xs = Foldl Ins' Empty xs
+
+data Ins'
+type instance App2 Ins' m (Cons k v) = Insert k v m
+
+-- ToAscList
+type ToAscList m = FoldrWithKey ToAscList' L.Null m
+
+data ToAscList'
+type instance App3 ToAscList' k v vs = Cons (Cons k v) vs
+
+-- ToDescList
+type ToDescList m = FoldlWithKey ToDescList' L.Null m
+
+data ToDescList'
+type instance App3 ToDescList' vs k v = Cons (Cons k v) vs
diff --git a/Types/Data/Maybe.hs b/Types/Data/Maybe.hs
index 997c93b..fde963b 100644
--- a/Types/Data/Maybe.hs
+++ b/Types/Data/Maybe.hs
@@ -15,7 +15,7 @@ module Types.Data.Maybe
     )
     where
 
-import Prelude ()
+import Prelude hiding (Maybe)
 import Types.Data.Bool
 
 
diff --git a/rrdtool.cabal b/rrdtool.cabal
index 9c0f524..2f8385e 100644
--- a/rrdtool.cabal
+++ b/rrdtool.cabal
@@ -38,6 +38,7 @@ Library
         Data.HList.Graph
         Data.HList.Prelude
         Data.HList.String
+        Types.Data.List.Ops
         Types.Data.Map
         Types.Data.Maybe
 
-- 
2.40.0