%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% 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 ))).
