module Data.Graph.DAG.Edge.Utils where
import Data.Graph.DAG.Edge
import GHC.TypeLits
import Data.Singletons.TH
import Data.Singletons.Prelude
import Data.Proxy
import Data.Monoid
import Data.Foldable (Foldable (foldMap))
import Control.Applicative
$(singletons [d|
data RTree a = a :@-> [RTree a] deriving (Show, Eq, Functor)
|])
instance Applicative RTree where
pure a = a :@-> []
(f :@-> fs) <*> (x :@-> xs) = (f x) :@->
(zipWith (<*>) fs xs)
instance Monad RTree where
return = pure
(x :@-> xs) >>= f = case f x of
(y :@-> ys) -> y :@-> (fmap (>>= f) xs)
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
reflect ::
forall (a :: k).
(SingI a, SingKind ('KProxy :: KProxy k)) =>
Proxy a -> Demote a
reflect _ = fromSing (sing :: Sing a)
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 '[] = (c :@-> '[]) ': '[]
type family AddChildTo (test :: k)
(child :: k)
(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 '[] = '[]
type family AddEdge' (edge :: EdgeKind)
(trees :: [RTree Symbol])
(hasFromRoot :: Bool)
(hasToRoot :: Bool):: [RTree Symbol] where
AddEdge' ('EdgeType from to) '[] 'False 'False =
(from :@-> ((to :@-> '[]) ': '[])) ': (to :@-> '[]) ': '[]
AddEdge' ('EdgeType from to) '[] 'True 'False =
(to :@-> '[]) ': '[]
AddEdge' ('EdgeType from to) '[] 'False 'True =
(from :@-> ((to :@-> '[]) ': '[])) ': '[]
AddEdge' x '[] 'True 'True = '[]
AddEdge' ('EdgeType from to) ((from :@-> xs) ': xss) hasFromRoot hasToRoot =
(from :@-> (AppendIfNotElemTrees to xs)) ':
(AddEdge' ('EdgeType from to) xss 'True hasToRoot)
AddEdge' ('EdgeType from to) ((to :@-> xs) ': xss) hasFromRoot hasToRoot =
(to :@-> (AddEdge' ('EdgeType from to) xs 'True 'True)) ':
(AddEdge' ('EdgeType from to) xss hasFromRoot '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)
type family AddEdge (edge :: EdgeKind)
(trees :: [RTree Symbol]) :: [RTree Symbol] where
AddEdge a trees = AddEdge' a trees 'False 'False
type family SpanningTrees' (edges :: [EdgeKind])
(acc :: [RTree Symbol]) :: [RTree Symbol] where
SpanningTrees' '[] trees = trees
SpanningTrees' (('EdgeType from to) ': es) trees =
SpanningTrees' es (AddEdge ('EdgeType from to) trees)
type family SpanningTrees (edges :: [EdgeKind]) :: [RTree Symbol] where
SpanningTrees edges = SpanningTrees' edges '[]
getSpanningTrees :: EdgeSchema es x unique -> Proxy (SpanningTrees es)
getSpanningTrees _ = Proxy
espanningtrees :: SingI (SpanningTrees' es '[]) =>
EdgeSchema es x unique
-> Demote (SpanningTrees' es '[])
espanningtrees = reflect . getSpanningTrees
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
ehead :: ( EdgeType from to ~ b
, EdgeValue from to ~ a
) => EdgeSchema (b ': old) c u -> a
ehead _ = Edge
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
umerge [] ys = ys
umerge (x:xs) ys | x `elem` ys = umerge xs ys
| otherwise = x : umerge xs ys
eForestToEdges :: [RTree String] -> [(String,String)]
eForestToEdges xs = foldl (\es t -> umerge es $ eTreeToEdges t) [] xs
where
umerge [] ys = ys
umerge (x:xs) ys | x `elem` ys = umerge xs ys
| otherwise = x : umerge xs ys
fcEdges :: SingI (SpanningTrees' es '[]) =>
EdgeSchema es x 'True -> [(String, String)]
fcEdges = eForestToEdges . espanningtrees