Graph.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Conic.Graph where

import qualified Data.Vinyl as V
import Data.Vinyl.Functor
import Fcf
import Fcf.Data.Graph
import Fcf.Data.Vinyl

data RGraph :: (u -> *) -> Graph u -> * where
  REmpty :: RGraph f 'Empty
  RVertex :: !(f r) -> RGraph f ('Vertex r)
  ROverlay :: !(RGraph f xs) -> !(RGraph f ys) -> RGraph f ('Overlay xs ys)
  RConnect :: !(RGraph f xs) -> !(RGraph f ys) -> RGraph f ('Connect xs ys)

instance Eq (RGraph f 'Empty) where
  _ == _ = True

instance Eq (f r) => Eq (RGraph f ('Vertex r)) where
  RVertex x == RVertex y = x == y

instance (Eq (RGraph f x), Eq (RGraph f y)) => Eq (RGraph f ('Overlay x y)) where
  ROverlay x y == ROverlay x' y' = x == x' && y == y'

instance (Eq (RGraph f x), Eq (RGraph f y)) => Eq (RGraph f ('Connect x y)) where
  RConnect x y == RConnect x' y' = x == x' && y == y'

edge :: f a -> f b -> RGraph f (Eval (Edge a b))
edge x y = RConnect (RVertex x) (RVertex y)

data VertexList :: Graph a -> Exp [a]

type instance Eval (VertexList 'Empty) = '[]

type instance Eval (VertexList ('Vertex x)) = '[x]

type instance Eval (VertexList ('Overlay x y)) = Eval (LiftM2 (++) (VertexList x) (VertexList y))

type instance Eval (VertexList ('Connect x y)) = Eval (LiftM2 (++) (VertexList x) (VertexList y))

vertexList :: RGraph f xs -> V.Rec f (Eval (VertexList xs))
vertexList REmpty = V.RNil
vertexList (RVertex x) = x V.:& V.RNil
vertexList (ROverlay x y) = rappend (vertexList x) (vertexList y)
vertexList (RConnect x y) = rappend (vertexList x) (vertexList y)

rmap :: (forall x. f x -> g x) -> RGraph f rs -> RGraph g rs
rmap f REmpty = REmpty
rmap f (RVertex x) = RVertex (f x)
rmap f (ROverlay x y) = ROverlay (rmap f x) (rmap f y)
rmap f (RConnect x y) = RConnect (rmap f x) (rmap f y)

rtraverse :: Applicative h => (forall x. f x -> h (g x)) -> RGraph f rs -> h (RGraph g rs)
rtraverse f REmpty = pure REmpty
rtraverse f (RVertex x) = RVertex <$> f x
rtraverse f (ROverlay x y) = ROverlay <$> rtraverse f x <*> rtraverse f y
rtraverse f (RConnect x y) = RConnect <$> rtraverse f x <*> rtraverse f y

rapply :: RGraph (Lift (->) f g) xs -> RGraph f xs -> RGraph g xs
rapply _ REmpty = REmpty
rapply (RVertex f) (RVertex x) = RVertex (getLift f x)
rapply (ROverlay f g) (ROverlay x y) = ROverlay (rapply f x) (rapply g y)
rapply (RConnect f g) (RConnect x y) = RConnect (rapply f x) (rapply g y)

rzipWith :: (forall x. f x -> g x -> h x) -> RGraph f xs -> RGraph g xs -> RGraph h xs
rzipWith f = rapply . rmap (Lift . f)