Alga core

Alga.hs

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

module Alga where

import Data.Set(Set)
import qualified Data.Set as Set


---------------------------------------------------------------------
-- CORE LANGUAGE

data Graph a
    = Empty
    | Vertex a
    | Overlay (Graph a) (Graph a)
    | Connect (Graph a) (Graph a)
      deriving Show

class Graphable g a where
    toGraph :: g a -> Graph a

    empty :: g a
    vertex :: a -> g a
    overlay :: g a -> g a -> g a
    connect :: g a -> g a -> g a

instance Graphable Graph a where
    toGraph = id
    empty = Empty
    vertex = Vertex
    overlay = Overlay
    connect = Connect


---------------------------------------------------------------------
-- GENERIC UTILITIES

fromGraph :: Graphable g a => Graph a -> g a
fromGraph Empty = empty
fromGraph (Vertex x) = vertex x
fromGraph (Overlay a b) = overlay (fromGraph a) (fromGraph b)
fromGraph (Connect a b) = connect (fromGraph a) (fromGraph b)

castGraph :: (Graphable g1 a, Graphable g2 a) => g1 a -> g2 a
castGraph = fromGraph . toGraph

overlays, connects, biconnects :: (Foldable t, Graphable g a) => t (g a) -> g a
overlays = foldr overlay empty
connects = foldr connect empty
biconnects = foldr biconnect empty

biconnect :: Graphable g a => g a -> g a -> g a
biconnect a b = connect a b `overlay` connect b a

clique :: Graphable g a => [a] -> g a
clique = connects . map vertex


---------------------------------------------------------------------
-- RELATION REPRESENTATION

data Relation a = R { domain :: Set a, relation :: Set (a, a) }

instance Ord a => Graphable Relation a where
    toGraph (R d r) = overlays $
        map vertex (Set.toList d) ++
        [connect (vertex a) (vertex b) | (a,b) <- Set.toList r]

    empty = R Set.empty Set.empty
    vertex x = R (Set.singleton x) Set.empty
    overlay a b = R (domain a `Set.union` domain b) (relation a `Set.union` relation b)
    connect x y = R (domain x `Set.union` domain y) (relation x `Set.union` relation y
        `Set.union` (domain x >< domain y))

(><) :: Set a -> Set a -> Set (a, a)
x >< y = Set.fromDistinctAscList [ (a, b) | a <- Set.elems x, b <- Set.elems y ]