diff --git a/dag.cabal b/dag.cabal --- a/dag.cabal +++ b/dag.cabal @@ -1,10 +1,10 @@ Name: dag -Version: 0.0.2.1 +Version: 0.1 Author: Athan Clark Maintainer: Athan Clark License: BSD3 License-File: LICENSE -Synopsis: Basic type-safe directed acyclic graphs. +Synopsis: Compile-time, type-safe directed acyclic graphs. Description: This is a type-safe approach for a directed acyclic graph. . @@ -46,10 +46,10 @@ > > getSpanningTrees $ edges > :: Data.Proxy.Proxy - > '['Node "foo" '['Node "bar" '['Node "baz" '[]], - > 'Node "baz" '[]], - > 'Node "bar" '['Node "baz" '[]], - > 'Node "baz" '[]] + > '['Node "foo" '['Node "bar" '['Node "baz" '[]] + > ,'Node "baz" '[]] + > ,'Node "bar" '['Node "baz" '[]] + > ,'Node "baz" '[]] > > *Data.Graph.DAG> reflect $ getSpanningTrees $ edges > @@ -58,8 +58,40 @@ > ,Node "bar" [Node "baz" []] > ,Node "baz" []] . + We can also look at the edges, first-class: + . + > *Data.Graph.DAG> fcEdges edges + > + > [("foo","bar"),("foo","baz"),("bar","baz")] + . + Node construction is done with a uniquely keyed (inductive) map: + . + > data Cool = AllRight | Radical | SuperDuper deriving (Show, Eq) + > nodes = + > nadd "foo" AllRight $ + > nadd "bar" Radical $ + > nadd "baz" SuperDuper $ + > nempty + . + Note that a @NodeSchema@'s keys don't have to be in-sync with it's paired + @EdgeSchema@. After we have both, we can construct a @DAG@: + . + > graph = DAG edges nodes + . + Now we can do fun things, like get the spanning tree of a node: + . + > *Data.Graph.DAG> gtree "foo" graph + > + > Just (AllRight :@-> [Radical :@-> [SuperDuper :@-> []] + > ,SuperDuper :@-> []]) + . This library is still very naive, but it will give us compile-time enforcement of acyclicity (and uniqueness) in these graphs - ideal for dependency graphs. + . + The main deficiency of this graph is that our @EdgeSchema@ can't be + /deconstructed/ soundly - there is just too much information loss between the + value and type levels. This means we can't delete edges or look inside, but we + can still add edges or work with the resulting structure. Cabal-Version: >= 1.10 Build-Type: Simple diff --git a/src/Data/Graph/DAG.hs b/src/Data/Graph/DAG.hs --- a/src/Data/Graph/DAG.hs +++ b/src/Data/Graph/DAG.hs @@ -7,50 +7,40 @@ module Data.Graph.DAG ( module Data.Graph.DAG.Edge , module Data.Graph.DAG.Edge.Utils + , module Data.Graph.DAG.Node , DAG (..) , glookup ) where import Data.Graph.DAG.Edge import Data.Graph.DAG.Edge.Utils +import Data.Graph.DAG.Node import Data.List (lookup) import Data.Singletons import Data.Proxy - --- | The graph may be not connected -data DAG es a = forall x unique. GNil (EdgeSchema es x unique) - | GCons String a (DAG es a) - -instance Functor (DAG es) where - fmap f (GNil e) = GNil e - fmap f (GCons k x xs) = GCons k (f x) $ - fmap f xs - -{- --- | Convenience function. --- getEdgeSchema :: DAG es -getEdgeSchema (GNil e) = e -getEdgeSchema (GCons _ _ gs) = getEdgeSchema gs --} +import Data.Maybe (fromJust) --- | A simple @Data.Map.lookup@ duplicate. -glookup :: String -> DAG es a -> Maybe a -glookup _ (GNil _) = Nothing -glookup k (GCons k2 a gs) | k == k2 = Just a - | otherwise = glookup k gs +-- | A (potentially sparse) directed acyclic graph, composed of edges and nodes. +data DAG es x u a = DAG { getEdgeSchema :: (EdgeSchema es x u) + , getNodeSchema :: (NodeSchema a) + } --- | Get the spanning trees of an @EdgeSchema@. Operate on the assumtion that --- the data returned is actually @[Tree String]@. -espanningtrees :: SingI (SpanningTrees' es '[]) => - EdgeSchema es x unique - -> Demote (SpanningTrees' es '[]) -espanningtrees = reflect . getSpanningTrees +instance Functor (DAG es x u) where + fmap f (DAG es xs) = DAG es $ fmap f xs --- gspanningtrees +-- | @Data.Map.lookup@ duplicate. +glookup :: String -> DAG es x u a -> Maybe a +glookup k (DAG _ xs) = nlookup k xs +-- | Spanning trees of a graph. +gspanningtrees :: SingI (SpanningTrees' es '[]) => + DAG es x u a -> [RTree a] +gspanningtrees g = fmap replace $ espanningtrees $ getEdgeSchema g + where + replace = fmap $ fromJust . flip glookup g -{- -gtree :: String -> DAG es a -> Maybe (Tree a) -gtree k g = lookup k $ force $ reflect $ getSpanningTrees $ getEdgeSchema g --} +-- | Spanning tree of a particular node. "A possible tree of possible results" +gtree :: SingI (SpanningTrees' es '[]) => + String -> DAG es x unique a -> Maybe (RTree a) +gtree k g = fmap (fmap $ fromJust . flip glookup g) $ etree k $ getEdgeSchema g diff --git a/src/Data/Graph/DAG/Edge.hs b/src/Data/Graph/DAG/Edge.hs --- a/src/Data/Graph/DAG/Edge.hs +++ b/src/Data/Graph/DAG/Edge.hs @@ -76,15 +76,15 @@ type family DisallowIn (new :: EdgeKind) ( oldLoops :: [(Symbol, [Symbol])] ) - (keyFound :: Bool) :: [(Symbol, [Symbol])] where + (keyFoundYet :: Bool) :: [(Symbol, [Symbol])] where -- When @from ~ key@: DisallowIn ('EdgeType from to) ( '(from, xs) ': es) 'False = '(from, (to ': xs)) ': -- add @to@ to transitive reach list (DisallowIn ('EdgeType from to) es 'True) -- continue -- When @from ~/~ key@, and @from ~/~ head value@ - DisallowIn ('EdgeType from to) ( '(key, vs) ': es ) keyFound = + DisallowIn ('EdgeType from to) ( '(key, vs) ': es ) keyFoundYet = '(key, (PrependIfElem from to vs)) ': -- find the needle if it exists - (DisallowIn ('EdgeType from to) es keyFound) -- continue + (DisallowIn ('EdgeType from to) es keyFoundYet) -- continue -- Basis DisallowIn a '[] 'True = '[] -- search over. -- Growth via append @@ -104,7 +104,8 @@ -> !(EdgeSchema old oldLoops unique) -> EdgeSchema (b ': old) c unique --- | Utility for constructing an @EdgeSchema@ granularly +-- | Utility for constructing an @EdgeSchema@ incrementally without a type +-- signature. unique :: EdgeSchema '[] '[] 'True unique = ENil diff --git a/src/Data/Graph/DAG/Edge/Utils.hs b/src/Data/Graph/DAG/Edge/Utils.hs --- a/src/Data/Graph/DAG/Edge/Utils.hs +++ b/src/Data/Graph/DAG/Edge/Utils.hs @@ -20,31 +20,35 @@ import Data.Singletons.Prelude import Data.Proxy import Data.Monoid +import Data.Foldable (Foldable (foldMap)) import Control.Applicative -- | Trivial rose tree for creating spanning trees. We make control structure -- instances "parallel" (instead of cartesian) by default for simplicity. $(singletons [d| - data Tree a = Node a [Tree a] deriving (Show, Eq, Functor) + data RTree a = a :@-> [RTree a] deriving (Show, Eq, Functor) |]) -instance Applicative Tree where - pure a = Node a [] - (Node f fs) <*> (Node x xs) = Node (f x) $ - zipWith (<*>) fs xs +instance Applicative RTree where + pure a = a :@-> [] + (f :@-> fs) <*> (x :@-> xs) = (f x) :@-> + (zipWith (<*>) fs xs) -instance Monad Tree where +instance Monad RTree where return = pure - (Node x xs) >>= f = case f x of -- Substitution based instance. - (Node y ys) -> Node y $ fmap (>>= f) xs + (x :@-> xs) >>= f = case f x of -- Substitution based instance. + (y :@-> ys) -> y :@-> (fmap (>>= f) xs) -instance Monoid a => Monoid (Tree a) where - mempty = Node mempty [] - (Node x xs) `mappend` (Node y ys) = Node (x `mappend` y) $ - zipWith mappend xs ys +instance Monoid a => Monoid (RTree a) where + mempty = mempty :@-> [] + (x :@-> xs) `mappend` (y :@-> ys) = (x `mappend` y) :@-> + (zipWith mappend xs ys) +instance Foldable RTree where + foldMap f (x :@-> xs) = f x <> foldMap (foldMap f) xs + -- | Gives us a generic way to get our spanning trees of the graph, as a value. --- Credit goes to . +-- Credit goes to . reflect :: forall (a :: k). (SingI a, SingKind ('KProxy :: KProxy k)) => @@ -52,66 +56,123 @@ reflect _ = fromSing (sing :: Sing a) -- | Adds an empty @c@ tree to the list of trees uniquely -type family AppendIfNotElemTrees (c :: k) (trees :: [Tree k]) :: [Tree k] where - AppendIfNotElemTrees c ((Node c xs) ': xss) = (Node c xs) ': xss - AppendIfNotElemTrees c ((Node x xs) ': xss) = (Node x xs) ': +type family AppendIfNotElemTrees (c :: k) (trees :: [RTree k]) :: [RTree k] where + AppendIfNotElemTrees c ((c :@-> xs) ': xss) = (c :@-> xs) ': xss + AppendIfNotElemTrees c ((x :@-> xs) ': xss) = (x :@-> xs) ': (AppendIfNotElemTrees c xss) - AppendIfNotElemTrees c '[] = (Node c '[]) ': '[] + AppendIfNotElemTrees c '[] = (c :@-> '[]) ': '[] -- | Adds @c@ as a child of any tree with a root @t@. Assumes unique roots. type family AddChildTo (test :: k) (child :: k) - (trees :: [Tree k]) :: [Tree k] where - AddChildTo t c ((Node t xs) ': xss) = - (Node t (AppendIfNotElemTrees c xs)) ': (AddChildTo t c xss) - AddChildTo t c ((Node x xs) ': xss) = - (Node x (AddChildTo t c xs)) ': (AddChildTo t c xss) + (trees :: [RTree k]) :: [RTree k] where + AddChildTo t c ((t :@-> xs) ': xss) = + (t :@-> (AppendIfNotElemTrees c xs)) ': (AddChildTo t c xss) + AddChildTo t c ((x :@-> xs) ': xss) = + (x :@-> (AddChildTo t c xs)) ': (AddChildTo t c xss) AddChildTo t c '[] = '[] -- | We need to track if @from@ has is a root node or not. TODO: Some code repeat. type family AddEdge' (edge :: EdgeKind) - (trees :: [Tree Symbol]) + (trees :: [RTree Symbol]) (hasFromRoot :: Bool) - (hasToRoot :: Bool):: [Tree Symbol] where + (hasToRoot :: Bool):: [RTree Symbol] where AddEdge' ('EdgeType from to) '[] 'False 'False = - (Node from ((Node to '[]) ': '[])) ': (Node to '[]) ': '[] + (from :@-> ((to :@-> '[]) ': '[])) ': (to :@-> '[]) ': '[] AddEdge' ('EdgeType from to) '[] 'True 'False = - (Node to '[]) ': '[] + (to :@-> '[]) ': '[] AddEdge' ('EdgeType from to) '[] 'False 'True = - (Node from ((Node to '[]) ': '[])) ': '[] + (from :@-> ((to :@-> '[]) ': '[])) ': '[] AddEdge' x '[] 'True 'True = '[] - AddEdge' ('EdgeType from to) ((Node from xs) ': xss) hasFromRoot hasToRoot = - (Node from (AppendIfNotElemTrees to xs)) ': + AddEdge' ('EdgeType from to) ((from :@-> xs) ': xss) hasFromRoot hasToRoot = + (from :@-> (AppendIfNotElemTrees to xs)) ': (AddEdge' ('EdgeType from to) xss 'True hasToRoot) - AddEdge' ('EdgeType from to) ((Node to xs) ': xss) hasFromRoot hasToRoot = - (Node to (AddEdge' ('EdgeType from to) xs 'True 'True)) ': + AddEdge' ('EdgeType from to) ((to :@-> xs) ': xss) hasFromRoot hasToRoot = + (to :@-> (AddEdge' ('EdgeType from to) xs 'True 'True)) ': (AddEdge' ('EdgeType from to) xss hasFromRoot 'True) -- Go downward, and laterally (I think). - AddEdge' ('EdgeType from to) ((Node x xs) ': xss) hasFromRoot hasToRoot = - (Node x (AddEdge' ('EdgeType from to) xs 'True 'True)) ': + AddEdge' ('EdgeType from to) ((x :@-> xs) ': xss) hasFromRoot hasToRoot = + (x :@-> (AddEdge' ('EdgeType from to) xs 'True 'True)) ': (AddEdge' ('EdgeType from to) xss hasFromRoot hasToRoot) -- | Add @to@ as a child to every @from@ node in the accumulator. type family AddEdge (edge :: EdgeKind) - (trees :: [Tree Symbol]) :: [Tree Symbol] where + (trees :: [RTree Symbol]) :: [RTree Symbol] where AddEdge a trees = AddEdge' a trees 'False 'False -- | Auxilliary function normally defined in a @where@ clause for manual folding. type family SpanningTrees' (edges :: [EdgeKind]) - (acc :: [Tree Symbol]) :: [Tree Symbol] where + (acc :: [RTree Symbol]) :: [RTree Symbol] where SpanningTrees' '[] trees = trees SpanningTrees' (('EdgeType from to) ': es) trees = SpanningTrees' es (AddEdge ('EdgeType from to) trees) -- | Expects edges to already be type-safe -type family SpanningTrees (edges :: [EdgeKind]) :: [Tree Symbol] where +type family SpanningTrees (edges :: [EdgeKind]) :: [RTree Symbol] where SpanningTrees edges = SpanningTrees' edges '[] getSpanningTrees :: EdgeSchema es x unique -> Proxy (SpanningTrees es) getSpanningTrees _ = Proxy + +-- | Get the spanning trees of an @EdgeSchema@. Operate on the assumtion that +-- the data returned is actually @[Tree String]@. +espanningtrees :: SingI (SpanningTrees' es '[]) => + EdgeSchema es x unique + -> Demote (SpanningTrees' es '[]) +espanningtrees = reflect . getSpanningTrees + +-- | Get a single tree. +etree :: SingI (SpanningTrees' es '[]) => + String -> EdgeSchema es x unique -> Maybe (RTree String) +etree k es = getTree k $ espanningtrees es + where + getTree k1 ( n@(k2 :@-> xs) : ns ) | k1 == k2 = Just n + | otherwise = getTree k1 ns + getTree _ [] = Nothing + +-- | Degenerate (but type-safe!) @head@. +ehead :: ( EdgeType from to ~ b + , EdgeValue from to ~ a + ) => EdgeSchema (b ': old) c u -> a +ehead _ = Edge + +-- | For now, we only suport unique edges. +eTreeToEdges :: RTree String -> [(String,String)] +eTreeToEdges = treeToEdges' [] + where + treeToEdges' :: [(String,String)] + -> RTree String + -> [(String,String)] + treeToEdges' zs (_ :@-> []) = zs + treeToEdges' zs (x :@-> xs) = + let newEdges = umerge zs $ map (\q -> (x, getNodeVal q)) xs + in + foldl treeToEdges' newEdges xs + getNodeVal (x :@-> _) = x + -- unique merge + umerge [] ys = ys + umerge (x:xs) ys | x `elem` ys = umerge xs ys + | otherwise = x : umerge xs ys + +-- | Get a first-class list of edges from spanning trees. Only works on uniqely +-- edged @EdgeSchema@'s. +eForestToEdges :: [RTree String] -> [(String,String)] +eForestToEdges xs = foldl (\es t -> umerge es $ eTreeToEdges t) [] xs + where + -- unique merge + umerge [] ys = ys + umerge (x:xs) ys | x `elem` ys = umerge xs ys + | otherwise = x : umerge xs ys + +-- | Get the "First-Class" edges of a uniquely-edged @EdgeSchema@. +fcEdges :: SingI (SpanningTrees' es '[]) => + EdgeSchema es x 'True -> [(String, String)] +fcEdges = eForestToEdges . espanningtrees + +-- eflip e = espanningtrees e