From a370bc29f91d16ad36da733fb82061b9a543700e Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Mon, 26 Apr 2010 18:09:26 +0900
Subject: [PATCH] working on graphs...

---
 Data/HList/Graph.hs                | 72 -------------------------
 Types/Data/Graph.hs                | 84 ++++++++++++++++++++++++++++++
 Types/Data/Graph/Dijkstra.hs       | 60 +++++++++++++++++++++
 Types/Data/Graph/RootPath.hs       | 55 +++++++++++++++++++
 {Data/HList => Types/Data}/Heap.hs | 10 ++--
 Types/Data/Map.hs                  | 34 ++++++------
 rrdtool.cabal                      |  6 ++-
 7 files changed, 226 insertions(+), 95 deletions(-)
 delete mode 100644 Data/HList/Graph.hs
 create mode 100644 Types/Data/Graph.hs
 create mode 100644 Types/Data/Graph/Dijkstra.hs
 create mode 100644 Types/Data/Graph/RootPath.hs
 rename {Data/HList => Types/Data}/Heap.hs (88%)

diff --git a/Data/HList/Graph.hs b/Data/HList/Graph.hs
deleted file mode 100644
index c3fcf87..0000000
--- a/Data/HList/Graph.hs
+++ /dev/null
@@ -1,72 +0,0 @@
-{-# LANGUAGE
-  EmptyDataDecls,
-  TypeFamilies
-  #-}
-module Data.HList.Graph
-    ( Context
-    , Graph
-
-    , Empty
-    , IsEmpty
---    , Match
-    )
-    where
-
-import Data.HList.Prelude
-import Types.Data.Bool
-
--- Graph is a map from node ID to context
-data Context preNodes node sucNodes
-data Graph nodeMap
-
--- Empty
-type Empty = Graph Nil
-
--- IsEmpty
-type family   IsEmpty g
-type instance IsEmpty (Graph Nil)         = True
-type instance IsEmpty (Graph (Cons x xs)) = False
-
--- Match
---type Match n g
---    = 
-
-{-
--- NodeSet
-class    NodeSet ns
-instance NodeSet Nil
-instance NodeSet ns => NodeSet (Cons n ns)
-
--- NodeIDSet
-class    NoDuplicates ids => NodeIDSet ids
-instance NodeIDSet Nil
-instance (OccursNot id ids, NodeIDSet ids) => NodeIDSet (Cons id ids)
-
--- LPath (list of labeled node IDs)
-class    LPath p
-instance LPath Nil
-instance LPath p => LPath (Cons (Cons l id) p)
-
--- Node
-class NodeIDSet (LinksFrom n) => Node n
-    where
-      type NodeID n
-      type LinksFrom n
-
--- NodeIDA
-data NodeIDA
-instance ApplyT NodeIDA n where
-    type Apply NodeIDA n = NodeID n
-
--- Graph
-class ( NodeSet (Nodes g)
-      , NoDuplicates (Map NodeIDA g)
-      )
-    => Graph g
-    where
-      type Empty g
-      type Nodes g
-
--- IsEmpty
-type family IsEmpty g
--}
\ No newline at end of file
diff --git a/Types/Data/Graph.hs b/Types/Data/Graph.hs
new file mode 100644
index 0000000..8c5fc57
--- /dev/null
+++ b/Types/Data/Graph.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE
+  EmptyDataDecls,
+  TypeFamilies,
+  UndecidableInstances
+  #-}
+module Types.Data.Graph
+    ( Context
+    , Decomp
+    , LNode
+    , LPath
+    , Graph
+
+    , Empty
+    , IsEmpty
+
+    , Match
+    )
+    where
+
+import qualified Types.Data.List     as L
+import qualified Types.Data.List.Ops as L
+import qualified Types.Data.Map      as M
+
+import Types.Data.Bool
+import Types.Data.Maybe
+
+
+-- preNodes, sucNodes: map from node ID to edge label
+data Context preNodes nodeID nodeLabel sucNodes
+
+-- nodeMap: map from node ID to context
+data Graph nodeMap
+
+-- mContext: Maybe Context
+data Decomp mContext graph
+
+-- nodeID: natural number
+data LNode nodeID nodeLabel
+
+-- lNodes: list of LNode
+data LPath lNodes
+
+-- Empty
+type Empty = Graph M.Empty
+
+-- IsEmpty
+type family   IsEmpty g
+type instance IsEmpty (Graph m) = M.Null m
+
+-- Match
+type Match node g = Match' (M.Lookup node g) node g
+
+type family   Match' mContext node g
+type instance Match' Nothing                          node g = Decomp Nothing g
+type instance Match' (Just (Context p node' label s)) node g
+    = Decomp (Just (Context (M.Delete node p)
+                            node
+                            label
+                            (M.Delete node s)))
+             (ClearSucc (ClearPred (M.Delete node g)
+                                   node
+                                   (M.Keys (M.Delete node s)))
+                        node
+                        (M.Keys (M.Delete node p)))
+
+-- ClearSucc
+type family   ClearSucc g n ns
+type instance ClearSucc g n L.Null        = g
+type instance ClearSucc g n (L.Cons s ss)
+    = ClearSucc (M.Adjust (ClearSucc' n) s g) n ss
+
+data ClearSucc' n
+type instance L.App (ClearSucc' n) (Context ps n' l ss)
+    = Context ps n' l (M.Delete n ss)
+
+-- ClearPred
+type family   ClearPred g n ns
+type instance ClearPred g n L.Null        = g
+type instance ClearPred g n (L.Cons p ps)
+    = ClearPred (M.Adjust (ClearPred' n) p g) n ps
+
+data ClearPred' n
+type instance L.App (ClearPred' n) (Context ps n' l ss)
+    = Context (M.Delete n ps) n' l ss
diff --git a/Types/Data/Graph/Dijkstra.hs b/Types/Data/Graph/Dijkstra.hs
new file mode 100644
index 0000000..9a70ee9
--- /dev/null
+++ b/Types/Data/Graph/Dijkstra.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE
+  EmptyDataDecls,
+  TypeFamilies,
+  UndecidableInstances
+  #-}
+module Types.Data.Graph.Dijkstra
+    ( Dijkstra
+    , SpTree
+    , SpLength
+    , Sp
+    )
+    where
+
+import qualified Types.Data.Heap     as H
+import qualified Types.Data.List     as L
+import qualified Types.Data.List.Ops as L
+import qualified Types.Data.Map      as M
+
+import Types.Data.Bool
+import Types.Data.Graph
+import Types.Data.Graph.RootPath
+import Types.Data.Maybe
+import Types.Data.Num
+
+-- Expand
+type family   Expand distance lPath context
+type instance Expand d (LPath p) (Context ps n l ss)
+    = L.Map (Expand' d p) (M.Assocs ss)
+
+data Expand' distance path
+type instance L.App (Expand' d p) (L.Cons n d')
+    = H.Unit (d :+: d')
+             (LPath (L.Cons (LNode n (d :+: d')) p))
+
+-- Dijkstra
+type Dijkstra h g
+    = If (H.IsEmpty h :||: IsEmpty g)
+         L.Null
+         (Dijkstra' h g (H.SplitMin h))
+
+type family   Dijkstra' heap graph min
+type instance Dijkstra' h g (L.Cons d (L.Cons (LPath (L.Cons (LNode n d') ps)) h'))
+    = Dijkstra'' n d' (LPath (L.Cons (LNode n d) ps)) h' (Match n g)
+
+type family   Dijkstra'' node distance lPath heap' decomp
+type instance Dijkstra'' n d p h' (Decomp Nothing  g') = Dijkstra h' g'
+type instance Dijkstra'' n d p h' (Decomp (Just c) g')
+    = L.Cons p (Dijkstra (H.MergeAll (L.Cons h' (Expand d p c))) g')
+
+-- SpTree
+type SpTree node graph
+    = Dijkstra (H.Unit D0 (LPath (L.Cons (LNode node D0) L.Null))) graph
+
+-- SpLength
+type SpLength node1 node2 graph
+    = GetDistance node2 (SpTree node1 graph)
+
+-- Sp
+type Sp node1 node2 graph
+    = GetLPathNodes node2 (SpTree node1 graph)
diff --git a/Types/Data/Graph/RootPath.hs b/Types/Data/Graph/RootPath.hs
new file mode 100644
index 0000000..753f331
--- /dev/null
+++ b/Types/Data/Graph/RootPath.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE
+  EmptyDataDecls,
+  TypeFamilies,
+  UndecidableInstances
+  #-}
+module Types.Data.Graph.RootPath
+    ( GetLPath
+    , GetDistance
+    , GetLPathNodes
+    )
+    where
+
+import qualified Types.Data.List     as L
+import qualified Types.Data.List.Ops as L
+
+import Types.Data.Bool
+import Types.Data.Graph
+import Types.Data.Ord
+
+-- NodeID
+type family   NodeID lNode
+type instance NodeID (LNode nodeID nodeLabel) = nodeID
+
+-- NodeIDA
+data NodeIDA
+type instance L.App NodeIDA lNode = NodeID lNode
+
+-- NodeLabel
+type family   NodeLabel lNode
+type instance NodeLabel (LNode nodeID nodeLabel) = nodeLabel
+
+-- FindP
+type family   FindP node lPaths
+type instance FindP n L.Null                     = L.Null
+type instance FindP n (L.Cons (LPath L.Null) ps) = FindP n ps
+type instance FindP n (L.Cons (LPath (L.Cons (LNode n' l) ns)) ps)
+    = If (n :==: n')
+         (L.Cons (LNode n' l) ns)
+         (FindP n ps)
+
+-- GetLPath
+type GetLPath node lPaths
+    = LPath (GetLPath' node lPaths)
+
+-- GetLPath'
+type GetLPath' node lPaths
+    = L.Reverse (FindP node lPaths)
+
+-- GetDistance
+type GetDistance node lPaths
+    = NodeLabel (L.Head (FindP node lPaths))
+
+-- GetLPathNodes
+type GetLPathNodes node lPaths
+    = L.Map NodeIDA (GetLPath' node lPaths)
diff --git a/Data/HList/Heap.hs b/Types/Data/Heap.hs
similarity index 88%
rename from Data/HList/Heap.hs
rename to Types/Data/Heap.hs
index acd479f..0db1489 100644
--- a/Data/HList/Heap.hs
+++ b/Types/Data/Heap.hs
@@ -4,7 +4,7 @@
   TypeOperators,
   UndecidableInstances
   #-}
-module Data.HList.Heap
+module Types.Data.Heap
     ( Heap
 
     , Empty
@@ -19,7 +19,7 @@ module Data.HList.Heap
     )
     where
 
-import Data.HList
+import Types.Data.List
 import Types.Data.Bool
 import Types.Data.Ord
 
@@ -31,7 +31,7 @@ class Heap h
 instance Heap Empty
 instance Heap hs => Heap (Node k v hs)
 
-type Unit k v = Node k v Nil
+type Unit k v = Node k v Null
 
 type family   IsEmpty h
 type instance IsEmpty Empty         = True
@@ -48,8 +48,8 @@ type instance Merge (Node k1 v1 hs1) (Node k2 v2 hs2)
         (Node k2 v2 (Cons (Node k1 v1 hs1) hs2))
 
 type family   MergeAll hs
-type instance MergeAll Nil          = Empty
-type instance MergeAll (Cons h Nil) = h
+type instance MergeAll Null          = Empty
+type instance MergeAll (Cons h Null) = h
 type instance MergeAll (Cons h (Cons h' hs))
     = Merge (Merge h h') (MergeAll hs)
 
diff --git a/Types/Data/Map.hs b/Types/Data/Map.hs
index 6cb61c6..9f12a5d 100644
--- a/Types/Data/Map.hs
+++ b/Types/Data/Map.hs
@@ -90,18 +90,16 @@ 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)
+type family   CompCase o  ifLT ifGT ifEQ
+type instance CompCase LT ifLT ifGT ifEQ = ifLT
+type instance CompCase GT ifLT ifGT ifEQ = ifGT
+type instance CompCase EQ ifLT ifGT ifEQ = ifEQ
 
 -- Lookup
 type family   Lookup k m
 type instance Lookup k Tip              = Nothing
 type instance Lookup k (Bin s k' v l r)
-    = CompCase k k'
+    = CompCase (Compare k k')
                (Lookup k l)
                (Lookup k r)
                (Just v)
@@ -110,7 +108,7 @@ type instance Lookup k (Bin s k' v l r)
 type family   LookupAssoc k m
 type instance LookupAssoc k Tip              = Nothing
 type instance LookupAssoc k (Bin s k' v l r)
-    = CompCase k k'
+    = CompCase (Compare k k')
                (LookupAssoc k l)
                (LookupAssoc k r)
                (Just (Cons k v))
@@ -138,7 +136,7 @@ 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)
-    = CompCase k k'
+    = CompCase (Compare k k')
                (Balance k' v' (Insert k v l) r)
                (Balance k' v' l (Insert k v r))
                (Bin s k v l r)
@@ -147,7 +145,7 @@ type instance Insert k v (Bin s k' v' l r)
 type family   Delete k m
 type instance Delete k Tip              = Tip
 type instance Delete k (Bin s k' v l r)
-    = CompCase k k'
+    = CompCase (Compare k k')
                (Balance k' v (Delete k l) r)
                (Balance k' v l (Delete k r))
                (Glue l r)
@@ -158,12 +156,14 @@ type Ratio = D2
 
 type Balance k v l r
     = If ((Size l :+: Size r) :<=: D1)
-         (Bin (Size l :+: Size r :+: D1) k v l r)
+         (Bin (SizeX l r) k v l r)
          (If (Size r :>=: (Delta :*: Size l))
              (RotateL k v l r)
              (If (Size l :>=: (Delta :*: Size r))
                  (RotateR k v l r)
-                 (Bin (Size l :+: Size r :+: D1) k v l r)))
+                 (Bin (SizeX l r) k v l r)))
+
+type SizeX l r = Size l :+: Size r :+: D1
 
 -- Rotate
 type family   RotateL k v l r
@@ -282,12 +282,14 @@ type instance App2 (AdjustWithKey' f) k v = Just (App2 f k v)
 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'
+    = CompCase (Compare 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))
+               (UpdateWithKey' s k' (App2 f k' v) l r)
+
+type family   UpdateWithKey' s k mv l r
+type instance UpdateWithKey' s k (Just v) l r = Bin s k v l r
+type instance UpdateWithKey' s k Nothing  l r = Glue l r
 
 -- Map
 type MapValue f m = MapWithKey (MapValue' f) m
diff --git a/rrdtool.cabal b/rrdtool.cabal
index 2f8385e..6cd8401 100644
--- a/rrdtool.cabal
+++ b/rrdtool.cabal
@@ -34,10 +34,12 @@ Library
         Database.RRDtool.Create
         Database.RRDtool.Expression
         Data.HList
-        Data.HList.Heap
-        Data.HList.Graph
         Data.HList.Prelude
         Data.HList.String
+        Types.Data.Graph
+        Types.Data.Graph.Dijkstra
+        Types.Data.Graph.RootPath
+        Types.Data.Heap
         Types.Data.List.Ops
         Types.Data.Map
         Types.Data.Maybe
-- 
2.40.0