-- # Software Tools for Discrete Mathematics
module Stdm10Relations where

import Stdm06LogicOperators
import Stdm08SetTheory

-- # Chapter 10.  Relations
type Relation a = Set (a, a)

type Digraph a = (Set a, Relation a)

domain :: (Eq a, Show a, Eq b, Show b) => Set (a, b) -> Set a
domain set =
  if not (normalForm set)
    then errfun "domain" set "set"
    else map fst set

codomain :: (Eq a, Show a, Eq b, Show b) => Set (a, b) -> Set b
codomain set =
  if not (normalForm set)
    then errfun "codomain" set "set"
    else map snd set

isDigraph :: (Eq a, Show a) => Digraph a -> Bool
isDigraph (set, relation) =
  normalForm set /\ normalForm relation

digraphEq :: (Eq a, Show a) => Digraph a -> Digraph a -> Bool
digraphEq digraph1 digraph2 =
  if not (isDigraph digraph1)
    then errfun "digraphEq" digraph1 "digraph"
    else
      if not (isDigraph digraph2)
        then errfun "digraphEq" digraph2 "digraph"
        else
          let (set1, relation1) = digraph1
              (set2, relation2) = digraph2
           in (setEq set1 set2) /\ (setEq relation1 relation2)

isReflexive :: (Eq a, Show a) => Digraph a -> Bool
isReflexive digraph =
  if not (isDigraph digraph)
    then errfun "isReflexive" digraph "digraph"
    else
      let (set, relation) = digraph
       in and [elem (e, e) relation | e <- set]

isIrreflexive :: (Eq a, Show a) => Digraph a -> Bool
isIrreflexive digraph =
  if not (isDigraph digraph)
    then errfun "isIrreflexive" digraph "digraph"
    else
      let (set, relation) = digraph
       in [a | (a, b) <- relation, a == b && elem a set] == []

lessThan_N100 :: Digraph Int
lessThan_N100 =
  let set = [1 .. 100]
   in (set, [(a, b) | a <- set, b <- set, a < b])

equals_N100 :: Digraph Int
equals_N100 =
  let set = [1 .. 100]
   in (set, [(a, b) | a <- set, b <- set, a == b])

greaterThan_N100 :: Digraph Int
greaterThan_N100 =
  let set = [1 .. 100]
   in (set, [(a, b) | a <- set, b <- set, a > b])

lessThanOrEq_N100 :: Digraph Int
lessThanOrEq_N100 =
  let set = [1 .. 100]
   in (set, [(a, b) | a <- set, b <- set, a < b \/ a == b])

greaterThanOrEq_N100 :: Digraph Int
greaterThanOrEq_N100 =
  let set = [1 .. 100]
   in (set, [(a, b) | a <- set, b <- set, a > b \/ a == b])

notEq_N100 :: Digraph Int
notEq_N100 =
  let set = [1 .. 100]
   in (set, [(a, b) | a <- set, b <- set, not (a == b)])

isSymmetric :: (Eq a, Show a) => Digraph a -> Bool
isSymmetric digraph =
  if not (isDigraph digraph)
    then errfun "isSymmetric" digraph "digraph"
    else
      let (set, relation) = digraph
       in and
            [ (elem (a, b) relation) ==> (elem (b, a) relation)
              | a <- set,
                b <- set
            ]

isAntisymmetric :: (Eq a, Show a) => Digraph a -> Bool
isAntisymmetric digraph =
  if not (isDigraph digraph)
    then errfun "isAntisymmetric" digraph "digraph"
    else
      let (set, relation) = digraph
       in and
            [ ((elem (x, y) relation) /\ (elem (y, x) relation))
                ==> (x == y)
              | x <- set,
                y <- set
            ]

isTransitive :: (Eq a, Show a) => Digraph a -> Bool
isTransitive digraph =
  if not (isDigraph digraph)
    then errfun "isTransitive" digraph "digraph"
    else
      let (set, relation) = digraph
       in and
            [ ((elem (x, y) relation) /\ (elem (y, z) relation))
                ==> (elem (x, z) relation)
              | x <- set,
                y <- set,
                z <- set
            ]

relationalComposition ::
  (Show a, Eq b, Show c, Show b, Eq c, Eq a) =>
  Set (a, b) ->
  Set (b, c) ->
  Set (a, c)
relationalComposition set1 set2 =
  if not (normalForm set1)
    then errfun "relationalComposition" set1 "relation"
    else
      if not (normalForm set2)
        then errfun "relationalComposition" set2 "relation"
        else normalizeSet [(a, c) | (a, b) <- set1, (b', c) <- set2, b == b']

equalityRelation :: (Eq a, Show a) => Set a -> Relation a
equalityRelation set =
  if not (normalForm set)
    then errfun "equalityRelation" set "set"
    else [(e, e) | e <- set]

relationalPower :: (Eq a, Show a) => Digraph a -> Int -> Relation a
relationalPower digraph power =
  if not (isDigraph digraph)
    then errfun "relationalPower" digraph "digraph"
    else relationalPowerLoop digraph power
  where
    relationalPowerLoop (set, relation) 0 =
      equalityRelation set
    relationalPowerLoop (set, relation) n =
      relationalComposition
        (relationalPowerLoop (set, relation) (n - 1))
        relation

reflexiveClosure :: (Eq a, Show a) => Digraph a -> Digraph a
reflexiveClosure digraph =
  if not (isDigraph digraph)
    then errfun "reflexiveClosure" digraph "digraph"
    else
      let (set, relation) = digraph
       in (set, relation +++ (equalityRelation set))

inverse :: Set (a, b) -> Set (b, a)
inverse set = [(b, a) | (a, b) <- set]

symmetricClosure :: (Eq a, Show a) => Digraph a -> Digraph a
symmetricClosure digraph =
  if not (isDigraph digraph)
    then errfun "symmetricClosure" digraph "digraph"
    else
      let (set, relation) = digraph
       in (set, relation +++ (inverse relation))

transitiveClosure :: (Eq a, Show a) => Digraph a -> Digraph a
transitiveClosure digraph =
  if not (isDigraph digraph)
    then errfun "transitiveClosure" digraph "digraph"
    else
      let (set, relation) = digraph
          len = length set
          loop n power =
            if (n > len)
              then []
              else
                power
                  +++ ( loop
                          (n + 1)
                          (relationalComposition power relation)
                      )
       in (set, loop 1 relation)

isPartialOrder :: (Eq a, Show a) => Digraph a -> Bool
isPartialOrder digraph =
  if not (isDigraph digraph)
    then errfun "isPartialOrder" digraph "digraph"
    else
      isReflexive digraph
        /\ ( isAntisymmetric digraph
               /\ isTransitive digraph
           )

remTransArcs :: (Eq a, Show a) => Relation a -> Relation a
remTransArcs relation =
  relation ~~~ [(x, z) | (x, y) <- relation, (y', z) <- relation, y == y']

remRelArcs :: (Eq a, Show a) => Relation a -> Relation a
remRelArcs relation = relation ~~~ [(x, y) | (x, y) <- relation, x == y]

remReflexTransArcs :: (Eq a, Show a) => Relation a -> Relation a
remReflexTransArcs relation =
  remTransArcs (remRelArcs relation)

isWeakest :: (Eq a, Show a) => Relation a -> a -> Bool
isWeakest relation a =
  if not (normalForm relation)
    then errfun "isWeakest" relation "relation"
    else and [a /= c | (b, c) <- remReflexTransArcs relation]

isGreatest :: (Eq a, Show a) => Relation a -> a -> Bool
isGreatest set a =
  if not (normalForm set)
    then errfun "isGreatest" set "relation"
    else and [a /= b | (b, c) <- remReflexTransArcs set]

weakestSet :: (Eq a, Show a) => Digraph a -> Set a
weakestSet digraph =
  if not (isDigraph digraph)
    then errfun "weakestSet" digraph "digraph"
    else
      let (set, relation) = digraph
       in filter (isWeakest relation) set

greatestSet :: (Eq a, Show a) => Digraph a -> Set a
greatestSet digraph =
  if not (isDigraph digraph)
    then errfun "greatestSet" digraph "digraph"
    else
      let (set, relation) = digraph
       in filter (isGreatest relation) set

isQuasiOrder :: (Eq a, Show a) => Digraph a -> Bool
isQuasiOrder digraph =
  if not (isDigraph digraph)
    then errfun "isQuasiOrder" digraph "digraph"
    else
      isTransitive digraph
        /\ isIrreflexive digraph

isChain :: (Eq a, Show a) => Set (a, a) -> Bool
isChain rel =
  let loop [] = True
      loop ((a, b) : ps) =
        let new_rel = [pr | pr <- rel, not (pr == (a, b))]
         in if (elem a (codomain new_rel) || elem b (domain new_rel))
              then loop ps
              else False
   in loop rel

isLinearOrder :: (Eq a, Show a) => Digraph a -> Bool
isLinearOrder digraph =
  if not (isDigraph digraph)
    then errfun "isLinearOrder" digraph "digraph"
    else
      if not (isPartialOrder digraph)
        then errfun "isLinearOrder" digraph "partial order"
        else
          let (set, relation) = digraph
           in isChain (remReflexTransArcs relation)

removeFromRelation :: (Eq a, Show a) => a -> Set (a, a) -> Set (a, a)
removeFromRelation elt relation =
  loop relation
  where
    loop [] = []
    loop ((a, b) : relation) =
      if ((elt == a) || (elt == b))
        then loop relation
        else (a, b) : loop relation

removeElt :: (Eq a, Show a) => a -> Digraph a -> Digraph a
removeElt elt (set, relation) =
  ( set ~~~ [elt],
    removeFromRelation elt relation
  )

topsort :: (Eq a, Show a) => Digraph a -> Set a
topsort digraph =
  if not (isPartialOrder digraph)
    then errfun "topsort" digraph "partial order"
    else
      let topsortLoop ([], relation) = []
          topsortLoop (set, []) = []
          topsortLoop digraph =
            min_elt : topsortLoop (removeElt min_elt digraph)
            where
              min_elt = head (weakestSet digraph)
       in topsortLoop digraph

isEquivalenceRelation :: (Eq a, Show a) => Digraph a -> Bool
isEquivalenceRelation digraph =
  if not (isDigraph digraph)
    then errfun "isEquivalenceRelation" digraph "digraph"
    else
      let (set, relation) = digraph
       in ( isReflexive digraph
              /\ (isSymmetric digraph /\ isTransitive digraph)
          )