Relations and Graphs

allRelations[n_]:=allRelations[n]=Module[{r=(n^2)},
Partition[IntegerDigits[#,2,r],n]&/@Range[0,(2^r)-1]]
reflexiveQ[m_]:=(Tr[m]==Length[m])
symmetricQ[m_]:=(Transpose[m]==m)
leq[m1_,m2_]:=(And@@(NonPositive /@ Flatten[m1-m2]))
antisymmetricQ[m_]:=leq[m  Transpose[m],IdentityMatrix[Length[m]]]
transitiveQ[m_]:=leq[m.m /. _?Positive->1,m]
partialOrderQ[m_]:=(reflexiveQ[m]∧antisymmetricQ[m]∧transitiveQ[m])
totalOrderQ[m_]:=(partialOrderQ[m]∧(Position[m+Transpose[m],0]=={}))
functionQ[m_]:=(And@@((Plus@@#==1)&/@m))
permutationQ[m_]:=(functionQ[m]∧functionQ[Transpose[m]])
matOr[m_]:=Plus@@NestList[#.m&,m,Length[m]-1]
connectedQ[m_]:=(Position[matOr[m],0]=={})
simpleQ[m_]:=(Tr[m]==0)∧connectedQ[m]
acyclicQ[m_]:=(Tr[matOr[m]]==0)
choose[n_,v_,an_,sr_]:=Module[{s},
s=aR[[n]];
If[sr≠dc,s=Select[s,Plus@@Flatten[#]==sr&]];
If[v[[1]]≠dc,s=Select[s,If[v[[1]]=="no",!reflexiveQ[#],reflexiveQ[#]]&]];
If[v[[2]]≠dc,s=Select[s,If[v[[2]]=="no",!symmetricQ[#],symmetricQ[#]]&]];
If[v[[3]]≠dc,s=Select[s,If[v[[3]]=="no",!transitiveQ[#],transitiveQ[#]]&]];
If[v[[4]]≠dc,s=Select[s,If[v[[4]]=="no",!antisymmetricQ[#],antisymmetricQ[#]]&]];
If[v[[5]]≠dc,s=Select[s,If[v[[5]]=="no",!totalOrderQ[#],totalOrderQ[#]]&]];
If[v[[6]]≠dc,s=Select[s,If[v[[6]]=="no",!functionQ[#],functionQ[#]]&]];
If[v[[7]]≠dc,s=Select[s,If[v[[7]]=="no",!permutationQ[#],permutationQ[#]]&]];
If[v[[8]]≠dc,s=Select[s,If[v[[8]]=="no",!connectedQ[#],connectedQ[#]]&]];
If[v[[9]]≠dc,s=Select[s,If[v[[9]]=="no",!acyclicQ[#],acyclicQ[#]]&]];
If[v[[10]]≠dc,s=Select[s,If[v[[10]]=="no",!simpleQ[#],simpleQ[#]]&]];
{Length[s],Take[s,Min[Length[s],an]]}]
u={dc="any","no","yes"};
aR=Table[allRelations[n],{n,3}];

Manipulate[
s=choose[n,{eins,zwei,drei,vier,funf,sechs,sieben,acht,neun,zehn},an,sr];g=Map[GraphicsRow[{GraphicsGrid[{{"",Graphics[Table[Text[Style[i,20,"Title"],{i,0}],{i,n}],ImageSize->{50,50}]},{Graphics[Table[Text[Style[n+1-i,20,"Title"],{0,i}],{i,n}],ImageSize->{50,50}],ArrayPlot[#,Mesh->True]}}],GraphPlot[#,SelfLoopStyle->True,VertexLabeling->True,DirectedEdges->True,ImageSize-> {150,150}]}]&,s[[2]]]; 

Pane[
Column[{
If[(eins=="yes")∧(drei=="yes")∧(zwei=="yes"),Text@Style[Row[{"Reflexive, symmetric and transitive relations are called ",Style["equivalence relations.",Red]}],12,"Section",Blue,Italic,Background->LightCyan],""],
If[(eins=="yes")∧(drei=="yes")∧(vier=="yes"),Text@Style[Row[{"Reflexive, antisymmetric and transitive relations are called ",Style["partial orders.",Red]}],12,"Section",Blue,Italic,Background->LightCyan],""],
If[(eins=="yes")∧(drei=="yes"),Text@Style[Row[{"Reflexive and transitive relations are called ",Style["quasiorders.",Red]}],12,"Section",Blue,Italic,Background->LightCyan],""],
If[(zwei=="yes")∧(sechs=="yes"),Text@Style[Row[{"Symmetric functions are called ",Style["involutions.",Red]}],12,"Section",Blue,Italic,Background->LightCyan],""],
Row[{Text@Style["\nThere "<>If[s[[1]]==1,"is only ","are "]<>ToString[s[[1]]]<>" relation"<>If[s[[1]]==1," ","s "]<>"of this type.\n",12,"Section",Blue,Italic,Background->LightCyan]}],If[s[[2]]=={},"",SlideView[g]]}],{400,400}],

{{n,2,"size of the set"},{1,2,3}},
{{sr,dc,"size of the relation"},Join[{dc},Range[(n^2)]],ControlType->PopupMenu},
{{an,5,"amount needed"},Range[5,50,5]},Delimiter,
Style["choose a type of relation\n",Bold],
{{eins,dc,"reflexive"},u},
{{zwei,dc,"symmetric"},u},
{{drei,dc,"transitive"},u},
{{vier,dc,"antisymmetric"},u},
{{funf,dc,"total order"},u},
{{sechs,dc,"function"},u},
{{sieben,dc,"permutation"},u},
{{acht,dc,"connected"},u},
{{neun,dc,"acyclic"},u},
{{zehn,dc,"simple"},u},SaveDefinitions->True,TrackedSymbols->Manipulate]

THIS NOTEBOOK IS THE SOURCE CODE FROM

"Relations and Graphs" from The Wolfram Demonstrations Project
 http://demonstrations.wolfram.com/RelationsAndGraphs/

Contributed by: Jaime Rangel-Mondragon

A full-function Wolfram Mathematica 6 system is required to edit this notebook.
GET WOLFRAM MATHEMATICA 6 »

© The Wolfram Demonstrations Project & Contributors   |   Terms of Use   |   Make a new version of this Demonstration »