%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Decision procedure for intuitonistic propositional logic
%%% based on contraction-free sequent calculus and inversion.
%%% Author: Frank Pfenning
%%% October 2009
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Auxiliary predicates on lists
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% append is an efficient built-in
% use append_ here for completeness
% append_(+[X], +[Y], -[Z]).
append_([], Ys, Ys).
append_([X|Xs], Ys, [X|Zs]) :-
append_(Xs, Ys, Zs).
% memberchk is an efficient built-in
% use memberchk_ here for completeness
% memberchk_(+X, +[X]).
memberchk_(X, [X|Ys]) :- !.
memberchk_(X, [Y|Ys]) :- memberchk_(X, Ys).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Language and type definitions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% operator precedence declarations,
% in increasing binding strength (= decreasing priority)
:- op(850, xfx, <=>). % iff, non-assoc
:- op(840, xfy, =>). % implies, right assoc
:- op(840, yfx, <=). % if, left assoc
:- op(830, xfy, \/). % or, right assoc
:- op(820, xfy, /\). % and, right assoc
:- op(810, fy, ~). % not, prefix
:- op(800, fy, ?). % atom, prefix
% propositions F, G, with definitions
prop_def(?P).
prop_def(F /\ G) :- prop_def(F), prop_def(G).
prop_def(tt).
prop_def(F \/ G) :- prop_def(F), prop_def(G).
prop_def(ff).
prop_def(F => G) :- prop_def(F), prop_def(G).
prop_def(F <= G) :- prop_def(F), prop_def(G).
prop_def(F <=> G) :- prop_def(F), prop_def(G).
prop_def(~F) :- prop_def(F).
% propositions A, B, C, ..., without defs
prop(?P).
prop(A /\ B) :- prop(A), prop(B).
prop(tt).
prop(A \/ B) :- prop(A), prop(B).
prop(ff).
prop(A => B) :- prop(A), prop(B).
% right synchronous propositions
rsyn(?P).
rsyn(A \/ B) :- prop(A), prop(B).
rsyn(ff).
% left synchronous propositions
lsyn( ?P => B) :- prop(B).
lsyn((D => E) => B) :- prop(D), prop(E), prop(B).
% atoms P
atm(?P).
% expand_defs(+prop_def, -prop).
% expand_defs(F, A)
% if A is the result of expanding definitions in F
expand_defs(?P, ?P).
expand_defs(F /\ G, A /\ B) :-
expand_defs(F, A),
expand_defs(G, B).
expand_defs(tt, tt).
expand_defs(F \/ G, A \/ B) :-
expand_defs(F, A),
expand_defs(G, B).
expand_defs(ff, ff).
expand_defs(F => G, A => B) :-
expand_defs(F, A),
expand_defs(G, B).
expand_defs(F <= G, B => A) :-
expand_defs(F, A),
expand_defs(G, B).
expand_defs(F <=> G, (A => B) /\ (B => A)) :-
expand_defs(F, A),
expand_defs(G, B).
expand_defs(~F, A => ff) :-
expand_defs(F, A).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Decision procedure
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% top-level predicates prove(F) and refute(F)
% prove(+prop_def).
prove(F) :-
expand_defs(F, A),
seqR([], [], [], A).
% refute(+prop_def).
refute(F) :-
expand_defs(F, A),
\+ seqR([], [], [], A).
% Contraction-free sequent calculus with inversion
% All arguments are inputs
% seqR(+[atm], +[lsyn], +[prop], +prop).
% seqL(+[atm], +[lsyn], +[prop], +rsyn).
% chooseR(+[atm], +[lsyn], +rsyn).
% chooseL(+[atm], +[lsyn], +[lsyn], +rsyn).
% seqR(Ps, Is, Hs, A)
% break down right asynchronous proposition A
% right asynchronous cases /\R, ttR, =>R
seqR(Ps, Is, Hs, A /\ B) :-
seqR(Ps, Is, Hs, A),
seqR(Ps, Is, Hs, B).
seqR(Ps, Is, Hs, tt).
seqR(Ps, Is, Hs, A => B) :-
seqR(Ps, Is, [A|Hs], B).
% right synchronous cases \/, ff, ?
seqR(Ps, Is, Hs, A \/ B) :-
seqL(Ps, Is, Hs, A \/ B).
seqR(Ps, Is, Hs, ff) :-
seqL(Ps, Is, Hs, ff).
seqR(Ps, Is, Hs, ?P) :-
seqL(Ps, Is, Hs, ?P).
% seqL(Ps, Is, Hs, C)
% break down left asynchronous propositions Hs
% left asynchronous cases /\L, ttL, \/L, ffL
seqL(Ps, Is, [A /\ B|Hs], C) :-
seqL(Ps, Is, [A,B|Hs], C).
seqL(Ps, Is, [tt|Hs], C) :-
seqL(Ps, Is, Hs, C).
seqL(Ps, Is, [A \/ B|Hs], C) :-
seqL(Ps, Is, [A|Hs], C),
seqL(Ps, Is, [B|Hs], C).
seqL(Ps, Is, [ff|Hs], C).
% left asynchronous cases /\=>L, tt=>L, \/=>L, ff=>L
seqL(Ps, Is, [(D /\ E) => B|Hs], C) :-
seqL(Ps, Is, [D => (E => B)|Hs], C).
seqL(Ps, Is, [tt => B|Hs], C) :-
seqL(Ps, Is, [B|Hs], C).
seqL(Ps, Is, [(D \/ E) => B|Hs], C) :-
seqL(Ps, Is, [D => B, E => B|Hs], C).
seqL(Ps, Is, [ff => B|Hs], C) :-
seqL(Ps, Is, Hs, C).
% left synchronous cases ?, ?=>, =>=>
seqL(Ps, Is, [?P|Hs], C) :-
seqL([?P|Ps], Is, Hs, C).
seqL(Ps, Is, [(?P => B)|Hs], C) :-
seqL(Ps, [(?P => B)|Is], Hs, C).
seqL(Ps, Is, [(D => E) => B|Hs], C) :-
seqL(Ps, [(D => E) => B|Is], Hs, C).
% asynchronous phase complete (Hs = [])
% now apply synchronous rule on right or left
seqL(Ps, Is, [], C) :- chooseR(Ps, Is, C).
seqL(Ps, Is, [], C) :- chooseL(Ps, Is, [], C).
% chooseR(Ps, Is, C)
% break down a synchronous proposition on right
chooseR(Ps, Is, A \/ B) :- seqR(Ps, Is, [], A).
chooseR(Ps, Is, A \/ B) :- seqR(Ps, Is, [], B).
% chooseR(Ps, Is, ff) fails - no right rule
chooseR(Ps, Is, ?P) :- memberchk_(?P,Ps). % init rule
% chooseL(Ps, Is, Js, C)
% break down a synchronous proposition on left
% Js accumulates unused synchronous propositions
chooseL(Ps, [?P => B|Is], Js, C) :-
memberchk_(?P,Ps), !, % in this case, rule is invertible
append_(Is, Js, Ks),
seqL(Ps, Ks, [B], C). % now decompose B asynchronously
chooseL(Ps, [?P => B|Is], Js, C) :-
chooseL(Ps, Is, [?P => B|Js], C).
chooseL(Ps, [(D => E) => B|Is], Js, C) :-
append_(Is, Js, Ks),
seqR(Ps, Ks, [E => B, D], E), % now decompose E, then E => B and D
seqL(Ps, Ks, [B], C). % now decompose B (C is r-synchronous already)
chooseL(Ps, [(D => E) => B|Is], Js, C) :-
chooseL(Ps, Is, [(D => E) => B|Js], C).
% chooseL(Ps, [], Js, C) fails - all possibilities tried
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Test cases
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% note: space or parens are needed for ~ ~A and ~ ?P
:- initialization(prove(?p => ?p)).
:- initialization(refute(?p \/ ~ ?p)).
:- initialization(prove(~ ~(?p \/ ~ ?p))).
:- initialization(prove(~ ~(((?p => ?q) => ?p) => ?p))).
% from SML test harness
:- initialization(prove( ?a => ?a )).
:- initialization(prove( ?a => (?b => ?a) )).
:- initialization(prove( (?a => ?b) => (?a => (?b => ?c)) => (?a => ?c) )).
:- initialization(prove( ~ (~ (((?a => ?b) => ?a) => ?a)) )).
:- initialization(prove( ?a /\ ?b => ?b /\ ?a )).
:- initialization(prove( ?a \/ ?b => ?b \/ ?a )).
:- initialization(prove(
(?p => (?c /\ ?k) \/ (?d /\ ?l))
=> (~ ?k => ?s)
=> (?d \/ ?l)
=> (?p => ~ ?s) /\ (?s => ~ ?p)
=> (?c => ~ ?d) /\ (?d => ~ ?c)
=> (?k => ~ ?l) /\ (?l => ~ ?k)
=> ~ ?p )).
:- initialization(prove( (?a \/ ?c) /\ (?b => ?c) => (?a => ?b) => ?c )).
:- initialization(prove( (?a => ?b => ?c) <=> (?a /\ ?b => ?c) )).
:- initialization(prove( (?a => ?b /\ ?c) <=> (?a => ?b) /\ (?a => ?c) )).
:- initialization(refute( (?a => ?b \/ ?c) => (?a => ?b) \/ (?a => ?c) )).
:- initialization(prove( (?a => ?b \/ ?c) <= (?a => ?b) \/ (?a => ?c) )).
:- initialization(refute( ((?a => ?b) => ?c) => ((?a \/ ?b) /\ (?b => ?c)) )).
:- initialization(prove( ((?a => ?b) => ?c) <= ((?a \/ ?b) /\ (?b => ?c)) )).
:- initialization(prove( (?a \/ ?b => ?c) <=> (?a => ?c) /\ (?b => ?c) )).
:- initialization(prove( (?a /\ (?b \/ ?c)) <=> (?a /\ ?b) \/ (?a /\ ?c) )).
:- initialization(prove( (?a \/ (?b /\ ?c)) <=> (?a \/ ?b) /\ (?a \/ ?c) )).
:- initialization(refute( ~ (?a /\ ?b) => ~ ?a \/ ~ ?b )).
:- initialization(prove( ~ (?a /\ ?b) <= ~ ?a \/ ~ ?b )).
:- initialization(prove( ~ (?a \/ ?b) <=> ~ ?a /\ ~ ?b )).
:- initialization(refute( ~ (?a => ?b) => ?a /\ ~ ?b )).
:- initialization(prove( ~ (?a => ?b) <= ?a /\ ~ ?b )).
:- initialization(refute( ~ (~ ?a) => ?a )).
:- initialization(prove( ~ (~ ?a) <= ?a )).
:- initialization(prove( ~ tt <=> ff )).
:- initialization(prove( ~ ff <=> tt )).
:- initialization(prove( ~ (~ (~ ?a)) <=> ~ ?a )).
:- initialization(prove( (?a => ?b) => (?b => ?c) => (?c => ?d) => (?a => ?d) )).
:- initialization(prove( (?a => ?b) => (?a => ?c) => ?a => ?b )).
:- initialization(prove( (?a => ?b) => (?a => ?c) => ?a => ?c )).
:- initialization(prove( ?a => (?a => ?b) => (?a => ?c) => ?b )).
:- initialization(prove( ?a => (?a => ?b) => (?a => ?c) => ?c )).
:- initialization(prove( (?a => ?b => ?c) => ?a => ?b => ?c )).
:- initialization(prove( (?a => ?b => ?c) => ?b => ?a => ?c )).
:- initialization(prove( ?a => ?b => (?a => ?b => ?c) => ?c )).
:- initialization(prove( ?b => ?a => (?a => ?b => ?c) => ?c )).
:- initialization(prove( (?a => ?b) => ?a => ?b )).
:- initialization(prove( ((?a => ?b) => ?c) => ((?a => ?b) => ?c) )).
:- initialization(prove( (((?a => ?b) => ?c) => ?d) => (((?a => ?b) => ?c) => ?d) )).
:- initialization(prove( ((((?a => ?b) => ?c) => ?d) => ?e)
=> (((?a => ?b) => ?c) => ?d) => ?e )).
:- initialization(prove( (((((?a => ?b) => ?c) => ?d) => ?e) => ?f)
=> ((((?a => ?b) => ?c) => ?d) => ?e) => ?f )).
:- initialization(prove( (((((?a => ?b) => ?c) => ?d) => ?e) => ?f)
=> (((((?a => ?b) => ?c) => ?d) => ?e) => ?f)
\/ (((((?a => ?b) => ?c) => ?d) => ?e) => ?f) )).
:- initialization(prove( ((?a => ?b) => ?c) => ?d => ?d \/ ?d )).
:- initialization(prove(( ( ?p1 <=> ?p2) => ( ?p1 /\ ?p2 /\ ?p3 )) =>
( ( ?p2 <=> ?p3) => ( ?p1 /\ ?p2 /\ ?p3 )) =>
( ( ?p3 <=> ?p1) => ( ?p1 /\ ?p2 /\ ?p3 )) =>
( ?p1 /\ ?p2 /\ ?p3 ))).