3
$\begingroup$

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]
$\endgroup$
  • $\begingroup$ I posted a preliminary answer. Please have a look. Before I continue the process I need to know if you are using Mathematica 10 or later so I do not waste more time with Associations if you are not. $\endgroup$ – Mr.Wizard Jun 26 '15 at 7:07
  • $\begingroup$ By the way I am not happy with my make["transitive"] code but I wanted to get some ink on the page. I imagine it can be substantially optimized. $\endgroup$ – Mr.Wizard Jun 26 '15 at 7:21
  • $\begingroup$ @Mr. Wizard - thanks much for the input - you can see MMA is not my first language. I am using MMA 10.0.0.0, and I am implementing your code now to try to understand it. $\endgroup$ – Paul R. Jun 26 '15 at 12:52
  • $\begingroup$ @Mr. Wizard - I'm getting the idea, but the make["transitive"] mechanism is still opaque to me. Also, I see that make[transitive]; make[symmetric]; make[reflexive]; does not yield the equivalence, while reversing their order does, because the make[ ] functions do not commute. I would like to not have to worry about the order in which things are implemented, which is why I have the Booleans named "reflexive", "symmetric", and "transitive". Your code is much cleaner and simpler, and I like the idea of thinking of the truth table m as the object to work on, rather than a way to display results. $\endgroup$ – Paul R. Jun 26 '15 at 15:11
  • $\begingroup$ I am glad there seems to be something helpful in there. I should have explicitly stated that make["transitive"] would need to be performed last; sorry. The mechanism is pick a row then for every position at that row in which a 1 occurs select that row from m. Total all selected rows (meaning add values down each column) and add this vector to the original row. Do this for every row in m, then repeat the process i times to make sure any changes are propagated all the way across m. That last step is surely inefficient but I just wanted to get it done. $\endgroup$ – Mr.Wizard Jun 26 '15 at 15:28
1
$\begingroup$

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:

enter image description here

We can perform operations by calling e.g.:

make["symmetric"]

enter image description here

make["reflexive"]

enter image description here

make["transitive"]

enter image description here

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.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.