working on graphs...

diff --git a/Data/HList/Graph.hs b/Data/HList/Graph.hs
deleted file mode 100644 (file)
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 (file)
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 (file)
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 (file)
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 acd479fb962091308158adf6f2fd36987ce3bb2a..0db148984390f6cc6bb5965e80340ad273467fad 100644 (file)
--- a/Data/HList/Heap.hs
+++ b/Types/Data/Heap.hs
@@ -4,7 +4,7 @@
   TypeOperators,
   UndecidableInstances
   #-}
   TypeOperators,
   UndecidableInstances
   #-}

-module Data.HList.Heap
+module Types.Data.Heap

     ( Heap
 
     , Empty
     ( Heap
 
     , Empty


@@ -19,7 +19,7 @@ module Data.HList.Heap
     )
     where
 
     )
     where
 

-import Data.HList
+import Types.Data.List

 import Types.Data.Bool
 import Types.Data.Ord
 
 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)
 
 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
 
 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
         (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)
 
 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 6cb61c62b2f5bc015a29eb141b736c9d722a5689..9f12a5d56e9afe3186aa216c17bfc2aac40fd847 100644 (file)
--- 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 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)
 
 -- 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)
                (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)
 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))
                (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)
 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)
                (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)
 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)
                (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)
 
 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)
          (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
 
 -- 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)
 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))
                (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
 
 -- Map
 type MapValue f m = MapWithKey (MapValue' f) m

diff --git a/rrdtool.cabal b/rrdtool.cabal
index 2f8385eb6962190349773a9989bcc4e357640082..6cd84016f42bb473f7b57e1e43fd0f4975b0a0a9 100644 (file)
--- a/rrdtool.cabal
+++ b/rrdtool.cabal
@@ -34,10 +34,12 @@ Library
         Database.RRDtool.Create
         Database.RRDtool.Expression
         Data.HList
         Database.RRDtool.Create
         Database.RRDtool.Expression
         Data.HList

-        Data.HList.Heap
-        Data.HList.Graph

         Data.HList.Prelude
         Data.HList.String
         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
         Types.Data.List.Ops
         Types.Data.Map
         Types.Data.Maybe