Completeness Theorem of Equivalential Calculus

rulesG={{p_,{p_,q_}}:>q,{{p_,q_},r_}:>{p,{q,r}},{p_,{{q_,r_},s_}}:>{p,{q,{r,s}}},{p_,{q_,r_}}:>{p,{r,q}},{p_,{{q_,r_},s_}}:>{p,{r,{q,s}}}};

pletters=CharacterRange["p","v"];

formulaexample={{{{p,q},r},s},{{{{{p,q},r},s},v},a},{{{{{{{p,q},r},s},v},a},b},c},{{{{{{{{{p,q},r},s},v},a},b},c},d},e},{{{{{{{{{{{p,q},r},s},v},a},b},c},d},e},f},g}};

RandomKsublist[set_,k_]:=Module[{sub={},rest=set,new},
Do[new=rest[[RandomInteger[{1,Length[rest]}]]];sub=AppendTo[sub,new];rest=Complement[rest,{new}],{k}];sub];
Randompermut[k_]:=RandomKsublist[Range[k],k];
set2[n_]:=Flatten[Table[{i,j},{i,-n+1,n-1},{j,-n+1,n-1}],1];

taut= {{{2,2}},{{2,2,2},{4,2}},{{2,2,2,2},{4,2,2},{4,4}},{{2,2,2,2,2},{4,2,2,2},{4,4,2}},{{2,2,2,2,2,2},{4,2,2,2,2},{4,4,2,2},{4,4,4}}};

set[k_]:=Module[{kom=Random[Integer,{1,Length[taut[[k]]]}],komb},komb=taut[[k,kom]];Flatten[Table[Table[pletters[[i]],{komb[[i]]}],{i,1,Length[komb]}]][[Randompermut[2k+2]]]];

rulesLetter1={p,q,r,s,v,a,b,c,d,e,f,g};

randformulaT[k_]:=Module[{formula=formulaexample[[k]],kk=Random[Integer,{1,k}],set1,rul},Do[formula=formula/.rulesG,{i,1,kk} ];set1=set[k];rul=Table[rulesLetter1[[i]]->set1[[i]],{i,1,2k+2}];formula/.rul]

setpl=Join[Take[pletters,3],Take[pletters,3],Take[pletters,3],Take[pletters,3]][[Randompermut[12]]];

randformula[k_]:=Module[{formula=formulaexample[[k]],kk=Random[Integer,{1,k}],rul},Do[formula=formula/.rulesG,{i,1,k} ];rul=Table[rulesLetter1[[i]]->setpl[[i]],{i,1,2k+2}];formula/.rul];
Convert[p_]:=(p/;AtomQ[p]);
Convert[{p_,q_}]:=StringJoin["E",Convert[p],Convert[q]];

rules={{p_,{p_,q_}}:>q/;AtomQ[p],{{p_,q_},r_}:>{p,{q,r}},{p_,{{q_,r_},s_}}:>{p,{q,{r,s}}}/;AtomQ[x]&&OccursQ[p,q],{p_,{q_,r_}}:>{p,{r,q}}/;AtomQ[p]&&OccursQ[p,r]&&!OccursQ[p,q],{p_,{{q_,r_},s_}}:>{p,{{r,q},s}}/;AtomQ[p]&&OccursQ[p,r]&&!OccursQ[p,q]};

rulesE={"1. ExExy~y","2. EExyz~ExEyz","3. ExEEyzw~ExEyEzw","4. ExEyz~ExEzy","5. ExEEyzw~ExEzEyw"};

rules1={{p_,{p_,q_}}/;AtomQ[p],{{p_,q_},r_},{p_,{{q_,r_},s_}}/;AtomQ[p]&&OccursQ[p,q],{p_,{q_,r_}}/;AtomQ[p]&&OccursQ[p,r]&&!OccursQ[p,q],{p_,{{q_,r_},s_}}/;AtomQ[p]&&OccursQ[p,r]&&!OccursQ[p,q]};

theq[formula_]:=Module[{expr=formula,theorem=True,mapmatch,pos,subs,formule,subs2,explan={},explan2={},explan2A={}},formule={Convert[expr]};
While[theorem && !MatchQ[expr,{p_,p_}/;AtomQ[p]],mapmatch=Map[MatchQ[expr,#]&,rules1];pos=Position[mapmatch,True];If[!MemberQ[mapmatch,True],theorem=False,subs=Sub1[expr,pos[[1,1]]];subs2=Sub[expr,pos[[1,1]]];expr=(expr/.rules[[pos[[1,1]]]]);formule=Append[formule,Convert[expr]];explan=Append[explan,Row[{pos[[1,1]]/.{1->11,2->15,3->20,4->16,5->19},If[subs=={},"",Table[Row[{Style[subs[[i,1]],Italic],"->",Style[Convert[subs[[i,2]]],Italic]}],{i,1,Length[subs]}]]}]];
explan2A=Append[explan2A,Row[{pos[[1,1]]/.{1->12,2->14,3->21,4->16,5->19},If[subs=={},"",Table[Row[{Style[subs[[i,1]],Italic],"->",Style[Convert[subs[[i,2]]],Italic]}],{i,1,Length[subs]}]]}]]];
explan2=Append[explan2,Row[{pos[[1,1]]/.{1->12,2->14,3->21,4->16,5->19}," ",Style[Convert[theorems[[pos[[1,1]]/.{1->12,2->14,3->21,4->16,5->19}]]/.subs2],Italic]}]]];
{{Map[Style[#,Italic]&,formule],Join[{"given"},explan]},{Reverse[Map[Style[#,Italic]&,formule]],Join[{Row[{6,If[First[expr]=="p","",{Style["p",Italic]->Style[First[expr],Italic]}]}]},Reverse[explan2A]]},{Reverse[Map[Style[#,Italic]&,formule]],Join[{Row[{6,If[First[expr]=="p","",{Style["p",Italic]->Style[First[expr],Italic]}]}]},Reverse[explan2]]}}];

OccursQ[p_,q_]:=If[AtomQ[q],p===q ,MemberQ[Flatten[q],p]];
Sub[expr_,1]:={p->expr[[1]],q->expr[[2,2]] };
Sub[expr_,2]:={p->expr[[1,1]],q->expr[[1,2]],r-> expr[[2]]};
Sub[expr_,3]:={p->expr[[1]],q->expr[[2,1,1]],r-> expr[[2,1,2]],s->expr[[2,2]]};
Sub[expr_,4]:={p->expr[[1]],q->expr[[2,1]],r-> expr[[2,2]]};
Sub[expr_,5]:={p->expr[[1]],q->expr[[2,1,1]],r-> expr[[2,1,2]],s->expr[[2,2]]};
Sub1[expr_,1]:=DeleteCases[{{"p",expr[[1]]},{"q",expr[[2,2]] }},{x_,x_}];
Sub1[expr_,2]:=DeleteCases[{{"p",expr[[1,1]]},{"q",expr[[1,2]]},{"r", expr[[2]]}},{x_,x_}];
Sub1[expr_,3]:=DeleteCases[{{"p",expr[[1]]},{"q",expr[[2,1,1]]},{"r", expr[[2,1,2]]},{"s",expr[[2,2]]}},{x_,x_}];
Sub1[expr_,4]:=DeleteCases[{{"p",expr[[1]]},{"q",expr[[2,1]]},{"r",expr[[2,2]]}},{x_,x_}];
Sub1[expr_,5]:=DeleteCases[{{"p",expr[[1]]},{"q",expr[[2,1,1]]},{"r",expr[[2,1,2]]},{"s",expr[[2,2]]}},{x_,x_}];
theorems={{{p,q},{{r,q},{p,r}}},{{s,{{r,q},{p,r}}},{{p,q},s}},{{p,q},{p,q}},{{r,{p,q}},{{p,q},r}},{{{r,q},{p,r}},{p,q}},{p,p},{{p,q},{q,p}},{{r,{q,p}},{{p,q},r}},{{{p,q},r},{r,{q,p}}},{{r,q},{{p,r},{p,q}}},{{p,{p,q}},q},{q,{p,{p,q}}},{{r,q},{{p,{p,q}},r}},{{p,{q,r}},{{p,q},r}},{{{p,q},r},{p,{q,r}}},{{p,{q,r}},{p,{r,q}}},{{{p,r},{q,p}},{r,q}},{{{p,q},r},{{q,p},r}},{{p,{{q,r},s}},{p,{{r,q},s}}},{{p,{{q,r},s}},{p,{q,{r,s}}}},{{p,{q,{r,s}}},{p,{{q,r},s}}}};
theorems1=theorems/. {p->"p",q->"q",r->"r",s->"s"};
proofs={{1,{p->{p,q},q->{{r,q},{p,r}},r->s},1,{}},{2,{s->{p,q}},1,{}},{1,{p->{p,q},q->{p,q}},3,{}},{4,{r->{p,q},p->{r,q},q->{p,r}},1,{}},{5,{r->p,q->p},3,{q->p}},{1,{p->q,r->p},6,{p->q}},{1,{p->{p,q},q->{q,p}},7,{}},{7,{p->{r,{q,p}},q->{{p,q},r}},8,{}},{2,{s->{{p,r},{p,q}},r->p,p->r},9,{q->r,r->{p,q}}},{5,{r->{p,q},p->{p,{p,q}}},10,{r->{p,q}}},{7,{p->{p,{p,q}}},11,{}},{1,{p->{p,{p,q}}},11,{}},{2,{s->{{p,q},r},r->q,q->{q,r}},13,{r->{p,q},q->r,p->q}},{7,{p->{p,{q,r}},q->{{p,q},r}},14,{}},{9,{p->{r,q},q->p,r->{p,{q,r}}},9,{p->r,r->p}},{16,{p->{{p,r},{q,p}}},5,{r->p,q->r,p->q}},{16,{p->{{p,q},r},q->r,r->{q,p}},9,{}},{10,{r->{{q,r},s},q->{{r,q},s}},18,{p->q,q->r,r->s}},{10,{r->{{q,r},s},q->{q,{r,s}}},15,{p->q,q->r,r->s}},{7,{p->{p,{{q,r},s}},q->{p,{q,{r,s}}}},20,{}}};
proofs1=proofs//. {p->"p",q->"q",r->"r",s->"s"};
proofs2=Table[{proofs1[[i,1]],Table[Row[{Style[#,Italic]&@proofs1[[i,2,j,1]]," -> ",Style[#,Italic]&@Convert[proofs1[[i,2,j,2]]]}],{j,1,Length[proofs1[[i,2]]]}],proofs1[[i,3]],Table[Row[{Style[#,Italic]&@proofs1[[i,4,j,1]]," -> ",Style[#,Italic]&@Convert[proofs1[[i,4,j,2]]]}],{j,1,Length[proofs1[[i,4]]]}]},{i,1,20}];
proofs3=Table[{proofs1[[i,1]],Table[Row[{Style[#,Italic]&@proofs1[[i,2,j,1]]," -> ",Style[#,Italic]&@Convert[proofs1[[i,2,j,2]]]}],{j,1,Length[proofs1[[i,2]]]}],", ",proofs1[[i,3]],If[proofs[[i,4]]=={},"",Table[Row[{Style[#,Italic]&@proofs1[[i,4,j,1]]," -> ",Style[#,Italic]&@Convert[proofs1[[i,4,j,2]]]}],{j,1,Length[proofs1[[i,4]]]}]]},{i,1,20}];
lukth=Row[{Column[Table[Row[{If[i<10," ",""],ToString[i],". ",Style[#,Italic]&@Convert[theorems1[[i]]]}],{i,1,21}]],
Spacer[30],
Column[Join[{"Axiom"},Map[Row,proofs3]]]}];

Manipulate[SeedRandom[ranint];Text@With[{formula={randformulaT[len],randformula[len]}[[Random[Integer,{1,1}]]]},With[{thformula=theq[formula]},Style[Column[{
Switch[
show,1,Text@Column[{lukth}],2,Column[{Text@"Proof that the following equivalential formula",Style[Convert[formula],Italic],Text@"is equivalent to a formula of form ",Style[Convert[{"x","x"}],Italic],"",Text@"Proof:",Row[{Column[thformula[[1,1]]],"  ",Column[thformula[[1,2]]]}]}],3,
Column[{Text@"Proof of the following equivalential formula",Style[Convert[formula],Italic],"",Text@"Proof:",Row[{Column[thformula[[If[shsf,2,3],1]]],"  ",Column[thformula[[If[shsf,2,3],2]]]}]}]
]
}],12]
]],{{ranint,RandomInteger[1233455]},ControlType->None},{{len,1,"length paramether of formula"},Range[4]},Button["new equivalential formula",(*an=0;*)show=2;ranint=RandomInteger[{1,23423}]],{{show,2,""},{1->"show first 21 theorems",2->"eliminate pairs of equal variables",3->"proof of the formula"}},
{{shsf,True,"show substitution/formula"},{True,False},Enabled->show==3},SaveDefinitions->True,ContentSize->{540,450}]

This Demonstration shows examples of Łukasiewicz's completeness theorem for the equivalential calculus. He first derived 21 theorems. Some of these theorems are associative and commutative rules on different parts of a formula. To show that a formula is tautology, he eliminates pairs of same propositional variable eventually to get a formula of the form E x x. The proof of the formula goes in the opposite direction, and modus ponens is used in the form: y follows from E y x and x. The first formula in its proof is a substitution instance of theorem 6, that is of E p p. Each next formula follows by modus ponens from the immediately preceding formula, and from one  of 21 numbered theorems on which a substitution is applied.

The equivalential calculus is a subsystem of propositional calculus with equivalence as the only connective. In 1929 Leśniewski recognized that the equivalential calculus could be axiomatized. He used two axioms and the rules of detachment and substitution. He also observed that a formula of propositional calculus in which equivalence was the only propositional function was a tautology if and only if each propositional letter has even number of appearances in it. In 1932 Wajsberg showed that the calculus can be based on a single axiom. In 1933 Łukasiewicz found the shortest axiom E E p q E E r q E p r and gave a simple completeness proof. He first derived 21 tautologies. Some of them such as E E E p q r E p E q r, were used as rules. The rule E E x y z ~ E x E y z says that a formula of the form E E x y z  is equivalent to E x E y z. A formula of the calculus is a tautology if it is deductively equivalent to E x x, where x is a propositional variable [1]. The realization of the completeness theorem as a Prolog program was given in [3].

In 1981 Hafner gave a more complicated completeness proof showing that the proof length (the number of proof steps) is linear in formula size [2].

[1] J. Łukasiewicz, "The Equivalential Calculus," in Polish Logic (1920–1939), S. McCall, ed., Oxford: Clarendon Press, 1967, pp. 90–91.

[2] I. Hafner, "On Proof length in the Equivalential Calculus," Glasnik Matematički, 15(35), 1980, pp. 233–242.

[3] I. Hafner, "The Completeness Theorem of Equivalential Calculus as a Prolog Program," Logic Programming Newsletter, May 1987, pp. 7–8.

[4] S. Wolfram, A New Kind of Science, Champaign, IL: Wolfram Media, 2002 p. 1170e.

Contributed by: Izidor Hafner