{-# LANGUAGE DeriveFunctor #-}
module Tungsten.Structure.Graph
(
GraphF (..), Graph (..)
, empty, vertex, overlay, connect
, foldg
, transpose, hasVertex
, vertices, edges
)
where
import Data.Functor.Classes
import Data.Coerce (coerce)
import Tungsten.Fix
data GraphF a b =
EmptyF
| VertexF a
| OverlayF b b
| ConnectF b b
deriving (Eq, Ord, Show, Read, Functor)
instance Show2 GraphF where
liftShowsPrec2 sa _ sb _ d x =
case x of
EmptyF -> showString "EmptyF"
VertexF a -> showParen (d > 10)
$ showString "VertexF "
. sa 11 a
OverlayF a b -> showParen (d > 10)
$ showString "OverlayF "
. sb 11 a
. showString " "
. sb 11 b
ConnectF a b -> showParen (d > 10)
$ showString "ConnectF "
. sb 11 a
. showString " "
. sb 11 b
instance Show a => Show1 (GraphF a) where
liftShowsPrec = liftShowsPrec2 showsPrec showList
newtype Graph a = Graph (Fix (GraphF a))
instance Show a => Show (Graph a) where
show (Graph g) = show g
instance Functor Graph where
fmap = mapg
instance Applicative Graph where
pure = vertex
(Graph f) <*> (Graph x) = Graph $ buildR $ \fix' ->
let e = fix' EmptyF
o = overlayF fix'
c = overlayF fix'
in
cata (graphF e (\f' -> cata (graphF e (fix' . VertexF . f') o c) x) o c) f
instance Monad Graph where
return = pure
(>>=) = bind
empty :: Graph a
empty = Graph $ fix EmptyF
{-# INLINE empty #-}
vertex :: a -> Graph a
vertex = Graph . fix . VertexF
{-# INLINE vertex #-}
overlay :: Graph a -> Graph a -> Graph a
overlay (Graph a) (Graph b) = Graph $ fix (OverlayF a b)
{-# INLINE overlay #-}
connect :: Graph a -> Graph a -> Graph a
connect (Graph a) (Graph b) = Graph $ fix (ConnectF a b)
{-# INLINE connect #-}
graphF :: p -> (t1 -> p) -> (t2 -> t2 -> p) -> (t2 -> t2 -> p) -> GraphF t1 t2 -> p
graphF e _ _ _ EmptyF = e
graphF _ v _ _ (VertexF x) = v x
graphF _ _ o _ (OverlayF a b) = o a b
graphF _ _ _ c (ConnectF a b) = c a b
{-# INLINE graphF #-}
foldg :: b
-> (a -> b)
-> (b -> b -> b)
-> (b -> b -> b)
-> Graph a
-> b
foldg e v o c = cata (graphF e v o c) . coerce
{-# INLINE foldg #-}
overlayF :: (GraphF a b -> t) -> b -> b -> t
overlayF f = \a b -> f (OverlayF a b)
connectF :: (GraphF a b -> t) -> b -> b -> t
connectF f = \a b -> f (ConnectF a b)
mapg :: (a -> b) -> Graph a -> Graph b
mapg f (Graph g) = Graph $ buildR $ \fix' ->
let go = fix' . graphF EmptyF (VertexF . f) OverlayF ConnectF
in cata go g
{-# INLINE mapg #-}
bind :: Graph a -> (a -> Graph b) -> Graph b
bind (Graph g) f = Graph $ buildR $ \fix' ->
let go = graphF (fix' EmptyF) (cata fix' . coerce . f) (overlayF fix') (connectF fix')
in cata go g
{-# INLINE bind #-}
transpose :: Graph a -> Graph a
transpose (Graph g) = Graph $ buildR $ \fix' ->
let go x =
case x of
ConnectF a b -> fix' $ ConnectF b a
_ -> fix' x
in cata go g
{-# INLINE transpose #-}
hasVertex :: Eq a => a -> Graph a -> Bool
hasVertex v = cata (graphF False (==v) (||) (||)) . coerce
{-# INLINE hasVertex #-}
vertices :: [a] -> Graph a
vertices xs = Graph $ buildR $ \fix' ->
foldr (\x -> fix' . OverlayF (fix' (VertexF x))) (fix' EmptyF) xs
{-# INLINE vertices #-}
edges :: [(a,a)] -> Graph a
edges xs = Graph $ buildR $ \fix' ->
let edge' (u,v) = (fix' $ ConnectF (fix' (VertexF u)) (fix' (VertexF v)))
in foldr (\e -> fix' . OverlayF (edge' e)) (fix' EmptyF) xs
{-# INLINE edges #-}