relations.hs

{-# LANGUAGE NoMonomorphismRestriction, MultiParamTypeClasses, GADTs, StandaloneDeriving,
             TypeFamilies, ConstraintKinds, TypeOperators, TupleSections,
             NoImplicitPrelude #-}

import BasicPrelude hiding ((.), id, Map, Set)
import GHC.Prim
import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Map as M
import qualified Data.Set as S

class RCat cat where
  type CatC cat a :: Constraint
  type CatC cat a = ()
  ----------------------------
  id  :: (CatC cat a)                         => cat a a
  (.) :: (CatC cat a, CatC cat b, CatC cat c) => cat b c -> cat a b -> cat a c

instance RCat (->) where
  id      x = x
  (f . g) x = f (g x)

data Rel :: * -> * -> * where
  IdRel  :: Rel a a
  MapRel :: Map a (Set b) -> Rel a b

deriving instance (Show a, Show b) => Show (Rel a b)
deriving instance (Eq   a, Eq   b) => Eq   (Rel a b)

instance RCat Rel where
  type CatC Rel e = Ord e
  -----------------------
  id = IdRel
  -----------------------
  IdRel . r     = r
  r     . IdRel = r
  --------------------------------------------------------------
  MapRel rF . MapRel rG = MapRel $ M.map f rG
    where f es = S.fromList $ S.toList es >>= S.toList . (rF M.!)

nilRel = MapRel M.empty

zipFst = map (\kvs -> (fst (head kvs), map snd kvs)) . groupBy ((==) `on` fst)
shrink = M.fromList . map (second S.fromList) . zipFst

expand (MapRel r) = concat $ M.elems $ M.mapWithKey (\k es -> map (k,) (S.toList es)) r
expand IdRel      = let xs = enumFrom minBound in zip xs xs

inv IdRel = IdRel
inv r     = MapRel $ shrink $ sortBy (comparing fst) $ map swap $ expand r

isect IdRel IdRel       = IdRel
isect IdRel (MapRel rG) = MapRel $ M.mapMaybeWithKey (\k es -> S.singleton k <$ S.lookupIndex k es) rG
isect x     IdRel       = isect IdRel x
isect rF    rG          = MapRel $ shrink $ intersect (expand rF) (expand rG)

v -*> vs = (v, S.fromList vs)

rel54 :: Rel Int Int
rel54 = MapRel $ M.fromList edges
  where
    edges =
      [ 1  -*> [3,4,5,6,7,9]
      , 2  -*> [1,3,4,5,6,7,8,9,10]
      , 3  -*> [4,5,6,7,9]
      , 4  -*> [6,7,9]
      , 5  -*> [4,6,7,9]
      , 6  -*> [9]
      , 7  -*> [6,9]
      , 8  -*> [1,3,4,5,6,7,9,10]
      , 10 -*> [1,3,4,5,6,7,9]
      ]

refl     r = isect r IdRel /= nilRel
antirefl r = isect r IdRel == nilRel

symm  r = r == inv r
asymm r = isect r (inv r) == nilRel