Defining an arbitrary binary relation

Question

I am trying to define some binary operators. A binary operator operates on a set of variables V and is defined by a subset S of pairs of those variables {Vi,Vj}. For example, "=",">",">=" are all binary operators that are already implemented in Mathematica. I would like to use Tilde[ ] as the "set" operator, analogous to "=" and TildeTilde[ ] as the test operator, analogous to "==". I will use a~~b here to represent TildeTilde[a,b]. I would like to be able to specify the operator as having any combination of three properties: Reflexive (x~~x is True for all x), symmetric (if x~~y then y~~x for all x,y) and transitive (if x~~y and y~~z then x~~z for all x,y,z). Perhaps I would specify other properties, and test various theorems on binary operators. The following code implements this in a very klugy way, but it works. I wonder if there is an elegant way of doing this? I looked at Can I define an axiomatic (Boolean algebra) system and prove theorems using Mathematica? and maybe I am asking too much.

The following code does what I want, but I am interested in a more elegant solution.

Tilde[a_, b_] := Module[{Change, SS},
  If[Length[S] == 0, S = {{a, b}}, S = Append[S, {a, b}]];
  If[Length[V] == 0, V = {a, b}, V = Union[Flatten[{V, a, b}]]];
  SS = S;
  Change = True;
  While[Change, {
    Change = False;
    If[reflexive, SS = MakeReflexive[S]];
    If[S != SS, Change = True];
    S = SS;
    If[symmetric, SS = MakeSymmetric[S]];
    If[S != SS, Change = True];
    S = SS;
    If[transitive, SS = MakeTransitive[S]];
    If[S != SS, Change = True];
    S = SS;
    }];
  ]

TildeTilde[a_, b_] := MemberQ[S, {a, b}]

MakeReflexive[S_] := Module[{n, nV, i, SS},   (* {a,a} True *)
  SS = S;
  n = Length[SS];
  If[n > 0, {
    nV = Length[V];
    For[i = 1, i <= nV, i++, SS = Append[SS, {V[[i]], V[[i]]}]];
    SS = Union[SS];  (* Remove duplicates *)
    }];
  SS
  ]

MakeSymmetric[S_] := Module[{n, i, SS},   (* {a,b} in S => {b,a} in S *)
  SS = S;
  n = Length[SS];
  If[n > 0, {
    For[i = 1, i <= n, i++, SS = Append[SS, {S[[i, 2]], S[[i, 1]]}]];
    SS = Union[SS];  (* Remove duplicates *)
    }];
  SS
  ]

MakeTransitive[S_] := Module[{SS, n, i, j},  (* {a,c} in S and {c,b} in S => {a,b} in S *)
  SS = S;
  n = Length[SS];
  If[n > 0, {
    For[i = 1, i <= n, i++, {For[j = 1, j <= n, j++,
       If[S[[i, 2]] == S[[j, 1]], SS = Append[SS, {S[[i, 1]], S[[j, 2]]}]];
    ]}];
    SS = Union[SS];  (* Remove duplicates *)
    }];
  SS
  ]

STable[S_] := Module[{n, i, j, table}, (* Generate truth table for binary relation *)
  n = Length[V];
  table = Array["?" &, {n, n}];
  For[i = 1, i <= n, i++, {For[j = 1, j <= n, j++, {
      If[V[[i]] \[TildeTilde] V[[j]], table[[i, j]] = 1, table[[i, j]] = 0, table[[i,j]] = "?"];
      }]}];
  MatrixForm[table]
  ]

Now I can observe an equivalence truth table with:

ClearAll[a, b, c, d, e, f, x, y, S, V, reflexive, symmetric, transitive]
reflexive = True;
symmetric = True;
transitive = True;
V = {x, y}; (* include variables that might not be related to any other variable *)
a \[Tilde] b;
a \[Tilde] c;
d \[Tilde] e;
f \[Tilde] f;
Print["V=", V];
Print["S=", S];
STable[S]

Answer 1

I have a couple of ideas that might be improvements over what you are doing but they are neither fully realized nor tested. Consider this answer a work in progress.

Matrix operations

The first is to operate on the truth table itself with matrix operations. Probably this will be faster in some cases and slower in others than what you are doing now. I do find it more "elegant" by my own sensibility.

I shall use an Association idx to keep track of the variables and a mapping to positions in the matrix, m. When variable is used I shall check with KeyFreeQ (undocumented) if it exists in idx, and if not I shall expand m and increment the symbol i.

m = {{}};
idx = <||>;
i = 0;

addKey[x_] /; KeyFreeQ[idx, x] := (
  idx[x] = ++i;
  m = PadRight[m, {i, i}];
 )

Tilde[a_, b_] := (
  addKey /@ {a, b};
  m[[idx @ a, idx @ b]] = 1;
 )

Operations are defined in terms of and acting upon the matrix m:

make["symmetric"] := (m = Unitize[m + m\[Transpose]];)

make["reflexive"] := (m = Unitize[m + IdentityMatrix @ i];)

make["transitive"] :=
  Do[
    m[[n]] = Unitize[ m[[n]] + Total @ Pick[m, m[[n]], 1] ],
    {i}, {n, i}
  ]

To see changes in action create a Dynamic expression with:

Dynamic @ TableForm[m, TableHeadings -> ({#, #} & @ Keys @ idx)]

Now add some rules:

a \[Tilde] b;
c \[Tilde] b;
b \[Tilde] d;
d \[Tilde] e;
f \[Tilde] f;
addKey /@ {x, y};

The table becomes:

We can perform operations by calling e.g.:

make["symmetric"]

make["reflexive"]

make["transitive"]

One could make these updating steps part of the Tilde function itself but I suspect that to get any advantage from the matrix method one will need to use a separate update[] function after making multiple rules.

The TildeTilde function could be defined:

TildeTilde[a_, b_] /; KeyMemberQ[idx, a] && KeyMemberQ[idx, b] :=
   1 == m[[idx @ a, idx @ b]]

Tested:

e \[TildeTilde] c
a \[TildeTilde] x

True

False

Regarding symmetry also see the Attribute Orderless but know that it will also change the way \[TildeTilde] expressions are displayed; I don't know if this is acceptable to you so I left it out of my code.