A Smarter Tautology Solver

From Coq Require Import String Arith List Lia Nat Bool Peano_dec.
[Loading ML file ring_plugin.cmxs (using legacy method) ... done]
[Loading ML file zify_plugin.cmxs (using legacy method) ... done]
[Loading ML file micromega_plugin.cmxs (using legacy method) ... done]
Import ListNotations.

Now we are ready to revisit the tautology solver we saw last time. We will also broaden the scope of the tactic to include formulas whose truth is not syntactically apparent. We will want to allow injection of arbitrary formulas, like we allowed arbitrary monoid expressions in the last example. Since we are working in a richer theory, it is important to be able to use equalities between different injected formulas. For instance, we cannot prove P -> P by translating the formula into a value like Imp (Var P) (Var P), because a Gallina function has no way of comparing the two Ps for equality.

We introduce a synonym for how we name variables: natural numbers.

Definition propvar := nat.

Inductive formula : Set :=
| Atomic : propvar -> formula
| Truth : formula
| Falsehood : formula
| And : formula -> formula -> formula
| Or : formula -> formula -> formula
| Imp : formula -> formula -> formula.

Now we can define our denotation function. First, a type of truth-value assignments to propositional variables:

Definition asgn := nat -> Prop.

Fixpoint formulaDenote (atomics : asgn) (f : formula) : Prop :=
  match f with
    | Atomic v => atomics v
    | Truth => True
    | Falsehood => False
    | And f1 f2 => formulaDenote atomics f1 /\ formulaDenote atomics f2
    | Or f1 f2 => formulaDenote atomics f1 \/ formulaDenote atomics f2
    | Imp f1 f2 => formulaDenote atomics f1 -> formulaDenote atomics f2
  end.

Require Import ListSet.

Section my_tauto.
  Variable atomics : asgn.

Now we are ready to define some helpful functions based on the ListSet module of the standard library, which (unsurprisingly) presents a view of lists as sets.

The eq_nat_dec below is a richly typed equality test on nats. See SubsetTypes.v for a review.

  Definition add (s : set propvar) (v : propvar) :=
    set_add eq_nat_dec v s.

We define what it means for all members of a variable set to represent true propositions, and we prove some lemmas about this notion.

  Fixpoint allTrue (s : set propvar) : Prop :=
    match s with
    | nil => True
    | v :: s' => atomics v /\ allTrue s'
    end.

  Theorem allTrue_add : forall v s,
    allTrue s
    -> atomics v
    -> allTrue (add s v).
atomics: asgn
forall (v : nat) (s : set propvar),
allTrue s -> atomics v -> allTrue (add s v)
  Proof.
atomics: asgn
forall (v : nat) (s : set propvar),
allTrue s -> atomics v -> allTrue (add s v)
    induction s; simpl; intuition;
      match goal with
        | [ |- context[if ?E then _ else _] ] => destruct E
      end; simpl; intuition.
  Qed.

  Theorem allTrue_In : forall v s,
    allTrue s
    -> set_In v s
    -> atomics v.
atomics: asgn
forall (v : propvar) (s : set propvar),
allTrue s -> set_In v s -> atomics v
  Proof.
atomics: asgn
forall (v : propvar) (s : set propvar),
allTrue s -> set_In v s -> atomics v
    induction s; simpl; intros; intuition congruence.
  Qed.

Now we can write a function forward that implements deconstruction of hypotheses, expanding a compound formula into a set of sets of atomic formulas covering all possible cases introduced with use of Or. To handle consideration of multiple cases, the function takes in a continuation argument (advanced functional-programming feature that often puzzles novices, so don't worry if it takes a while to digest!), which will be called once for each case.

  Fixpoint forward (known : set propvar) (hyp : formula)
           (cont : set propvar -> bool) : bool :=
    match hyp with
    | Atomic v => cont (add known v)
    | Truth => cont known
    | Falsehood => true
    | And h1 h2 => forward known h1 (fun known' =>
                     forward known' h2 cont)
    | Or h1 h2 => forward known h1 cont && forward known h2 cont
    | Imp _ _ => cont known
    end.

Some examples might help get the idea across.

  Compute fun cont =>
            forward [] (Atomic 0) cont.
= fun cont : set propvar -> bool => cont [0]
: (set propvar -> bool) -> bool
  Compute fun cont =>
            forward [] (Or (Atomic 0) (Atomic 1)) cont.
= fun cont : set propvar -> bool =>
  if cont [0] then cont [1] else false
: (set propvar -> bool) -> bool
  Compute fun cont =>
            forward [] (Or (Atomic 0) (And (Atomic 1) (Atomic 2))) cont.
= fun cont : set propvar -> bool =>
  if cont [0] then cont [1; 2] else false
: (set propvar -> bool) -> bool

A backward function implements analysis of the final goal. It calls forward to handle implications.

  Fixpoint backward (known : set propvar) (f : formula) : bool :=
    match f with
    | Atomic v => if In_dec eq_nat_dec v known then true else false
    | Truth => true
    | Falsehood => false
    | And f1 f2 => backward known f1 && backward known f2
    | Or f1 f2 => backward known f1 || backward known f2
    | Imp f1 f2 => forward known f1 (fun known' => backward known' f2)
    end.

Examples:

  Compute backward []
            (Atomic 0).
= false
: bool
  Compute backward [0]
            (Atomic 0).
= true
: bool
  Compute backward [0; 2]
            (Or (Atomic 0) (Atomic 1)).
= true
: bool
  Compute backward [2]
            (Or (Atomic 0) (Atomic 1)).
= false
: bool
  Compute backward [2]
            (Imp (Atomic 0) (Or (Atomic 0) (Atomic 1))).
= true
: bool
  Compute backward [2]
            (Imp (Or (Atomic 0) (Atomic 3)) (Or (Atomic 0) (Atomic 1))).
= false
: bool
  Compute backward [2]
            (Imp (Or (Atomic 1) (Atomic 0)) (Or (Atomic 0) (Atomic 1))).
= true
: bool
End my_tauto.

Hint Resolve allTrue_add : core.

Lemma forward_ok : forall atomics hyp f known cont,
    forward known hyp cont = true
    -> (forall known', allTrue atomics known'
                       -> cont known' = true
                       -> formulaDenote atomics f)
    -> allTrue atomics known
    -> formulaDenote atomics hyp
    -> formulaDenote atomics f.
forall (atomics : asgn) (hyp f : formula)
  (known : set propvar) (cont : set propvar -> bool),
forward known hyp cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true -> formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp -> formulaDenote atomics f
Proof.
forall (atomics : asgn) (hyp f : formula)
  (known : set propvar) (cont : set propvar -> bool),
forward known hyp cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true -> formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp -> formulaDenote atomics f
  induction hyp; simpl in *; intros.
atomics: asgn
p: propvar
f: formula
known: set propvar
cont: set propvar -> bool
H: cont (add known p) = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H2: atomics p
formulaDenote atomics f
atomics: asgn
f: formula
known: set propvar
cont: set propvar -> bool
H: cont known = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H2: True
formulaDenote atomics f
atomics: asgn
f: formula
known: set propvar
cont: set propvar -> bool
H: true = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H2: False
formulaDenote atomics f
atomics: asgn
hyp1, hyp2: formula
IHhyp1: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp1 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp1 ->
formulaDenote atomics f
IHhyp2: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp2 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp2 ->
formulaDenote atomics f
f: formula
known: set propvar
cont: set propvar -> bool
H: forward known hyp1
  (fun known' : set propvar =>
   forward known' hyp2 cont) = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H2: formulaDenote atomics hyp1 /\
formulaDenote atomics hyp2
formulaDenote atomics f
atomics: asgn
hyp1, hyp2: formula
IHhyp1: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp1 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp1 ->
formulaDenote atomics f
IHhyp2: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp2 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp2 ->
formulaDenote atomics f
f: formula
known: set propvar
cont: set propvar -> bool
H: forward known hyp1 cont && forward known hyp2 cont =
true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H2: formulaDenote atomics hyp1 \/
formulaDenote atomics hyp2
formulaDenote atomics f
atomics: asgn
hyp1, hyp2: formula
IHhyp1: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp1 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp1 ->
formulaDenote atomics f
IHhyp2: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp2 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp2 ->
formulaDenote atomics f
f: formula
known: set propvar
cont: set propvar -> bool
H: cont known = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H2: formulaDenote atomics hyp1 ->
formulaDenote atomics hyp2
formulaDenote atomics f

  all: repeat match goal with
              | [ H: _ && _ = true |- _ ] =>
                  apply Bool.andb_true_iff in H; destruct H
         end.
atomics: asgn
p: propvar
f: formula
known: set propvar
cont: set propvar -> bool
H: cont (add known p) = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H2: atomics p
formulaDenote atomics f
atomics: asgn
f: formula
known: set propvar
cont: set propvar -> bool
H: cont known = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H2: True
formulaDenote atomics f
atomics: asgn
f: formula
known: set propvar
cont: set propvar -> bool
H: true = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H2: False
formulaDenote atomics f
atomics: asgn
hyp1, hyp2: formula
IHhyp1: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp1 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp1 ->
formulaDenote atomics f
IHhyp2: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp2 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp2 ->
formulaDenote atomics f
f: formula
known: set propvar
cont: set propvar -> bool
H: forward known hyp1
  (fun known' : set propvar =>
   forward known' hyp2 cont) = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H2: formulaDenote atomics hyp1 /\
formulaDenote atomics hyp2
formulaDenote atomics f
atomics: asgn
hyp1, hyp2: formula
IHhyp1: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp1 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp1 ->
formulaDenote atomics f
IHhyp2: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp2 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp2 ->
formulaDenote atomics f
f: formula
known: set propvar
cont: set propvar -> bool
H: forward known hyp1 cont = true
H3: forward known hyp2 cont = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H2: formulaDenote atomics hyp1 \/
formulaDenote atomics hyp2
formulaDenote atomics f
atomics: asgn
hyp1, hyp2: formula
IHhyp1: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp1 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp1 ->
formulaDenote atomics f
IHhyp2: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp2 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp2 ->
formulaDenote atomics f
f: formula
known: set propvar
cont: set propvar -> bool
H: cont known = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H2: formulaDenote atomics hyp1 ->
formulaDenote atomics hyp2
formulaDenote atomics f

  all: intuition eauto 4.
atomics: asgn
hyp1, hyp2: formula
IHhyp1: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp1 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp1 ->
formulaDenote atomics f
IHhyp2: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp2 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp2 ->
formulaDenote atomics f
f: formula
known: set propvar
cont: set propvar -> bool
H: forward known hyp1
  (fun known' : set propvar =>
   forward known' hyp2 cont) = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H3: formulaDenote atomics hyp1
H4: formulaDenote atomics hyp2
formulaDenote atomics f

  {
atomics: asgn
hyp1, hyp2: formula
IHhyp1: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp1 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp1 ->
formulaDenote atomics f
IHhyp2: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp2 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp2 ->
formulaDenote atomics f
f: formula
known: set propvar
cont: set propvar -> bool
H: forward known hyp1
  (fun known' : set propvar =>
   forward known' hyp2 cont) = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H3: formulaDenote atomics hyp1
H4: formulaDenote atomics hyp2
formulaDenote atomics f eapply IHhyp1; eauto 3.
atomics: asgn
hyp1, hyp2: formula
IHhyp1: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp1 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp1 ->
formulaDenote atomics f
IHhyp2: forall (f : formula) (known : set propvar)
  (cont : set propvar -> bool),
forward known hyp2 cont = true ->
(forall known' : set propvar,
 allTrue atomics known' ->
 cont known' = true ->
 formulaDenote atomics f) ->
allTrue atomics known ->
formulaDenote atomics hyp2 ->
formulaDenote atomics f
f: formula
known: set propvar
cont: set propvar -> bool
H: forward known hyp1
  (fun known' : set propvar =>
   forward known' hyp2 cont) = true
H0: forall known' : set propvar,
allTrue atomics known' ->
cont known' = true -> formulaDenote atomics f
H1: allTrue atomics known
H3: formulaDenote atomics hyp1
H4: formulaDenote atomics hyp2
forall known' : set propvar,
allTrue atomics known' ->
(fun known'0 : set propvar =>
 forward known'0 hyp2 cont) known' = true ->
formulaDenote atomics f
    intros; eapply IHhyp2; eauto; eauto. }
Qed.

Lemma backward_ok' : forall atomics f known,
    backward known f = true
    -> allTrue atomics known
    -> formulaDenote atomics f.
forall (atomics : asgn) (f : formula)
  (known : set propvar),
backward known f = true ->
allTrue atomics known -> formulaDenote atomics f
Proof.
forall (atomics : asgn) (f : formula)
  (known : set propvar),
backward known f = true ->
allTrue atomics known -> formulaDenote atomics f
  induction f; simpl; intuition idtac.
atomics: asgn
p: propvar
known: set propvar
H: (if in_dec Nat.eq_dec p known then true else false) =
true
H0: allTrue atomics known
atomics p
atomics: asgn
known: set propvar
H: false = true
H0: allTrue atomics known
False
atomics: asgn
f1, f2: formula
IHf1: forall known : set propvar,
backward known f1 = true ->
allTrue atomics known ->
formulaDenote atomics f1
IHf2: forall known : set propvar,
backward known f2 = true ->
allTrue atomics known ->
formulaDenote atomics f2
known: set propvar
H: backward known f1 && backward known f2 = true
H0: allTrue atomics known
formulaDenote atomics f1
atomics: asgn
f1, f2: formula
IHf1: forall known : set propvar,
backward known f1 = true ->
allTrue atomics known ->
formulaDenote atomics f1
IHf2: forall known : set propvar,
backward known f2 = true ->
allTrue atomics known ->
formulaDenote atomics f2
known: set propvar
H: backward known f1 && backward known f2 = true
H0: allTrue atomics known
formulaDenote atomics f2
atomics: asgn
f1, f2: formula
IHf1: forall known : set propvar,
backward known f1 = true ->
allTrue atomics known ->
formulaDenote atomics f1
IHf2: forall known : set propvar,
backward known f2 = true ->
allTrue atomics known ->
formulaDenote atomics f2
known: set propvar
H: backward known f1 || backward known f2 = true
H0: allTrue atomics known
formulaDenote atomics f1 \/ formulaDenote atomics f2
atomics: asgn
f1, f2: formula
IHf1: forall known : set propvar,
backward known f1 = true ->
allTrue atomics known ->
formulaDenote atomics f1
IHf2: forall known : set propvar,
backward known f2 = true ->
allTrue atomics known ->
formulaDenote atomics f2
known: set propvar
H: forward known f1
  (fun known' : set propvar => backward known' f2) =
true
H0: allTrue atomics known
H1: formulaDenote atomics f1
formulaDenote atomics f2

  all: repeat match goal with
         | _ => progress destruct in_dec
         | [ H: false = true |- _ ] => discriminate
         | [ H: _ && _ = true |- _ ] =>
             apply Bool.andb_true_iff in H; destruct H
         | [ H: _ || _ = true |- _ ] =>
             apply Bool.orb_true_iff in H; destruct H
         end.
atomics: asgn
p: propvar
known: set propvar
i: In p known
H: true = true
H0: allTrue atomics known
atomics p
atomics: asgn
f1, f2: formula
IHf1: forall known : set propvar,
backward known f1 = true ->
allTrue atomics known ->
formulaDenote atomics f1
IHf2: forall known : set propvar,
backward known f2 = true ->
allTrue atomics known ->
formulaDenote atomics f2
known: set propvar
H: backward known f1 = true
H1: backward known f2 = true
H0: allTrue atomics known
formulaDenote atomics f1
atomics: asgn
f1, f2: formula
IHf1: forall known : set propvar,
backward known f1 = true ->
allTrue atomics known ->
formulaDenote atomics f1
IHf2: forall known : set propvar,
backward known f2 = true ->
allTrue atomics known ->
formulaDenote atomics f2
known: set propvar
H: backward known f1 = true
H1: backward known f2 = true
H0: allTrue atomics known
formulaDenote atomics f2
atomics: asgn
f1, f2: formula
IHf1: forall known : set propvar,
backward known f1 = true ->
allTrue atomics known ->
formulaDenote atomics f1
IHf2: forall known : set propvar,
backward known f2 = true ->
allTrue atomics known ->
formulaDenote atomics f2
known: set propvar
H: backward known f1 = true
H0: allTrue atomics known
formulaDenote atomics f1 \/ formulaDenote atomics f2
atomics: asgn
f1, f2: formula
IHf1: forall known : set propvar,
backward known f1 = true ->
allTrue atomics known ->
formulaDenote atomics f1
IHf2: forall known : set propvar,
backward known f2 = true ->
allTrue atomics known ->
formulaDenote atomics f2
known: set propvar
H: backward known f2 = true
H0: allTrue atomics known
formulaDenote atomics f1 \/ formulaDenote atomics f2
atomics: asgn
f1, f2: formula
IHf1: forall known : set propvar,
backward known f1 = true ->
allTrue atomics known ->
formulaDenote atomics f1
IHf2: forall known : set propvar,
backward known f2 = true ->
allTrue atomics known ->
formulaDenote atomics f2
known: set propvar
H: forward known f1
  (fun known' : set propvar => backward known' f2) =
true
H0: allTrue atomics known
H1: formulaDenote atomics f1
formulaDenote atomics f2

  all: intuition eauto.
atomics: asgn
p: propvar
known: set propvar
i: In p known
H: true = true
H0: allTrue atomics known
atomics p
atomics: asgn
f1, f2: formula
IHf1: forall known : set propvar,
backward known f1 = true ->
allTrue atomics known ->
formulaDenote atomics f1
IHf2: forall known : set propvar,
backward known f2 = true ->
allTrue atomics known ->
formulaDenote atomics f2
known: set propvar
H: forward known f1
  (fun known' : set propvar => backward known' f2) =
true
H0: allTrue atomics known
H1: formulaDenote atomics f1
formulaDenote atomics f2

  +
atomics: asgn
p: propvar
known: set propvar
i: In p known
H: true = true
H0: allTrue atomics known
atomics p eapply allTrue_In; unfold set_In; eauto.
  +
atomics: asgn
f1, f2: formula
IHf1: forall known : set propvar,
backward known f1 = true ->
allTrue atomics known ->
formulaDenote atomics f1
IHf2: forall known : set propvar,
backward known f2 = true ->
allTrue atomics known ->
formulaDenote atomics f2
known: set propvar
H: forward known f1
  (fun known' : set propvar => backward known' f2) =
true
H0: allTrue atomics known
H1: formulaDenote atomics f1
formulaDenote atomics f2 eapply forward_ok; eauto.
atomics: asgn
f1, f2: formula
IHf1: forall known : set propvar,
backward known f1 = true ->
allTrue atomics known ->
formulaDenote atomics f1
IHf2: forall known : set propvar,
backward known f2 = true ->
allTrue atomics known ->
formulaDenote atomics f2
known: set propvar
H: forward known f1
  (fun known' : set propvar => backward known' f2) =
true
H0: allTrue atomics known
H1: formulaDenote atomics f1
forall known' : set propvar,
allTrue atomics known' ->
(fun known'0 : set propvar => backward known'0 f2)
  known' = true -> formulaDenote atomics f2
    intros; eapply IHf2; eauto; eauto.
Qed.

Theorem backward_ok : forall f,
    backward [] f = true
    -> forall atomics, formulaDenote atomics f.
forall f : formula,
backward [] f = true ->
forall atomics : asgn, formulaDenote atomics f
Proof.
forall f : formula,
backward [] f = true ->
forall atomics : asgn, formulaDenote atomics f
  intros.
f: formula
H: backward [] f = true
atomics: asgn
formulaDenote atomics f
  apply backward_ok' with (known := []); simpl; eauto.
Qed.

Find the position of an element in a list.

Ltac position x ls :=
  match ls with
  | [] => constr:(@None nat)
  | x :: _ => constr:(Some 0)
  | _ :: ?ls' =>
    let p := position x ls' in
    match p with
    | None => p
    | Some ?n => constr:(Some (S n))
    end
  end.

Compute a duplicate-free list of all variables in P, combining it with acc.

Ltac vars_in P acc :=
  match P with
  | True => acc
  | False => acc
  | ?Q1 /\ ?Q2 =>
    let acc' := vars_in Q1 acc in
    vars_in Q2 acc'
  | ?Q1 \/ ?Q2 =>
    let acc' := vars_in Q1 acc in
    vars_in Q2 acc'
  | ?Q1 -> ?Q2 =>
    let acc' := vars_in Q1 acc in
    vars_in Q2 acc'
  | _ =>
    let pos := position P acc in
    match pos with
    | Some _ => acc
    | None => constr:(P :: acc)
    end
  end.

Reification of formula P, with a pregenerated list vars of variables it may mention

Ltac reify_tauto' P vars :=
  match P with
  | True => Truth
  | False => Falsehood
  | ?Q1 /\ ?Q2 =>
    let q1 := reify_tauto' Q1 vars in
    let q2 := reify_tauto' Q2 vars in
    constr:(And q1 q2)
  | ?Q1 \/ ?Q2 =>
    let q1 := reify_tauto' Q1 vars in
    let q2 := reify_tauto' Q2 vars in
    constr:(Or q1 q2)
  | ?Q1 -> ?Q2 =>
    let q1 := reify_tauto' Q1 vars in
    let q2 := reify_tauto' Q2 vars in
    constr:(Imp q1 q2)
  | _ =>
    let pos := position P vars in
    match pos with
    | Some ?pos' => constr:(Atomic pos')
    end
  end.

Our final tactic implementation is now fairly straightforward. First, we intro all quantifiers that do not bind Props. Then we reify. Finally, we call the verified procedure through a lemma.

Ltac my_tauto :=
  repeat match goal with
           | [ |- forall x : ?P, _ ] =>
             match type of P with
               | Prop => fail 1
               | _ => intro
             end
         end;
  match goal with
    | [ |- ?P ] =>
      let vars := vars_in P (@nil Prop) in
      let p := reify_tauto' P vars in
      change (formulaDenote (nth_default False vars) p)
  end;
  apply backward_ok; reflexivity.

A few examples demonstrate how the tactic works:

Theorem mt1 : True.
True
Proof.
True
  my_tauto.
Qed.

Print mt1.
mt1 =
backward_ok Truth eq_refl (nth_default False [])
     : True

Theorem mt2 : forall x y : nat, x = y -> x = y.
forall x y : nat, x = y -> x = y
Proof.
forall x y : nat, x = y -> x = y
  my_tauto.
Qed.

Print mt2.
mt2 =
fun x y : nat =>
backward_ok (Imp (Atomic 0) (Atomic 0)) eq_refl
  (nth_default False [x = y])
     : forall x y : nat, x = y -> x = y

Arguments mt2 (x y)%nat_scope _

Crucially, both instances of x = y are represented with the same variable 0.

Theorem mt3 : forall x y z,
  (x < y /\ y > z) \/ (y > z /\ x < S y)
  -> y > z /\ (x < y \/ x < S y).
forall x y z : nat,
x < y /\ y > z \/ y > z /\ x < S y ->
y > z /\ (x < y \/ x < S y)
Proof.
forall x y z : nat,
x < y /\ y > z \/ y > z /\ x < S y ->
y > z /\ (x < y \/ x < S y)
  my_tauto.
Qed.

Print mt3.
mt3 =
fun x y z : nat =>
backward_ok
  (Imp
     (Or (And (Atomic 2) (Atomic 1))
        (And (Atomic 1) (Atomic 0)))
     (And (Atomic 1) (Or (Atomic 2) (Atomic 0))))
  eq_refl (nth_default False [x < S y; y > z; x < y])
     : forall x y z : nat,
       x < y /\ y > z \/ y > z /\ x < S y ->
       y > z /\ (x < y \/ x < S y)

Arguments mt3 (x y z)%nat_scope _

Our goal contained three distinct atomic formulas, and we see that a three-element environment is generated.

It can be interesting to observe differences between the level of repetition in proof terms generated by my_tauto and tauto for especially trivial theorems.

Theorem mt4 :
  True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
True /\ True /\ True /\ True /\ True /\ True /\ False ->
False
Proof.
True /\ True /\ True /\ True /\ True /\ True /\ False ->
False
  my_tauto.
Qed.

Print mt4.
mt4 =
backward_ok
  (Imp
     (And Truth
        (And Truth
           (And Truth
              (And Truth
                 (And Truth (And Truth Falsehood))))))
     Falsehood) eq_refl (nth_default False [])
     : True /\
       True /\ True /\ True /\ True /\ True /\ False ->
       False

Theorem mt4' :
  True /\ True /\ True /\ True /\ True /\ True /\ False -> False.
True /\ True /\ True /\ True /\ True /\ True /\ False ->
False
Proof.
True /\ True /\ True /\ True /\ True /\ True /\ False ->
False
  tauto.
Qed.

Print mt4'.
mt4' =
fun
  H : True /\
      True /\ True /\ True /\ True /\ True /\ False =>
and_ind
  (fun (_ : True)
     (H1 : True /\
           True /\ True /\ True /\ True /\ False) =>
   and_ind
     (fun (_ : True)
        (H2 : True /\ True /\ True /\ True /\ False)
      =>
      and_ind
        (fun (_ : True)
           (H3 : True /\ True /\ True /\ False) =>
         and_ind
           (fun (_ : True)
              (H4 : True /\ True /\ False) =>
            and_ind
              (fun (_ : True) (H5 : True /\ False) =>
               and_ind
                 (fun (_ : True) (H6 : False) =>
                  False_ind False H6) H5) H4) H3) H2)
     H1) H
     : True /\
       True /\ True /\ True /\ True /\ True /\ False ->
       False

The traditional tauto tactic introduces a quadratic blow-up in the size of the proof term, whereas proofs produced by my_tauto always have linear size.