Require Import String.
Require Import Nat.
Require Import Lia.
Require Export Coq.Arith.Compare_dec.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Vectors.Vector.
Require Export RelationClasses.
Require Export Morphisms.
Require Import List.
Import ListNotations.
Open Scope string_scope.
From ST Require Import EVarsScratchwork Vector.
From ST Require Export Logic.V Logic.Term Logic.Predicate Logic.Formula Logic.Subcontext.
Import VectorNotations.
(** * Natural Deduction

We need to formalize the proof calculus to then prove the correctness of soft
type system.

References relevant:

- https://people.compute.dtu.dk/ahfrom/Formalized%20First-Order%20Logic.pdf
- https://hal.archives-ouvertes.fr/hal-03096253
*)

(** ** Rules of Natural Deduction

We can now encode natural deduction rules using a straightforward inductive
type. The only subtlety surrounds ensuring a variable [name] is [fresh].
And that's because I am too lazy to do this adequately. Modeling arguments
as vectors screw everything up. But it's obviously not wrong. Let's hope it
doesn't destroy correctness ;p
*)

(** Note: I think we need to modify our rules of inference so that modus ponens
has the side condition that in [Implies p q] either [p] is a sentence (i.e.,
a ground term) or [q] is not a sentence. Johnstone's notes on logic alerted me
to this, and the more I think about it, the more I believe he is correct. *)

(** Also important to note (to future me), since we are using de Bruijn indices
which bind from the innermost quantifiers outwards, we do not need
to [unshift] in our quantifier elimination rules. (Because we
humans conventionally work from the outer-most quantifiers, inwards.)
So there is no need to worry about unshifting. *)

Import ListNotations.
Reserved Notation "Γ ⊢ P" (no associativity, at level 61).
Inductive deducible : list Formula -> Formula -> Prop :=
| ND_exfalso_quodlibet {Γ p} :
  Γ ⊢ Falsum ->
  Γ ⊢ p
| ND_imp_e {Γ p q} :
  Γ ⊢ Implies p q ->
  Γ ⊢ p ->
  Γ ⊢ q
| ND_imp_i2 {Γ p q} :
  p::Γ ⊢ q ->
  Γ ⊢ Implies p q
| ND_or_intro_l {Γ p q} :
  Γ ⊢ p ->
  Γ ⊢ Or p q
| ND_or_intro_r {Γ p q} :
  Γ ⊢ q ->
  Γ ⊢ Or p q
| ND_proof_by_cases {Γ p q r} :
  Γ ⊢ Or p q ->
  p :: Γ ⊢ r ->
  q :: Γ ⊢ r ->
  Γ ⊢ r
| ND_and_intro {Γ P Q} :
  Γ ⊢ P ->
  Γ ⊢ Q ->
  Γ ⊢ And P Q
| ND_and_elim {Γ P Q R} :
  Γ ⊢ And P Q ->
  P :: Q :: Γ ⊢ R ->
  Γ ⊢ R
| ND_cut {Γ P Q} :
  Γ ⊢ P ->
  P :: Γ ⊢ Q ->
  Γ ⊢ Q
| ND_exists_intro {Γ p t} :
  Γ ⊢ (capture_free_subst 0 t p) ->
  Γ ⊢ Exists p
| ND_exists_elim_small {Γ p q c} :
  (capture_free_subst 0 c p)::Γ ⊢ q ->
  c = fresh_evar Γ q ->
  (Exists p)::Γ ⊢ q
| ND_proof_by_contradiction {Γ p} :
  (Not p) :: Γ ⊢ Falsum ->
  Γ ⊢ p
| ND_prioritize {Γ p q} :
  Γ ⊢ q ->
  In p Γ ->
  p :: Γ ⊢ q
| ND_unprioritize {Γ p q} :
  p :: Γ ⊢ q ->
  In p Γ ->
  Γ ⊢ q
where "Γ ⊢ P" := (deducible Γ P).

Definition proves (fm : Formula) : Prop := deducible List.nil fm.

#[local] Hint Unfold GlobalContext LocalContext : typeclass_instances.
#[local] Hint Constructors well_typed deducible : core.

(* These next two lemmas are "obvious", but obnoxious to prove.
So I'm...lazy. *)
Lemma exists_elim_freshness {Γ q} :
  (EConst 0) = fresh_evar (shift_evars Γ) (shift_evars q).
Admitted.

Lemma exists_evar_shift {Γ p q} :
  Exists p :: Γ ⊢ q <-> (shift_evars (Exists p))::(shift_evars Γ) ⊢ (shift_evars q).
Admitted.

Theorem exists_elim {Γ p q} :
  (capture_free_subst 0 (EConst 0) (shift_evars p))::(shift_evars Γ) ⊢ (shift_evars q) ->
  (Exists p)::Γ ⊢ q.
Proof.
  intros.
  apply exists_evar_shift.
  apply (ND_exists_elim_small (c := (EConst 0))). assumption.
  apply exists_elim_freshness.
Qed.

Theorem ND_exists_elim {Γ p q c} :
  Γ ⊢ Exists p ->
  c = fresh_evar Γ q ->
  capture_free_subst 0 c p :: Γ ⊢ q -> Γ ⊢ q.
Proof.
  intros.
  apply ND_exists_elim_small in H1.
  apply ND_imp_i2 in H1.
  apply (@ND_imp_e Γ (Exists p) q ) in H1.
  assumption. assumption.
  assumption.
Qed.

(**
I am being a bit cavalier here, but the only way to [prove Falsum]
is to assume contradictory premises. I can't seem to get Coq to believe
me about this, so I carved out [ND_assume] as an explicit axiom.
Otherwise the [consistency] theorem below fails.

After further thought, I believe we may need to require [p] be a sentence;
see the remarks about modus ponens above.
*)
Axiom ND_assume_axiom : forall (Γ : list Formula) (p : Formula),
  List.In p Γ ->  Γ ⊢ p.

Theorem ND_assume {Γ p} : List.In p Γ ->  Γ ⊢ p.
Proof.
  apply (ND_assume_axiom Γ p).
Qed.

Ltac Assume eqn :=
  assert (eqn) by (apply ND_assume; prove_In).

Theorem ND_not_i {Γ p} :
  p::Γ ⊢ Falsum ->
  Γ ⊢ Not p.
Proof.
  intros. unfold Not. apply ND_imp_i2. assumption.
Qed.

Theorem ND_not_e {Γ p q} :
  In p Γ -> In (Not p) Γ -> Γ ⊢ q.
Proof. intros.
  apply ND_assume in H as H1.
  apply ND_assume in H0 as H2.
  unfold Not in H2.
  apply (@ND_imp_e Γ p Falsum) in H2. 2: assumption.
  apply (@ND_exfalso_quodlibet Γ q) in H2. assumption.
Qed.

(** ** Subcontext-related manipulations *)

(* This is an axiom, which can't really be proven. *)
Lemma renaming_econst : forall (Γ1 Γ2 : list Formula) (p q : Formula),
  Γ1 ⊆ Γ2 ->
  capture_free_subst 0 (fresh_evar Γ1 q) p :: Γ1 ⊢ q ->
  capture_free_subst 0 (fresh_evar Γ2 q) p :: Γ2 ⊢ q.
Admitted.

Import ListNotations.
Open Scope list.

Lemma fresh_evar_alias : forall (Γ : list Formula) (p : Formula) (c : Term),
  c = (fresh_evar Γ p) <-> c = (fresh_evar (p::Γ)%list Falsum).
Proof.
  intros. unfold fresh_evar. unfold fresh_evar_counter.
  assert (list_evars (Falsum :: p :: Γ) = list_evars (p :: Γ)). {
    simpl; auto.
  }
  rewrite H. reflexivity.
Qed.

Lemma subcontext_in_trans {Γ1 Γ2 p} :
  In p Γ1 -> Γ1 ⊆ Γ2 -> In p Γ2.
Proof.
  intros. simpl; auto.
Qed.

Global Instance ND_context_extension :
  Proper (subcontext ++> eq ==> Basics.impl) deducible.
Proof.
intros Γ₁ Γ₂ ? P Q [] ?. revert Γ₂ H. induction H0; intros.
+ apply ND_exfalso_quodlibet. auto.
+ apply (ND_imp_e (p := p)); auto.
+ apply ND_imp_i2. apply IHdeducible. f_equiv. auto.
+ apply ND_or_intro_l. auto.
+ apply ND_or_intro_r. auto.
+  apply (ND_proof_by_cases (p := p) (q := q)); auto.
  - apply IHdeducible2. f_equiv. assumption.
  - apply IHdeducible3. f_equiv. assumption.
+ apply ND_and_intro; auto.
+ apply (ND_and_elim (P := P) (Q := Q0)); auto.
  apply IHdeducible2. do 2 f_equiv; assumption.
+ apply (ND_cut (P := P)); auto.
  apply IHdeducible2. f_equiv. assumption.
+ apply (ND_exists_intro (p := p) (t := t)); auto.
+ apply subcontext_cons in H1 as H2. destruct H2.
  apply renaming_econst with (p := p) (q := q) in H3 as H4. 2: { rewrite <- H; assumption. }
  apply (ND_unprioritize (p := Exists p) (Γ := Γ₂)).
  apply (ND_exists_elim_small (Γ := Γ₂) (c := (fresh_evar Γ₂ q))). assumption.
  reflexivity. assumption.
+ apply ND_proof_by_contradiction. apply IHdeducible. f_equiv. auto.
+ apply (@subcontext_cons Γ Γ₂ p) in H1 as H2. apply IHdeducible. destruct H2.
  assumption.
+ apply IHdeducible. apply (@subcontext_cons Γ Γ₂ p). split.
  apply (@subcontext_in_trans Γ Γ₂).
assumption. assumption. assumption.
Qed.

Theorem weakening : forall (Γ1 Γ2 : list Formula) (P : Formula),
  Γ1 ⊢ P ->
  Γ1 ⊆ Γ2 ->
  Γ2 ⊢ P.
Proof.
  intros.
  refine (ND_context_extension _ _ _ _ _ eq_refl H).
  assumption.
Qed.

(** ** Important Tautologies

We will now prove a number of important tautologies. And being a classy mathematician,
we will be proving results in classical logic.
*)

Theorem ND_and_idempotent : forall (P : Formula),
  [] ⊢ (And P P) <-> [] ⊢ P.
Proof. split. (* intros; split. *)
- intros. apply (@ND_and_elim [] P P P). assumption.
  apply ND_assume. unfold In. left. reflexivity.
- intros. apply (@ND_and_intro [] P P). assumption. assumption.
Qed.

Theorem ND_or_idempotent : forall (P : Formula),
  [] ⊢ (Or P P) <-> [] ⊢ P.
Proof. split.
- intros. apply (@ND_proof_by_cases [] P P P). assumption.
  Assume (P :: [] ⊢ P); assumption.
  Assume (P :: [] ⊢ P); assumption.
- intros. apply (@ND_or_intro_r [] P P). assumption.
Qed.

Theorem ND_implies_refl : forall (P : Formula),
  proves (Implies P P).
Proof. intros.
  set (Γ := [P]).
  assert (In P Γ). { unfold In. left. reflexivity. }
  apply ND_assume in H.
  apply ND_imp_i2 in H. assumption.
Qed.

Theorem ND_double_negation {Γ p} :
  Γ ⊢ Implies (Not (Not p)) p.
Proof.
  apply @ND_imp_i2; apply @ND_proof_by_contradiction; set (q := Not p).
  assert (In q (q :: Not q :: Γ)). prove_In.
  assert (In (Not q) (q :: Not q :: Γ)). prove_In.
  apply @ND_not_e with (Γ := (q :: Not q :: Γ)) (p := q) (q := Falsum).
  assumption. assumption.
Qed.

Theorem ND_implies_falsum_is_negation : forall (Γ : list Formula) (p : Formula),
  Γ ⊢ Implies p Falsum <-> Γ ⊢ Not p.
Proof.
  split.
- intros. apply (@ND_not_i Γ p).
  assert(Γ ⊆ (p :: Γ)). { apply subcontext_weaken. apply subcontext_reflex. }
  apply (weakening Γ (p :: Γ)) in H as H1.
  apply (@ND_imp_e (p :: Γ) p Falsum) in H1 as H2. assumption. apply ND_assume.
  unfold In; left; reflexivity. apply subcontext_weaken. apply subcontext_reflex.
- intros. apply (@ND_imp_i2 Γ p Falsum).
  assert(p :: Γ ⊆ (Not p :: p :: Γ)). { apply subcontext_weaken. apply subcontext_reflex. }
  assert(Γ ⊆ (p :: Γ)). { apply subcontext_weaken. apply subcontext_reflex. }
  apply (weakening Γ (p :: Γ)) in H as H2.
  assert (In p ((Not p) :: p :: Γ)). prove_In.
  assert (In (Not p) ((Not p) :: p :: Γ)). prove_In.
  assert ((Not p) :: p :: Γ ⊢ Falsum). {
  apply (@ND_not_e (Not p :: p :: Γ) p Falsum) in H3 as H5. assumption. assumption.
  }
  apply (@ND_cut (p :: Γ) (Not p) Falsum) in H2 as H6. assumption. assumption. assumption.
Qed.

Theorem ND_True_intro {Γ} :
  Γ ⊢ Verum.
Proof.
  unfold Verum. apply ND_implies_falsum_is_negation.
  apply ND_proof_by_contradiction.
  Assume (Not (Not Falsum) :: Γ ⊢ Not (Not Falsum)).
  assert (Not (Not Falsum) :: Γ ⊢ Implies (Not (Not Falsum)) Falsum).
  apply ND_double_negation.
  apply (@ND_imp_e (Not (Not Falsum) :: Γ) (Not (Not Falsum)) Falsum) in H0.
  assumption. assumption.
Qed.

Theorem ND_excluded_middle {Γ p} :
  Γ ⊢ Or p (Not p).
Proof.
apply @ND_proof_by_contradiction.
apply @ND_imp_e with (p := Or p (Not p)).
+ apply ND_implies_falsum_is_negation.
apply @ND_assume. prove_In.
+ apply @ND_or_intro_r. apply ND_implies_falsum_is_negation. apply @ND_imp_i2.
  apply @ND_imp_e with (p := Or p (Not p)).
  - apply ND_implies_falsum_is_negation. apply @ND_assume. prove_In.
  - apply @ND_or_intro_l.
    apply @ND_assume; prove_In.
Qed.

Theorem ND_and_simplify_l {Γ p q} :
  Γ ⊢ Implies (And p q) p.
Proof.
  intros. apply ND_imp_i2.
  assert (In (And p q) ((And p q) :: Γ)). prove_In.
  apply (@ND_assume ((And p q) :: Γ) (And p q)) in H as H1.
  apply (@ND_and_elim ((And p q)::Γ) p q p) in H1 as H2.
  assumption.
  assert (In p (p :: q :: (And p q) :: Γ)). prove_In.
  apply (@ND_assume (p :: q :: (And p q) :: Γ) p) in H0.
  assumption.
Qed.

Theorem ND_and_simplify_r {Γ p q} :
  Γ ⊢ Implies (And p q) q.
Proof.
  intros. apply ND_imp_i2.
  assert (In (And p q) ((And p q) :: Γ)). prove_In.
  apply (@ND_assume ((And p q) :: Γ) (And p q)) in H as H1.
  apply (@ND_and_elim ((And p q)::Γ) p q q) in H1 as H2.
  assumption.
  assert (In q (p :: q :: (And p q) :: Γ)). prove_In.
  apply (@ND_assume (p :: q :: (And p q) :: Γ) q) in H0.
  assumption.
Qed.

Theorem ND_conj_implies {Γ p q r} :
  Γ ⊢ Implies p q -> Γ ⊢ Implies p r -> Γ ⊢ Implies p (And q r).
Proof.
  intros. apply ND_imp_i2.
  assert(Γ ⊆ p::Γ). { apply subcontext_weaken. apply subcontext_reflex. }
  apply (weakening Γ (p :: Γ) (Implies p q)) in H1 as H3. 2: assumption.
  apply (weakening Γ (p :: Γ) (Implies p r)) in H1 as H4. 2: assumption.
  assert (In p (p::Γ)). prove_In. apply ND_assume in H2.
  apply (@ND_imp_e (p :: Γ) p q) in H3. 2: assumption.
  apply (@ND_imp_e (p :: Γ) p r) in H4. 2: assumption.
  apply (@ND_and_intro (p :: Γ) q r). assumption. assumption.
Qed.

Theorem ND_and_commutative {Γ p q} :
  Γ ⊢ Implies (And p q) (And q p).
Proof.
  intros.
  assert (Γ ⊢ Implies (And p q) p). apply ND_and_simplify_l.
  assert (Γ ⊢ Implies (And p q) q). apply ND_and_simplify_r.
  apply (@ND_conj_implies Γ (And p q) q p). assumption. assumption.
Qed.

Theorem ND_or_commutative {Γ p q} :
  Γ ⊢ Implies (Or p q) (Or q p).
Proof.
  apply ND_imp_i2;
  apply (@ND_proof_by_cases (Or p q :: Γ) p q (Or q p)).
  apply ND_assume; prove_In.
  apply ND_or_intro_r; apply ND_assume; prove_In.
  apply ND_or_intro_l; apply ND_assume; prove_In.
Qed.

Theorem ND_proj_l {Γ p q} :
  Γ ⊢ And p q -> Γ ⊢ p.
Proof.
  intros.
  Assume (p :: q :: Γ ⊢ p).
  apply (@ND_and_elim Γ p q p) in H. assumption.
  assumption.
Qed.

Theorem ND_proj_r {Γ p q} :
  Γ ⊢ And p q -> Γ ⊢ q.
Proof.
  intros.
  Assume (p :: q :: Γ ⊢ q).
  apply (@ND_and_elim Γ p q q) in H. assumption.
  assumption.
Qed.

Theorem ND_Iff_intro {Γ p q} :
  p::Γ ⊢ q -> q::Γ ⊢ p -> Γ ⊢ Iff p q.
Proof.
  intros.
  apply ND_imp_i2 in H; apply ND_imp_i2 in H0.
  apply ND_and_intro. assumption. assumption.
Qed.

Theorem ND_Iff_elim_l {Γ p q} :
  Γ ⊢ p -> Γ ⊢ Iff p q -> Γ ⊢ q.
Proof.
  intros.
  apply ND_proj_l in H0 as H1.
  apply (ND_imp_e (p := p) (q := q)) in H1.
  assumption. assumption.
Qed.

Theorem ND_Iff_elim_r {Γ p q} :
  Γ ⊢ q -> Γ ⊢ Iff p q -> Γ ⊢ p.
Proof.
  intros;
  apply ND_proj_r in H0 as H1;
  apply (ND_imp_e (p := q) (q := p)) in H1.
  assumption. assumption.
Qed.

Theorem ND_uncurry {Γ p q r} :
  Γ ⊢ Implies p (Implies q r) -> Γ ⊢ Implies (And p q) r.
Proof.
  intros.
  apply ND_imp_i2.
  assert (And p q :: Γ ⊢ p). {
    Assume (And p q :: Γ ⊢ And p q).
    apply ND_proj_l in H0. assumption.
  }
  assert (Γ ⊆ (And p q :: Γ)). {
    apply subcontext_weaken. apply subcontext_reflex.
  }
  apply (weakening Γ (And p q :: Γ)) in H. 2: assumption.
  apply (@ND_imp_e (And p q :: Γ) p (Implies q r)) in H. 2: assumption.
  assert (And p q :: Γ ⊢ q). {
    Assume (And p q :: Γ ⊢ And p q).
    apply ND_proj_r in H2. assumption.
  }
  apply (@ND_imp_e (And p q :: Γ) q r) in H. assumption. assumption.
Qed.

Theorem ND_curry_tautology {Γ p q r} :
  Γ ⊢ Implies (Implies (And p q) r) (Implies p (Implies q r)).
Proof.
  intros.
  Assume (q::p::(Implies (And p q) r)::Γ ⊢ (Implies (And p q) r)).
  Assume (q::p::(Implies (And p q) r)::Γ ⊢ p).
  Assume (q::p::(Implies (And p q) r)::Γ ⊢ q).
  apply (@ND_and_intro (q::p :: Implies (And p q) r :: Γ) p q) in H1 as H3.
  apply (@ND_imp_e (q::p :: Implies (And p q) r :: Γ) (And p q) r) in H as H4.
  apply (@ND_imp_i2 (p :: Implies (And p q) r :: Γ)) in H4.
  apply (@ND_imp_i2 (Implies (And p q) r :: Γ)) in H4.
  apply ND_imp_i2 in H4.
  assumption.
  assumption. assumption.
Qed.

Theorem ND_curry {Γ p q r} :
  Γ ⊢ Implies (And p q) r -> Γ ⊢ Implies p (Implies q r).
Proof.
  intros.
  assert (Γ ⊢ Implies (Implies (And p q) r) (Implies p (Implies q r))). {
  apply (@ND_curry_tautology Γ p q r).
  }
  apply (ND_imp_e (p := (Implies (And p q) r))) in H0.
  assumption. assumption.
Qed.

Theorem ND_uncurry_tautology {Γ p q r} :
  Γ ⊢ Implies (Implies p (Implies q r)) (Implies (And p q) r).
Proof.
  intros.
  apply ND_imp_i2.
  apply ND_uncurry.
  apply ND_assume; prove_In.
Qed.

Theorem ND_and_context {Γ p q r} :
  (And p q)::Γ ⊢ r <-> p::q::Γ ⊢ r.
Proof.
  split.
- intros. apply ND_imp_i2 in H; apply ND_curry in H.
  Assume (p :: q :: Γ ⊢ p).
  assert (Γ ⊆ p :: q :: Γ). { apply subcontext_weaken; apply subcontext_weaken; prove_subcontext. }
  apply (@weakening Γ (p :: q :: Γ)) in H. 2: assumption.
  apply (@ND_imp_e (p :: q :: Γ) p (Implies q r)) in H. 2: apply ND_assume; prove_In.
  apply (@ND_imp_e (p :: q :: Γ) q r) in H. 2: apply ND_assume; prove_In.
  assumption.
- intros. apply ND_imp_i2 in H; apply ND_imp_i2 in H. apply ND_uncurry in H.
  assert (Γ ⊆ (And p q) :: Γ). { apply subcontext_weaken; prove_subcontext. }
  apply (@weakening Γ ((And p q) :: Γ)) in H. 2: assumption.
  Assume (And p q :: Γ ⊢ And p q).
  assert (And p q :: Γ ⊢ Implies (And p q) (And q p)). { apply ND_and_commutative. }
  apply (@ND_imp_e (And p q :: Γ) (And p q)) in H2. 2: assumption.
  apply (@ND_imp_e (And p q :: Γ) (And q p)) in H. 2: assumption.
  assumption.
Qed.

Theorem ND_double_negation2 {Γ p} :
  Γ ⊢ Implies p (Not (Not p)).
Proof.
  apply ND_imp_i2; apply ND_implies_falsum_is_negation; apply ND_imp_i2;
  apply (@ND_imp_e (Not p :: p :: Γ) p Falsum).
  apply ND_implies_falsum_is_negation; apply ND_assume. prove_In.
  apply ND_assume. prove_In.
Qed.

Theorem ND_destruct_dn {Γ p} :
  Γ ⊢ p -> Γ ⊢ (Not (Not p)).
Proof. intros.
  assert (Γ ⊢ Implies p (Not (Not p))). apply ND_double_negation2.
  apply (@ND_imp_e Γ p (Not (Not p))) in H0. assumption. assumption.
Qed.

Theorem ND_make_dn {Γ p} :
  Γ ⊢ (Not (Not p)) -> Γ ⊢ p.
Proof.
  intros.
  assert (Γ ⊢ Implies (Not (Not p)) p). apply ND_double_negation.
  apply (@ND_imp_e Γ (Not (Not p)) p) in H0. assumption. assumption.
Qed.

Lemma falsum_is_negated_verum {Γ} :
  Γ ⊢ Implies (Not Verum) Falsum.
Proof.
  intros. apply ND_implies_falsum_is_negation. apply ND_destruct_dn.
  apply ND_True_intro.
Qed.

Lemma negated_verum_is_falsum {Γ} :
  Γ ⊢ Implies Falsum (Not Verum).
Proof.
  intros. apply ND_imp_i2.
  Assume (Falsum :: Γ ⊢ Falsum).
  apply (@ND_exfalso_quodlibet (Falsum :: Γ) (Not Verum)) in H.
  assumption.
Qed.

Lemma subst_falsum_to_not_verum {Γ} :
  Γ ⊢ Falsum -> Γ ⊢ (Not Verum).
Proof.
  intros. apply (@ND_exfalso_quodlibet Γ (Not Verum)) in H.
  assumption.
Qed.

Lemma subst_negate {Γ p t} :
  Γ ⊢ Not (capture_free_subst 0 t p) <->
  Γ ⊢ capture_free_subst 0 t (Not p).
Proof.
  split.
- intros; simpl; auto.
- intros; simpl; auto.
Qed.

(** We can always eliminate the [Forall] quantifier, to just use
[Exists], thanks to de Morgan's laws. This section gives us the
experimental introduction and elimination rules of inference. *)
Section ForallAbbreviation.
(** We can always eliminate the [Forall] quantifier, to just use
[Exists], thanks to de Morgan's laws. This theorem gives us the
"introduction rule" for this "abbreviated [Forall]" quantifier. *)
Theorem ND_forall_i {Γ p t} :
  Γ ⊢ capture_free_subst 0 t p ->
  t = fresh_evar Γ Falsum ->
  Γ ⊢ Forall p.
Proof.
  intros.
  assert (Γ ⊢ Implies (capture_free_subst 0 t p)
               (Not (Not (capture_free_subst 0 t p)))). apply ND_double_negation2.
  rename H0 into Ha.
  rename H1 into H0.
  apply (@ND_imp_e Γ (capture_free_subst 0 t p)) in H0. 2: assumption.
  assert (Γ ⊢ Not (Not (capture_free_subst 0 t p)) -> Γ ⊢ Not (capture_free_subst 0 t (Not p))). {
    intros. simpl; auto.
  }
  apply H1 in H0.
(* Thus we have established [H0 : Γ ⊢ Not (capture_free_subst 0 t (Not p))] *)
  unfold Not. unfold Not in H0.
  apply ND_imp_i2.
  apply (@ND_exists_elim_small Γ (Not p) Falsum t).
  Assume (capture_free_subst 0 t (Not p) :: Γ ⊢ (capture_free_subst 0 t (Not p))).
  assert (Γ ⊆ (capture_free_subst 0 t (Not p) :: Γ)). apply subcontext_weaken; apply subcontext_reflex.
  apply (@weakening Γ (capture_free_subst 0 t (Not p) :: Γ)) in H0.
  apply (@ND_imp_e (capture_free_subst 0 t (Not p) :: Γ) (capture_free_subst 0 t (Not p))) in H0.
  assumption. assumption. assumption. assumption.
Qed.

Theorem ND_neg_i {Γ p q} :
  p :: Γ ⊢ q -> p :: Γ ⊢ (Not q) -> Γ ⊢ Not p.
Proof.
  intros.
  unfold Not in H0.
  apply (@ND_imp_e (p :: Γ) q Falsum) in H0. 2: assumption.
  apply (@ND_imp_i2 Γ p Falsum) in H0.
  simpl; auto.
Qed.

Lemma subst_negate2 {Γ p t} :
  Γ ⊢ Not (Not (capture_free_subst 0 t p)) <->
  Γ ⊢ capture_free_subst 0 t (Not (Not p)).
Proof.
  split.
- intros; simpl; auto.
- intros; simpl; auto.
Qed.

(** This proof imitates the [(Not (Exists p)) ⊢ Forall (Not p)]
proof, to a large extent. It consists of two steps:

Step 1: weaken the premises to establish the contradictory results that
        [(Not p)[t], Γ ⊢ Not (Exists (Not p))] and
        [(Not p)[t], Γ ⊢ Exists (Not p)] both hold.

Step 2: Infer that [Γ ⊢ Not (Not p[t])] holds. And then the law of
        double negation gives the result. *)
Theorem ND_forall_elim {Γ p t} :
  Γ ⊢ Forall p ->
  Γ ⊢ capture_free_subst 0 t p.
Proof. intros.
  assert (Γ ⊆ (capture_free_subst 0 t (Not p) :: Γ)). apply subcontext_weaken; apply subcontext_reflex.
  apply (@weakening Γ (capture_free_subst 0 t (Not p) :: Γ)) in H. 2: assumption.
  Assume ((capture_free_subst 0 t (Not p) :: Γ) ⊢ (capture_free_subst 0 t (Not p))).
  apply ND_exists_intro in H1.
  apply (@ND_imp_e (capture_free_subst 0 t (Not p) :: Γ) (Exists (Not p)) Falsum) in H as H2. 2: assumption.
  apply (@ND_neg_i Γ (capture_free_subst 0 t (Not p)) (Exists (Not p))) in H1 as H3.
  2: assumption.
  (* Thus we have proved, in [H3], that
     [Γ ⊢ Not (capture_free_subst 0 t (Not p))].
     We will just move the inner [Not] outside the substitution, then
     use double negation law to prove this gives us the goal.*)
  rewrite -> subst_negate in H3.
  apply subst_negate2 in H3.
  assert (Γ ⊢ Implies (Not (Not (capture_free_subst 0 t p))) (capture_free_subst 0 t p)).
  apply ND_double_negation.
  apply @ND_imp_e with (p := (Not (Not (capture_free_subst 0 t p)))) in H4.
  assumption. assumption.
Qed.
End ForallAbbreviation.

Theorem contrapositive {Γ p q} :
  Γ ⊢ (Implies (Implies p q) (Implies (Not q) (Not p))).
Proof.
  intros.
  Assume(p::(Not q)::(Implies p q)::Γ ⊢ p).
  Assume(p::(Not q)::(Implies p q)::Γ ⊢ (Implies p q)).
  apply (@ND_imp_e (p:: Not q :: Implies p q :: Γ) p q) in H0 as H1.
  2: assumption.
  Assume(p::(Not q)::(Implies p q)::Γ ⊢ Not q).
  apply (@ND_neg_i (Not q :: Implies p q :: Γ)) in H1.
  apply (@ND_imp_i2 (Implies p q :: Γ) (Not q) (Not p)) in H1. 2: assumption.
  apply ND_imp_i2 in H1.
  assumption.
Qed.

Theorem modus_tollen {Γ p q} :
  Γ ⊢ (Implies p q) -> Γ ⊢ (Not q) -> Γ ⊢ (Not p).
Proof.
  intros.
  assert (Γ ⊢ (Implies (Implies p q) (Implies (Not q) (Not p)))). {
  apply (@contrapositive Γ p q).
  }
  apply (@ND_imp_e Γ (Implies p q)) in H1. 2: assumption.
  apply (@ND_imp_e Γ (Not q) (Not p)) in H1.
  assumption. assumption.
Qed.

(** We can now summarize the results which will be crucial in
proving the correctness of the translation. *)
Section ImportantTheorems.
Theorem forall_implies_reflex {Γ p} :
  Γ ⊢ Forall (Implies p p).
Proof.
  set (t := fresh_evar Γ Falsum).
  apply (@ND_forall_i Γ (Implies p p) t). 2: auto.
  simpl; auto.
  apply ND_imp_i2; apply ND_assume; prove_In.
Qed.

Theorem forall_modus_ponens_tautology {Γ p q} :
  Γ ⊢ Implies (Forall (Implies p q))
         (Implies (Exists p) (Exists q)).
Proof.
  intros.
  set (c := fresh_evar (Forall (Implies p q) :: Γ) (Exists q)).
  Assume((capture_free_subst 0 c p) ::  Forall (Implies p q) :: Γ ⊢ Forall (Implies p q)).
  apply (@ND_forall_elim (capture_free_subst 0 c p
     :: Forall (Implies p q) :: Γ) (Implies p q) c) in H as H2.

  assert (capture_free_subst 0 c p
     :: Forall (Implies p q) :: Γ ⊢ capture_free_subst 0 c (Implies p q)
  = capture_free_subst 0 c p
     :: Forall (Implies p q) :: Γ ⊢ Implies (capture_free_subst 0 c p) (capture_free_subst 0 c q)). { simpl; auto. }
  rewrite H0 in H2. clear H0.
  apply (ND_imp_e (p := capture_free_subst 0 c p) (q := capture_free_subst 0 c q)) in H2.
  2: apply ND_assume; prove_In.
  apply (@ND_exists_intro (capture_free_subst 0 c p
     :: Forall (Implies p q) :: Γ) q c) in H2.
  apply (@ND_exists_elim_small (Forall (Implies p q) :: Γ) p (Exists q) c) in H2 as H3.
  apply ND_imp_i2 in H3.
  apply ND_imp_i2 in H3.
  assumption. auto.
Qed.

Theorem forall_modus_const_tautology {Γ p q c} :
  Γ ⊢ Implies (Forall (Implies p q))
         (Implies (capture_free_subst 0 c p) (capture_free_subst 0 c q)).
Proof.
  intros.
  Assume((capture_free_subst 0 c p) ::  Forall (Implies p q) :: Γ ⊢ Forall (Implies p q)).
  apply (@ND_forall_elim (capture_free_subst 0 c p
    :: Forall (Implies p q) :: Γ) (Implies p q) c) in H as H1.
  assert (capture_free_subst 0 c p
     :: Forall (Implies p q) :: Γ ⊢ capture_free_subst 0 c (Implies p q)
  = capture_free_subst 0 c p
     :: Forall (Implies p q) :: Γ ⊢ Implies (capture_free_subst 0 c p) (capture_free_subst 0 c q)). { simpl; auto. }
  rewrite H0 in H1. clear H0.
  apply (@ND_imp_e (capture_free_subst 0 c p :: Forall (Implies p q) :: Γ) (capture_free_subst 0 c p) (capture_free_subst 0 c q)) in H1 as H2.
  apply ND_imp_i2 in H2 as H3.
  apply ND_imp_i2 in H3 as H4.
  assumption. apply ND_assume; prove_In.
Qed.

Theorem proj_r_forall {Γ p q} :
  Γ ⊢ Implies (Forall (And p q)) (Forall q).
Proof.
  set (c := fresh_evar (Forall (And p q) :: Γ) Falsum).
  apply ND_imp_i2.
  apply (@ND_forall_i (Forall (And p q) :: Γ) q c). 2: auto.
  Assume (Forall (And p q) :: Γ ⊢ Forall (And p q)).
  apply (@ND_forall_elim (Forall (And p q) :: Γ) (And p q) c) in H as H1.
  assert(Forall (And p q) :: Γ ⊢ capture_free_subst 0 c (And p q)
  = Forall (And p q) :: Γ ⊢ And (capture_free_subst 0 c p) (capture_free_subst 0 c q)). { simpl; auto. }
  rewrite H0 in H1. clear H0.
  apply (@ND_proj_r (Forall (And p q) :: Γ) (capture_free_subst 0 c p) (capture_free_subst 0 c q)) in H1.
  assumption.
Qed.

Theorem proj_l_forall {Γ p q} :
  Γ ⊢ Implies (Forall (And p q)) (Forall p).
Proof.
  set (c := fresh_evar (Forall (And p q) :: Γ) Falsum).
  apply ND_imp_i2.
  apply (@ND_forall_i (Forall (And p q) :: Γ) p c). 2: auto.
  Assume (Forall (And p q) :: Γ ⊢ Forall (And p q)).
  apply (@ND_forall_elim (Forall (And p q) :: Γ) (And p q) c) in H as H1.
  assert(Forall (And p q) :: Γ ⊢ capture_free_subst 0 c (And p q)
  = Forall (And p q) :: Γ ⊢ And (capture_free_subst 0 c p) (capture_free_subst 0 c q)). { simpl; auto. }
  rewrite H0 in H1. clear H0.
  apply (@ND_proj_l (Forall (And p q) :: Γ) (capture_free_subst 0 c p) (capture_free_subst 0 c q)) in H1.
  assumption.
Qed.

Theorem universal_hypothetical_syllogism {Γ p q r} :
  Γ ⊢ Implies (Forall (Implies p q))
        (Implies (Forall (Implies q r)) (Forall (Implies p r))).
Proof.
  intros.
  apply ND_imp_i2; apply ND_imp_i2.
  set (t := fresh_evar (Forall (Implies q r) :: Forall (Implies p q) :: Γ) Falsum).
  Assume ((capture_free_subst 0 t p) :: Forall (Implies q r) :: Forall (Implies p q) :: Γ ⊢ Forall (Implies p q)).
  Assume ((capture_free_subst 0 t p) :: Forall (Implies q r) :: Forall (Implies p q) :: Γ ⊢ Forall (Implies q r)).
  apply (@ND_forall_elim ((capture_free_subst 0 t p) :: Forall (Implies q r) :: Forall (Implies p q) :: Γ )
          (Implies p q) t) in H as H1.
  apply (@ND_forall_elim ((capture_free_subst 0 t p) :: Forall (Implies q r) :: Forall (Implies p q) :: Γ )
          (Implies q r) t) in H0 as H2.
  assert ((capture_free_subst 0 t p) :: Forall (Implies q r) :: Forall (Implies p q) :: Γ
     ⊢ capture_free_subst 0 t (Implies p q) = (capture_free_subst 0 t p) :: Forall (Implies q r) :: Forall (Implies p q) :: Γ
     ⊢  Implies (capture_free_subst 0 t p) (capture_free_subst 0 t q)). { simpl; auto. }
  assert ((capture_free_subst 0 t p) :: Forall (Implies q r) :: Forall (Implies p q) :: Γ
     ⊢ capture_free_subst 0 t (Implies q r) = (capture_free_subst 0 t p) :: Forall (Implies q r) :: Forall (Implies p q) :: Γ
     ⊢  Implies (capture_free_subst 0 t q) (capture_free_subst 0 t r)). { simpl; auto. }
  rewrite H3 in H1. rewrite H4 in H2.
  Assume ((capture_free_subst 0 t p) :: Forall (Implies q r) :: Forall (Implies p q) :: Γ ⊢ (capture_free_subst 0 t p)).
  apply (@ND_imp_e (capture_free_subst 0 t p
     :: Forall (Implies q r) :: Forall (Implies p q) :: Γ) (capture_free_subst 0 t p)) in H1.
  2: assumption.
  apply (@ND_imp_e (capture_free_subst 0 t p
     :: Forall (Implies q r) :: Forall (Implies p q) :: Γ) (capture_free_subst 0 t q)) in H2.
  2: assumption.
  apply ND_imp_i2 in H2.
  assert (Forall (Implies q r)
     :: Forall (Implies p q) :: Γ
     ⊢ Implies (capture_free_subst 0 t p)
         (capture_free_subst 0 t r) = Forall (Implies q r)
     :: Forall (Implies p q) :: Γ
     ⊢ (capture_free_subst 0 t (Implies  p r))). { simpl; auto. }
  rewrite H6 in H2.
  apply (@ND_forall_i (Forall (Implies q r) :: Forall (Implies p q) :: Γ) (Implies p r) t) in H2.
  assumption. auto.
Qed.

Theorem forall_proj_l {Γ p q} :
  Γ ⊢ Forall (Implies (And p q) p).
Proof.
  intros.
  set (t := fresh_evar Γ Falsum).
  apply (ND_forall_i (t := t)).
  simpl; auto. set (p' := (capture_free_subst 0 t p)).
  set (q' := (capture_free_subst 0 t q)).
  apply ND_imp_i2; apply ND_and_context; apply ND_assume; prove_In.
  unfold t; reflexivity.
Qed.

Theorem forall_proj_r {Γ p q} :
  Γ ⊢ Forall (Implies (And p q) q).
Proof.
  intros.
  set (t := fresh_evar Γ Falsum).
  apply (ND_forall_i (t := t)).
  simpl; auto. set (p' := (capture_free_subst 0 t p)).
  set (q' := (capture_free_subst 0 t q)).
  apply ND_imp_i2; apply ND_and_context; apply ND_assume; prove_In.
  unfold t; reflexivity.
Qed.

Theorem conj_l {Γ p q r} :
  Γ ⊢ Forall (Implies q r) -> Γ ⊢ Forall (Implies (And p q) (And p r)).
Proof.
  intros.
  set (t := fresh_evar Γ Falsum).
  apply (ND_forall_i (t := t)). 2: unfold t; reflexivity.
  simpl; auto. apply ND_imp_i2; apply ND_and_context.
  apply ND_and_intro. apply ND_assume; prove_In.
  Assume (capture_free_subst 0 t p :: capture_free_subst 0 t q :: Γ ⊢ capture_free_subst 0 t q).
  apply (ND_forall_elim (t := t)) in H as H1.
  simpl in H1.
  apply (@weakening Γ (capture_free_subst 0 t p :: capture_free_subst 0 t q :: Γ)) in H1.
  apply (ND_imp_e (p := capture_free_subst 0 t q)) in H1.
  assumption. assumption. apply subcontext_weaken; apply subcontext_weaken;
  apply subcontext_reflex.
Qed.

End ImportantTheorems.

Theorem implies_equiv_or_not {Γ p q} :
  Γ ⊢ Iff (Implies p q) (Or (Not p) q).
Proof.
  apply ND_Iff_intro.
  - assert (Implies p q :: Γ ⊢ Or p (Not p)). { apply ND_excluded_middle. }
    apply (ND_proof_by_cases (r := Or (Not p) q)) in H. assumption.
    Assume (p :: Implies p q :: Γ ⊢ Implies p q).
    Assume (p :: Implies p q :: Γ ⊢ p).
    apply ND_or_intro_r.
    apply (@ND_imp_e (p :: Implies p q :: Γ) p q). assumption. assumption.
    apply ND_or_intro_l. apply ND_assume; prove_In.
  - apply ND_imp_i2.
    Assume (p :: Or (Not p) q :: Γ ⊢ Or (Not p) q).
    apply (ND_proof_by_cases (p := Not p) (q := q) (r := q)).
    apply ND_assume; prove_In.
    apply (ND_not_e (q := q) (p := p)). prove_In. prove_In.
    apply ND_assume; prove_In.
Qed.

Section QuantifierTheorems.
Theorem not_Forall {Γ p} :
  Γ ⊢ Implies (Not (Forall p)) (Exists (Not p)).
Proof.
  intros.
  apply ND_imp_i2.
  assert (Not (Forall p) :: Γ ⊢ Exists (Not p)). {
    Assume (Not (Forall p) :: Γ ⊢ Not (Forall p)).
    unfold Forall; simpl; auto.
    unfold Forall in H; simpl in H; auto.
    assert (Not (Not (Exists (Not p))) :: Γ
    ⊢ Implies (Not (Not (Exists (Not p)))) (Exists (Not p))). { apply ND_double_negation. }
    apply (@ND_imp_e (Not (Not (Exists (Not p))) :: Γ) (Not (Not (Exists (Not p))))) in H0.
    assumption. assumption.
  }
  assumption.
Qed.

Lemma exists_not_not {Γ p} :
  Γ ⊢ Implies (Exists (Not (Not p))) (Exists p).
Proof.
  intros. apply ND_imp_i2.
  set (c := fresh_evar Γ (Exists p)).
  apply (ND_exists_elim_small (c := c) (p := Not (Not p)) (q := Exists p)).
  2: unfold c; reflexivity.
  assert (capture_free_subst 0 c (Not (Not p)) = Not (Not (capture_free_subst 0 c p))). {
    simpl; auto.
  }
  rewrite H.
  Assume (Not (Not (capture_free_subst 0 c p)) :: Γ ⊢ Not (Not (capture_free_subst 0 c p))).
  assert (Not (Not (capture_free_subst 0 c p)) :: Γ
            ⊢ Implies (Not (Not (capture_free_subst 0 c p)))
                    (capture_free_subst 0 c p)). {
    apply (@ND_double_negation (Not (Not (capture_free_subst 0 c p))::Γ) (capture_free_subst 0 c p)).
  }
  apply (@ND_imp_e (Not (Not (capture_free_subst 0 c p))::Γ) (Not (Not (capture_free_subst 0 c p)))) in H1 as H2.
  2: assumption.
  apply ND_exists_intro in H2. assumption.
Qed.

Theorem not_Exists {Γ p} :
  Γ ⊢ Implies (Not (Exists p)) (Forall (Not p)).
Proof.
  apply ND_imp_i2.
  assert (Not (Exists p) :: Γ ⊢ Forall (Not p)). {
    Assume (Not (Exists p) :: Γ ⊢ Not (Exists p)).
    unfold Forall; simpl; auto.
    assert (Not (Exists p) :: Γ
       ⊢ Implies (Implies (Exists (Not (Not p))) (Exists p))
           (Implies (Not (Exists p)) (Not (Exists (Not (Not p)))))). {
      assert (Not (Exists p) :: Γ ⊢ Implies (Exists (Not (Not p))) (Exists p)). {
        apply exists_not_not.
      }
      apply contrapositive.
    }
    assert (Not (Exists p) :: Γ ⊢ Implies (Exists (Not (Not p))) (Exists p)). {
      apply exists_not_not.
    }
    apply (@ND_imp_e (Not (Exists p) :: Γ) (Implies (Exists (Not (Not p))) (Exists p))) in H0.
    2: assumption.
    apply (@ND_imp_e (Not (Exists p) :: Γ) (Not (Exists p))) in H0.
    2: assumption.
    assumption.
  }
  assumption.
Qed.

Lemma exists_not_not_exists {Γ p} :
  Γ ⊢ Implies (Exists (Not (Not p))) (Exists p).
Proof.
  intros.
  apply ND_imp_i2.
  set (t := fresh_evar Γ (Exists p)).
  apply (ND_exists_elim_small (Γ := Γ) (p := (Not (Not p))) (c := t)).
  2: unfold t; reflexivity.
  assert (capture_free_subst 0 t (Not (Not p)) = Not (Not (capture_free_subst 0 t p))). { simpl; auto. }
  rewrite H.
  Assume(Not (Not (capture_free_subst 0 t p)) :: Γ ⊢ Not (Not (capture_free_subst 0 t p))).
  assert (Not (Not (capture_free_subst 0 t p)) :: Γ
     ⊢ Implies (Not (Not (capture_free_subst 0 t p))) (capture_free_subst 0 t p)). {
    apply ND_double_negation.
  }
  apply (ND_imp_e (q := capture_free_subst 0 t p)) in H0. 2: assumption.
  apply ND_exists_intro in H0.
  assumption.
Qed.

Theorem forall_subst : forall (n : nat) (t : Term) (p : Formula),
  capture_free_subst n t (Forall p) = Forall (capture_free_subst (S n) (lift (S n) 1 t) p).
Proof.
  intros.
  unfold Forall; unfold capture_free_subst; simpl; auto.
Qed.

Lemma forall_implies_verum_step {Γ} :
  forall (p : Formula),
  Γ ⊢ Implies (Forall p) Verum <-> Γ ⊢ Forall (Implies p Verum).
Proof.
  split.
  - intros.
    set (t := fresh_evar Γ Falsum).
    apply (@ND_forall_i Γ (Implies p Verum) t).
    2: unfold t; reflexivity.
    assert (Γ ⊢ capture_free_subst 0 t (Implies p Verum)
            = Γ ⊢ Implies (capture_free_subst 0 t p) Verum). {
      simpl; auto.
    }
    rewrite H0.
    apply ND_imp_i2.
    apply ND_True_intro.
  - intros. apply ND_imp_i2; apply ND_True_intro.
Qed.
Section CommutingConnectivesAndQuantifiers.
Lemma capturing_garbage_bvars {Γ} :
  forall (p : Formula) (t : Term),
  Γ ⊢ p -> capture_free_subst 0 t p = p.
Admitted.

Lemma wff_capture_free_vacuity {Γ} :
  forall (p : Formula) (t : Term),
  Γ ⊢ p -> (capture_free_subst 0 t p) = p.
Admitted.

Lemma wff_capture_free_vacuity_antecedent {Γ} :
  forall (p q : Formula) (t : Term),
  Γ ⊢ (Implies (Forall p) q) -> (capture_free_subst 0 t q) = q.
Admitted.

Theorem implies_or_not {Γ} :
  forall (p q : Formula),
  Γ ⊢ Implies p q <-> Γ ⊢ Or (Not p) q.
Proof.
  intros. split.
  - intros. assert (Γ ⊢ Iff (Implies p q) (Or (Not p) q)). {
      apply implies_equiv_or_not.
    }
    apply ND_Iff_elim_l in H0. assumption. assumption.
  - intros. assert (Γ ⊢ Iff (Implies p q) (Or (Not p) q)). {
      apply implies_equiv_or_not.
    }
    apply ND_Iff_elim_r in H0. assumption. assumption.
Qed.

Theorem ND_or_elim {Γ} :
  forall (p q r : Formula),
  p::Γ ⊢ r -> q::Γ ⊢r -> (Or p q)::Γ ⊢ r.
Proof.
  intros.
  apply (ND_proof_by_cases (Γ := (Or p q)::Γ) (r := r) (p := p) (q := q)).
  apply ND_assume; prove_In.
  - assert (p :: Γ ⊆ p :: Or p q :: Γ). { apply subcontext_cons. split. prove_In.
      apply subcontext_weaken; apply subcontext_weaken; apply subcontext_reflex.
    }
    apply (@weakening (p :: Γ) ( p :: Or p q :: Γ)) in H. assumption.
    assumption.
  - assert (q :: Γ ⊆ q :: Or p q :: Γ). { apply subcontext_cons. split. prove_In.
      apply subcontext_weaken; apply subcontext_weaken; apply subcontext_reflex.
    }
    apply (@weakening (q :: Γ) ( q :: Or p q :: Γ)) in H0. assumption.
    assumption.
Qed.

(*

Lemma wff_capture_free_vacuity {Γ} :
  forall (p : Formula) (t : Term)
  Γ ⊢ p -> (capture_free_subst 0 t p) = p.
Proof.
  intros.
  apply ND_Iff_intro.
  - assert (Implies (Forall p) q :: Γ ⊢ Iff (Implies (Forall p) q) (Or (Not (Forall p)) q)). {
      apply (implies_equiv_or_not (Γ := Implies (Forall p) q :: Γ) (p := Forall p) (q := q)).
    }
    apply ND_Iff_elim_l in H. 2: apply ND_assume; prove_In.
    set (t := fresh_evar (Implies (Forall p) q :: Γ) Falsum).
    apply (ND_exists_intro (Γ := Implies (Forall p) q :: Γ) (t := t)).
    simpl; auto.
*)

Theorem and_forall_equiv_forall_and {Γ} :
  forall (p q : Formula),
  Γ ⊢ Iff (And (Forall p) (Forall q)) (Forall (And p q)).
Proof.
  intros. apply ND_Iff_intro.
  - apply ND_and_context.
    set (t := fresh_evar ((Forall p)::(Forall q) :: Γ) Falsum).
    apply (ND_forall_i (Γ := ((Forall p)::(Forall q) :: Γ)) (t := t)).
    2: { unfold t; reflexivity. }
    simpl; auto.
    apply ND_and_intro.
    + apply ND_forall_elim; apply ND_assume; prove_In.
    + apply ND_forall_elim; apply ND_assume; prove_In.
  - Assume (Forall (And p q) :: Γ ⊢  Forall (And p q)).
    set (t := fresh_evar (Forall (And p q) :: Γ) Falsum).
    apply (ND_forall_elim (Γ := Forall (And p q) :: Γ) (t := t)) in H as H0.
    simpl in H0.
    apply ND_proj_l in H0 as H1.
    apply ND_forall_i in H1.
    apply ND_proj_r in H0 as H2.
    apply ND_forall_i in H2.
    apply ND_and_intro. assumption. assumption.
    unfold t; reflexivity. unfold t; reflexivity.
Qed.

Theorem or_exists_iff_exists_or {Γ} :
  forall (p q : Formula),
  Γ ⊢ Iff (Or (Exists p) (Exists q)) (Exists (Or p q)).
Proof.
  intros; apply ND_Iff_intro.
  - set (c := fresh_evar Γ (Exists (Or p q))).
    apply ND_or_elim with (p := (Exists p)) (q := (Exists q)) (r := Exists (Or p q)).
    + apply (@ND_exists_elim_small Γ p (Exists (Or p q)) c).
      2: unfold c; reflexivity.
      apply (@ND_exists_intro (capture_free_subst 0 c p :: Γ) (Or p q) c).
      simpl; auto.
      apply ND_or_intro_l; apply ND_assume; prove_In.
    + apply (@ND_exists_elim_small Γ q (Exists (Or p q)) c).
      2: unfold c; reflexivity.
      apply (@ND_exists_intro (capture_free_subst 0 c q :: Γ) (Or p q) c).
      simpl; auto.
      apply ND_or_intro_r; apply ND_assume; prove_In.
  - set (c := fresh_evar Γ (Or (Exists p) (Exists q))).
    apply (ND_exists_elim_small (c := c) (q :=  Or (Exists p) (Exists q)) (p := Or p q)).
    2: unfold c; reflexivity.
    assert (capture_free_subst 0 c (Or p q) = Or (capture_free_subst 0 c p) (capture_free_subst 0 c q)). {
      simpl; auto.
    }
    rewrite H.
    apply (@ND_or_elim Γ (capture_free_subst 0 c p) (capture_free_subst 0 c q) (Or (Exists p) (Exists q))).
    + apply ND_or_intro_l.
      apply (@ND_exists_intro (capture_free_subst 0 c p :: Γ) p c).
      apply ND_assume; prove_In.
    + apply ND_or_intro_r.
      apply (@ND_exists_intro (capture_free_subst 0 c q :: Γ) q c).
      apply ND_assume; prove_In.
Qed.

Theorem exists_and_implies_and_exists {Γ} :
  forall (p q : Formula),
  Γ ⊢ Implies (Exists (And p q)) (And (Exists p) (Exists q)).
Proof.
  intros. apply ND_imp_i2.
  set (c := fresh_evar Γ (And (Exists p) (Exists q))).
  apply (@ND_exists_elim_small Γ (And p q) (And (Exists p) (Exists q)) c).
  2: unfold c; reflexivity.
  simpl; auto. apply ND_and_context.
  apply ND_and_intro.
  - apply (@ND_exists_intro (capture_free_subst 0 c p :: capture_free_subst 0 c q :: Γ) p c).
    apply ND_assume; prove_In.
  - apply (@ND_exists_intro (capture_free_subst 0 c p :: capture_free_subst 0 c q :: Γ) q c).
    apply ND_assume; prove_In.
Qed.

Theorem or_forall_implies_forall_or {Γ} :
  forall (p q : Formula),
  Γ ⊢ Implies (Or (Forall p) (Forall q)) (Forall (Or p q)).
Proof.
  intros. apply ND_imp_i2.
  set (t := fresh_evar (Or (Forall p) (Forall q) :: Γ) Falsum).
  apply (@ND_forall_i (Or (Forall p) (Forall q) :: Γ) (Or p q) t).
  2: unfold t; reflexivity.
  simpl; auto.
  apply ND_or_elim.
  - apply ND_or_intro_l.
    apply ND_forall_elim. apply ND_assume; prove_In.
  - apply ND_or_intro_r; apply ND_forall_elim; apply ND_assume; prove_In.
Qed.

(** There is a complicated, counter-intuitive relationship between existential
and universal quantifiers. Namely:

$$ \exists x \forall y \varphi(x,y)\implies \forall y\exists x \varphi(x,y). $$

Using de Bruijn indices, this is a bit trickier. I will not even try to prove
this, but it's nice to know. *)

(*
Lemma push_forall_above_and {Γ} :
  forall (p q : Formula),
  Γ ⊢ Iff (And p (Forall q)) (Forall (And (shift p) q)).
Proof.
  intros.
  apply ND_Iff_intro.
  - apply ND_and_context.
    set (t := fresh_evar (p :: Forall q :: Γ) Falsum).
    apply (ND_forall_i (t := t)). 2: unfold t; reflexivity.
*)

Theorem implies_forall_equiv_exists_implies {Γ} :
  forall (p q : Formula),
  Γ ⊢ Iff (Implies (Forall p) q) (Exists (Implies p q)).
Proof.
Admitted.

End CommutingConnectivesAndQuantifiers.
End QuantifierTheorems.

Theorem Verum_implies_Verum :
  proves (Implies Verum Verum).
Proof.
  apply ND_imp_i2; apply ND_True_intro.
Qed.

Corollary forall_Verum_implies_Verum :
  proves (Forall (Implies Verum Verum)).
Proof.
  set (t := fresh_evar []%list Falsum).
  apply (ND_forall_i (t := t)). 2: unfold t; reflexivity.
  simpl; auto; fold Verum; apply Verum_implies_Verum.
Qed.

Corollary exists_Verum :
  proves (Exists Verum).
Proof.
  set (t := fresh_evar []%list Verum).
  apply (ND_exists_intro (t := t)).
  simpl; auto; fold Verum; apply ND_True_intro.
Qed.

Lemma forall_and_subst {Γ} :
  forall (p : Formula) (t : Term),
  Γ ⊢ Iff (Forall p) (And (Forall p) (capture_free_subst 0 t p)).
Proof.
  intros. apply ND_Iff_intro.
  - apply ND_and_intro. apply ND_assume; prove_In.
    apply (ND_forall_elim (t := t)). apply ND_assume; prove_In.
  - apply ND_and_context; apply ND_assume; prove_In.
Qed.

Lemma implies_verum {Γ} :
  forall (p : Formula),
  Γ ⊢ Implies Verum p <-> Γ ⊢ p.
Proof. split.
  - intros; apply (ND_imp_e (p := Verum)) in H. assumption. apply ND_True_intro.
  - intros. apply ND_imp_i2. apply (@weakening Γ (Verum::Γ)%list) in H.
    assumption. prove_subcontext.
Qed.

Lemma implies_forall_e {Γ} :
  forall (p q : Formula) (t : Term),
  Γ ⊢ Implies p (Forall q) ->
  Γ ⊢ Implies p (capture_free_subst 0 t q).
Proof. intros.
  apply ND_imp_i2; apply (@weakening Γ (p::Γ)%list) in H; Assume ((p::Γ)%list ⊢ p).
  apply (ND_imp_e (p := p)) in H.
  apply (ND_forall_elim (t := t)) in H. assumption. assumption. prove_subcontext.
Qed.

(* Similarly, we have [Γ ⊢ Iff (Exists p) (Or (Exists p) (capture_free_subst 0 t p))]. *)

Theorem consistency : not (proves Falsum).
Proof.
  unfold not; intro.
  induction H.
  - apply IHdeducible.
  - (* ND_imp_e *) contradict IHdeducible1.
  - (* ND_imp_i *) contradict IHdeducible.
  - (* ND_or_intro_l *) contradict IHdeducible.
  - (* ND_or_intro_r *) contradict IHdeducible.
  - (* ND_proof_by_cases *) contradict IHdeducible1.
  - (* ND_and_intro *) contradict IHdeducible1.
  - (* ND_and_elim *) contradict IHdeducible1.
  - (* ND_cut *) contradict IHdeducible1.
  - (* ND_exists_elim *) contradict IHdeducible.
  - (* ND_exists_intro *) contradict IHdeducible.
  - (* ND_forall_elim *) contradict IHdeducible.
  - (* ND_forall_intro *) contradict IHdeducible.
  - (* ND_proof_by_contradiction *) contradict IHdeducible.
Qed.


Require Export EquivDec.
Require Import Strings.String.
Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.Relations.Relation_Definitions.
Require Import ZArith NArith.

Ltac solve_eq_eqb_translations :=
  intros;
  unfold "<>b", "==b" in *;
  destruct (equiv_dec _ _); intuition; eauto.

Lemma equiv_decb_refl : forall {T} (x: T) {R: T -> T -> Prop} {equiv: Equivalence R} {ED: EqDec T R},
    (equiv_decb x x) = true.
Proof. solve_eq_eqb_translations. Qed.

Lemma eqb_to_eq : forall {T} (x y: T) {ED: EqDec T eq},
    (x ==b y) = true -> x = y.
Proof. solve_eq_eqb_translations. Qed.

Lemma not_eqb_to_ne : forall {T} (x y: T) {ED: EqDec T eq},
    (x ==b y) = false -> x <> y.
Proof. solve_eq_eqb_translations. Qed.

Lemma neb_to_ne : forall {T} (x y: T) {ED: EqDec T eq},
    (x <>b y) = true -> x <> y.
Proof. solve_eq_eqb_translations. Qed.

Lemma not_neb_to_eq : forall {T} (x y: T) {ED: EqDec T eq},
    (x <>b y) = false -> x = y.
Proof. solve_eq_eqb_translations. Qed.

Lemma comp_equiv_dec_to_ne : forall {T} (x y: T) {ED: EqDec T eq},
    (x =/= y) -> x <> y.
Proof. intuition. Qed.

Lemma ne_to_neb : forall {T} (x y: T) {ED: EqDec T eq},
    x <> y -> x <>b y = true.
Proof. solve_eq_eqb_translations. Qed.

Lemma ne_to_neb' : forall {T} (x y: T) {ED: EqDec T eq},
    x <> y -> y <>b x = true.
Proof. solve_eq_eqb_translations. Qed.

Lemma ne_to_not_eqb : forall {T} (x y: T) {ED: EqDec T eq},
    x <> y -> x ==b y = false.
Proof. solve_eq_eqb_translations. Qed.

Lemma ne_to_not_eqb' : forall {T} (x y: T) {ED: EqDec T eq},
    x <> y -> y ==b x = false.
Proof. solve_eq_eqb_translations. Qed.

Hint Rewrite @equiv_decb_refl : rweq.
Hint Rewrite @ne_to_neb @ne_to_not_eqb @ne_to_neb' @ne_to_not_eqb' using assumption : rweq.

Ltac simpl_eqb :=
  repeat
    match goal with
    | [ H: ?x =/= ?y |- _ ] => apply (@comp_equiv_dec_to_ne _ _ _ _) in H
    | [ H: ?x === ?y |- _ ] => unfold "===" in H; subst
    | [ H: (?x ==b ?y) = true |- _ ] => apply (@eqb_to_eq _ _ _ _) in H; subst
    | [ H: (?x ==b ?y) = false |- _ ] => apply (@not_eqb_to_ne _ _ _ _) in H
    | [ H: (?x <>b ?y) = true |- _ ] => apply (@neb_to_ne _ _ _ _) in H
    | [ H: (?x <>b ?y) = false |- _ ] => apply (@not_neb_to_eq _ _ _ _) in H; subst
    end;
  autorewrite with rweq.

Global Instance string_eqdec : EqDec string eq := string_dec.

Global Instance Z_eqdec : EqDec Z eq.
Proof.
  intro a. intro b.
  destruct (Z_dec a b).
  - right.
    destruct s.
    + apply Z.lt_neq.
      assumption.
    + apply Z.gt_lt in g.
      apply Z.lt_neq in g.
      intro.
      auto.
  - intuition.
Qed.

Global Instance nat_eqdec : EqDec nat eq := eq_nat_dec.

Global Instance Some_eqdec :
  forall T, EqDec T eq -> EqDec (option T) eq.
Proof.
  intros.
  intro x. intro y.
  unfold "===", complement.
  destruct x; destruct y.
  - destruct (t == t0).
    + unfold "===" in *.
      subst; auto.
    + right.
      intros.
      inversion H. subst.
      intuition.
  - right.
    inversion 1.
  - right.
    inversion 1.
  - left.
    reflexivity.
Qed.

Lemma proj1_sig_injective :
  forall T P (t1 t2: { v: T | P v }),
    proj1_sig t1 = proj1_sig t2 -> t1 = t2.
Proof.
  intros T P [v1 p1] [v2 p2] H.
  simpl in *.
  subst.
  f_equal.
  apply proof_irrelevance.
Qed.

Global Instance sig_eqdec : forall T P, EqDec T eq -> EqDec { v: T | P v} eq.
Proof.
  intros.
  unfold EqDec.
  intros.
  destruct (proj1_sig x == proj1_sig y).
  - left.
    apply proj1_sig_injective.
    auto.
  - right.
    intro.
    unfold "===" in H.
    subst.
    apply c.
    reflexivity.
Qed.


(** * Stlc: The Simply Typed Lambda-Calculus *)

Require Export Types.

(* ###################################################################### *)
(** * The Simply Typed Lambda-Calculus *)

(** The simply typed lambda-calculus (STLC) is a tiny core calculus
    embodying the key concept of _functional abstraction_, which shows
    up in pretty much every real-world programming language in some
    form (functions, procedures, methods, etc.).

    We will follow exactly the same pattern as in the previous
    chapter when formalizing this calculus (syntax, small-step
    semantics, typing rules) and its main properties (progress and
    preservation).  The new technical challenges (which will take some
    work to deal with) all arise from the mechanisms of _variable
    binding_ and _substitution_. *)

(* ###################################################################### *)
(** ** Overview *)

(** The STLC is built on some collection of _base types_ -- booleans,
    numbers, strings, etc.  The exact choice of base types doesn't
    matter -- the construction of the language and its theoretical
    properties work out pretty much the same -- so for the sake of
    brevity let's take just [Bool] for the moment.  At the end of the
    chapter we'll see how to add more base types, and in later
    chapters we'll enrich the pure STLC with other useful constructs
    like pairs, records, subtyping, and mutable state.

    Starting from the booleans, we add three things:
        - variables
        - function abstractions
        - application

    This gives us the following collection of abstract syntax
    constructors (written out here in informal BNF notation -- we'll
    formalize it below).

*)

(** Informal concrete syntax:
       t ::= x                       variable
           | \x:T1.t2                abstraction
           | t1 t2                   application
           | true                    constant true
           | false                   constant false
           | if t1 then t2 else t3   conditional
*)

(** The [\] symbol (backslash, in ascii) in a function abstraction
    [\x:T1.t2] is generally written as a greek letter "lambda" (hence
    the name of the calculus).  The variable [x] is called the
    _parameter_ to the function; the term [t1] is its _body_.  The
    annotation [:T] specifies the type of arguments that the function
    can be applied to. *)

(** Some examples:

      - [\x:Bool. x]

        The identity function for booleans.

      - [(\x:Bool. x) true]

        The identity function for booleans, applied to the boolean [true].

      - [\x:Bool. if x then false else true]

        The boolean "not" function.

      - [\x:Bool. true]

        The constant function that takes every (boolean) argument to
        [true]. *)
(**
      - [\x:Bool. \y:Bool. x]

        A two-argument function that takes two booleans and returns
        the first one.  (Note that, as in Coq, a two-argument function
        is really a one-argument function whose body is also a
        one-argument function.)

      - [(\x:Bool. \y:Bool. x) false true]

        A two-argument function that takes two booleans and returns
        the first one, applied to the booleans [false] and [true].

        Note that, as in Coq, application associates to the left --
        i.e., this expression is parsed as [((\x:Bool. \y:Bool. x)
        false) true].

      - [\f:Bool->Bool. f (f true)]

        A higher-order function that takes a _function_ [f] (from
        booleans to booleans) as an argument, applies [f] to [true],
        and applies [f] again to the result.

      - [(\f:Bool->Bool. f (f true)) (\x:Bool. false)]

        The same higher-order function, applied to the constantly
        [false] function. *)

(** As the last several examples show, the STLC is a language of
    _higher-order_ functions: we can write down functions that take
    other functions as arguments and/or return other functions as
    results.

    Another point to note is that the STLC doesn't provide any
    primitive syntax for defining _named_ functions -- all functions
    are "anonymous."  We'll see in chapter [MoreStlc] that it is easy
    to add named functions to what we've got -- indeed, the
    fundamental naming and binding mechanisms are exactly the same.

    The _types_ of the STLC include [Bool], which classifies the
    boolean constants [true] and [false] as well as more complex
    computations that yield booleans, plus _arrow types_ that classify
    functions. *)
(**
      T ::= Bool
          | T1 -> T2
    For example:

      - [\x:Bool. false] has type [Bool->Bool]

      - [\x:Bool. x] has type [Bool->Bool]

      - [(\x:Bool. x) true] has type [Bool]

      - [\x:Bool. \y:Bool. x] has type [Bool->Bool->Bool] (i.e. [Bool -> (Bool->Bool)])

      - [(\x:Bool. \y:Bool. x) false] has type [Bool->Bool]

      - [(\x:Bool. \y:Bool. x) false true] has type [Bool]
*)

(* ###################################################################### *)
(** ** Syntax *)

Module STLC.

(* ################################### *)
(** *** Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty.

(* ################################### *)
(** *** Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "ttrue"
  | Case_aux c "tfalse" | Case_aux c "tif" ].

(** Note that an abstraction [\x:T.t] (formally, [tabs x T t]) is
    always annotated with the type [T] of its parameter, in contrast
    to Coq (and other functional languages like ML, Haskell, etc.),
    which use _type inference_ to fill in missing annotations.  We're
    not considering type inference here, to keep things simple. *)

(** Some examples... *)

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

(** [idB = \x:Bool. x] *)

Notation idB :=
  (tabs x TBool (tvar x)).

(** [idBB = \x:Bool->Bool. x] *)

Notation idBB :=
  (tabs x (TArrow TBool TBool) (tvar x)).

(** [idBBBB = \x:(Bool->Bool) -> (Bool->Bool). x] *)

Notation idBBBB :=
  (tabs x (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))
    (tvar x)).

(** [k = \x:Bool. \y:Bool. x] *)

Notation k := (tabs x TBool (tabs y TBool (tvar x))).

(** [notB = \x:Bool. if x then false else true] *)

Notation notB := (tabs x TBool (tif (tvar x) tfalse ttrue)).

(** (We write these as [Notation]s rather than [Definition]s to make
    things easier for [auto].) *)

(* ###################################################################### *)
(** ** Operational Semantics *)

(** To define the small-step semantics of STLC terms, we begin -- as
    always -- by defining the set of values.  Next, we define the
    critical notions of _free variables_ and _substitution_, which are
    used in the reduction rule for application expressions.  And
    finally we give the small-step relation itself. *)

(* ################################### *)
(** *** Values *)

(** To define the values of the STLC, we have a few cases to consider.

    First, for the boolean part of the language, the situation is
    clear: [true] and [false] are the only values.  An [if]
    expression is never a value. *)

(** Second, an application is clearly not a value: It represents a
    function being invoked on some argument, which clearly still has
    work left to do. *)

(** Third, for abstractions, we have a choice:

      - We can say that [\x:T.t1] is a value only when [t1] is a
        value -- i.e., only if the function's body has been
        reduced (as much as it can be without knowing what argument it
        is going to be applied to).

      - Or we can say that [\x:T.t1] is always a value, no matter
        whether [t1] is one or not -- in other words, we can say that
        reduction stops at abstractions.

    Coq, in its built-in functional programming langauge, makes the
    first choice -- for example,
         Eval simpl in (fun x:bool => 3 + 4)
    yields [fun x:bool => 7].

    Most real-world functional programming languages make the second
    choice -- reduction of a function's body only begins when the
    function is actually applied to an argument.  We also make the
    second choice here. *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.

Hint Constructors value.

(** Finally, we must consider what constitutes a _complete_ program.

  Intuitively, a "complete" program must not refer to any undefined
  variables.  We'll see shortly how to define the "free" variables
  in a STLC term.  A program is "closed", that is, it contains no
  free variables.

*)

(** Having made the choice not to reduce under abstractions,
    we don't need to worry about whether variables are values, since
    we'll always be reducing programs "from the outside in," and that
    means the [step] relation will always be working with closed
    terms (ones with no free variables).  *)

(* ###################################################################### *)
(** *** Substitution *)

(** Now we come to the heart of the STLC: the operation of
    substituting one term for a variable in another term.

    This operation will be used below to define the operational
    semantics of function application, where we will need to
    substitute the argument term for the function parameter in the
    function's body.  For example, we reduce
       (\x:Bool. if x then true else x) false
    to
       if false then true else false
]]
    by substituting [false] for the parameter [x] in the body of the
    function.

    In general, we need to be able to substitute some given
    term [s] for occurrences of some variable [x] in another term [t].
    In informal discussions, this is usually written [ [x:=s]t ] and
    pronounced "substitute [x] with [s] in [t]." *)

(** Here are some examples:

      - [[x:=true] (if x then x else false)] yields [if true then true else false]

      - [[x:=true] x] yields [true]

      - [[x:=true] (if x then x else y)] yields [if true then true else y]

      - [[x:=true] y] yields [y]

      - [[x:=true] false] yields [false] (vacuous substitution)

      - [[x:=true] (\y:Bool. if y then x else false)] yields [\y:Bool. if y then true else false]
      - [[x:=true] (\y:Bool. x)] yields [\y:Bool. true]

      - [[x:=true] (\y:Bool. y)] yields [\y:Bool. y]

      - [[x:=true] (\x:Bool. x)] yields [\x:Bool. x]

    The last example is very important: substituting [x] with [true] in
    [\x:Bool. x] does _not_ yield [\x:Bool. true]!  The reason for
    this is that the [x] in the body of [\x:Bool. x] is _bound_ by the
    abstraction: it is a new, local name that just happens to be
    spelled the same as some global name [x]. *)

(** Here is the definition, informally...
   [x:=s]x = s
   [x:=s]y = y                                   if x <> y
   [x:=s](\x:T11.t12)   = \x:T11. t12
   [x:=s](\y:T11.t12)   = \y:T11. [x:=s]t12      if x <> y
   [x:=s](t1 t2)        = ([x:=s]t1) ([x:=s]t2)
   [x:=s]true           = true
   [x:=s]false          = false
   [x:=s](if t1 then t2 else t3) =
                   if [x:=s]t1 then [x:=s]t2 else [x:=s]t3
]]
*)

(**    ... and formally: *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if eq_id_dec x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if eq_id_dec x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(** _Technical note_: Substitution becomes trickier to define if we
    consider the case where [s], the term being substituted for a
    variable in some other term, may itself contain free variables.
    Since we are only interested here in defining the [step] relation
    on closed terms (i.e., terms like [\x:Bool. x], that do not mention
    variables are not bound by some enclosing lambda), we can skip
    this extra complexity here, but it must be dealt with when
    formalizing richer languages. *)

(** *** *)
(** **** Exercise: 3 stars (substi) *)

(** The definition that we gave above uses Coq's [Fixpoint] facility
    to define substitution as a _function_.  Suppose, instead, we
    wanted to define substitution as an inductive _relation_ [substi].
    We've begun the definition by providing the [Inductive] header and
    one of the constructors; your job is to fill in the rest of the
    constructors. *)

Inductive substi (s:tm) (x:id) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tvar x) s
  (* FILL IN HERE *)
.

Hint Constructors substi.

Theorem substi_correct : forall s x t t',
  [x:=s]t = t' <-> substi s x t t'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################### *)
(** *** Reduction *)

(** The small-step reduction relation for STLC now follows the same
    pattern as the ones we have seen before.  Intuitively, to reduce a
    function application, we first reduce its left-hand side until it
    becomes a literal function; then we reduce its right-hand
    side (the argument) until it is also a value; and finally we
    substitute the argument for the bound variable in the body of the
    function.  This last rule, written informally as
      (\x:T.t12) v2 ==> [x:=v2]t12
    is traditionally called "beta-reduction". *)

(**
                               value v2
                     ----------------------------                   (ST_AppAbs)
                     (\x:T.t12) v2 ==> [x:=v2]t12

                              t1 ==> t1'
                           ----------------                           (ST_App1)
                           t1 t2 ==> t1' t2

                              value v1
                              t2 ==> t2'
                           ----------------                           (ST_App2)
                           v1 t2 ==> v1 t2'
*)
(** ... plus the usual rules for booleans:
                    --------------------------------                (ST_IfTrue)
                    (if true then t1 else t2) ==> t1

                    ---------------------------------              (ST_IfFalse)
                    (if false then t1 else t2) ==> t2

                              t1 ==> t1'
         ----------------------------------------------------           (ST_If)
         (if t1 then t2 else t3) ==> (if t1' then t2 else t3)
*)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1"
  | Case_aux c "ST_App2" | Case_aux c "ST_IfTrue"
  | Case_aux c "ST_IfFalse" | Case_aux c "ST_If" ].

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

(* ##################################### *)
(** *** Examples *)

(** Example:
    ((\x:Bool->Bool. x) (\x:Bool. x)) ==>* (\x:Bool. x)
i.e.
    (idBB idB) ==>* idB
*)

Lemma step_example1 :
  (tapp idBB idB) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl.  Qed.

(** Example:
((\x:Bool->Bool. x) ((\x:Bool->Bool. x) (\x:Bool. x)))
      ==>* (\x:Bool. x)
i.e.
  (idBB (idBB idB)) ==>* idB.
*)

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply multi_refl.  Qed.

(** Example:
((\x:Bool->Bool. x) (\x:Bool. if x then false
                              else true)) true)
      ==>* false
i.e.
  ((idBB notB) ttrue) ==>* tfalse.
*)

Lemma step_example3 :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App1. apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_IfTrue. apply multi_refl.  Qed.

(** Example:
((\x:Bool->Bool. x) ((\x:Bool. if x then false
                               else true) true))
      ==>* false
i.e.
  (idBB (notB ttrue)) ==>* tfalse.
*)

Lemma step_example4 :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto. simpl.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_IfTrue.
  eapply multi_step.
    apply ST_AppAbs. auto. simpl.
  apply multi_refl.  Qed.

(** A more automatic proof *)

Lemma step_example1' :
  (tapp idBB idB) ==>* idB.
Proof. normalize.  Qed.

(** Again, we can use the [normalize] tactic from above to simplify
    the proof. *)

Lemma step_example2' :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  normalize.
Qed.

Lemma step_example3' :
  tapp (tapp idBB notB) ttrue ==>* tfalse.
Proof. normalize.  Qed.

Lemma step_example4' :
  tapp idBB (tapp notB ttrue) ==>* tfalse.
Proof. normalize.  Qed.

(** **** Exercise: 2 stars (step_example3) *)
(** Try to do this one both with and without [normalize]. *)

Lemma step_example5 :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  (* FILL IN HERE *) Admitted.

(* FILL IN HERE *)
(** [] *)

(* ###################################################################### *)
(** ** Typing *)

(* ################################### *)
(** *** Contexts *)

(** _Question_: What is the type of the term "[x y]"?

    _Answer_: It depends on the types of [x] and [y]!

    I.e., in order to assign a type to a term, we need to know
    what assumptions we should make about the types of its free
    variables.

    This leads us to a three-place "typing judgment", informally
    written [Gamma |- t \in T], where [Gamma] is a
    "typing context" -- a mapping from variables to their types. *)

(** We hide the definition of partial maps in a module since it is
    actually defined in [SfLib]. *)

Module PartialMap.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

(** Informally, we'll write [Gamma, x:T] for "extend the partial
    function [Gamma] to also map [x] to [T]."  Formally, we use the
    function [extend] to add a binding to a partial map. *)

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if eq_id_dec x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite eq_id. auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  x2 <> x1 ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite neq_id; auto.
Qed.

End PartialMap.

Definition context := partial_map ty.

(* ################################### *)
(** *** Typing Relation *)

(**
                             Gamma x = T
                            --------------                              (T_Var)
                            Gamma |- x \in T

                      Gamma , x:T11 |- t12 \in T12
                     ----------------------------                       (T_Abs)
                     Gamma |- \x:T11.t12 \in T11->T12

                        Gamma |- t1 \in T11->T12
                          Gamma |- t2 \in T11
                        ----------------------                          (T_App)
                         Gamma |- t1 t2 \in T12

                         --------------------                          (T_True)
                         Gamma |- true \in Bool

                        ---------------------                         (T_False)
                        Gamma |- false \in Bool

       Gamma |- t1 \in Bool    Gamma |- t2 \in T    Gamma |- t3 \in T
       --------------------------------------------------------          (T_If)
                  Gamma |- if t1 then t2 else t3 \in T

    We can read the three-place relation [Gamma |- t \in T] as:
    "to the term [t] we can assign the type [T] using as types for
    the free variables of [t] the ones specified in the context
    [Gamma]." *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      extend Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs"
  | Case_aux c "T_App" | Case_aux c "T_True"
  | Case_aux c "T_False" | Case_aux c "T_If" ].

Hint Constructors has_type.

(* ################################### *)
(** *** Examples *)

Example typing_example_1 :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof.
  apply T_Abs. apply T_Var. reflexivity.  Qed.

(** Note that since we added the [has_type] constructors to the hints
    database, auto can actually solve this one immediately. *)

Example typing_example_1' :
  empty |- tabs x TBool (tvar x) \in TArrow TBool TBool.
Proof. auto.  Qed.

(** Another example:
     empty |- \x:A. \y:A->A. y (y x))
           \in A -> (A->A) -> A.
*)

Example typing_example_2 :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using extend_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

(** **** Exercise: 2 stars, optional (typing_example_2_full) *)
(** Prove the same result without using [auto], [eauto], or
    [eapply]. *)

Example typing_example_2_full :
  empty |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (typing_example_3) *)
(** Formally prove the following typing derivation holds: *)
(**
   empty |- \x:Bool->B. \y:Bool->Bool. \z:Bool.
               y (x z)
         \in T.
*)

Example typing_example_3 :
  exists T,
    empty |-
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z)))))) \in
      T.
Proof with auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** We can also show that terms are _not_ typable.  For example, let's
    formally check that there is no typing derivation assigning a type
    to the term [\x:Bool. \y:Bool, x y] -- i.e.,
    ~ exists T,
        empty |- \x:Bool. \y:Bool, x y : T.
*)

Example typing_nonexample_1 :
  ~ exists T,
      empty |-
        (tabs x TBool
            (tabs y TBool
               (tapp (tvar x) (tvar y)))) \in
        T.
Proof.
  intros Hc. inversion Hc.
  (* The [clear] tactic is useful here for tidying away bits of
     the context that we're not going to need again. *)
  inversion H. subst. clear H.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  (* rewrite extend_neq in H1. rewrite extend_eq in H1. *)
  inversion H1.  Qed.

(** **** Exercise: 3 stars, optional (typing_nonexample_3) *)
(** Another nonexample:
    ~ (exists S, exists T,
          empty |- \x:S. x x : T).
*)

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        empty |-
          (tabs x S
             (tapp (tvar x) (tvar x))) \in
          T).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

End STLC.

(* $Date: 2013-11-20 13:03:49 -0500 (Wed, 20 Nov 2013) $ *)


Require Import Misc.
Require Export Monads.
Require Import Strategy.
Require Import List.
Import ListNotations.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section utils.

Variable A B C : Type.

Definition instr (T : monadType) (f : A -> T B)
  : A -> (StateT (list (A * B)) T) B
  := fun a l =>
       tbind (f a) (fun b => tval _ (b, (l ++ [(a,b)]))).

Fixpoint deps (t : Tree A B C) (f : A -> B) : list (A * B) :=
  match t with
    | Ans _ => nil
    | Que x k => let d := f x in (x, d) :: deps (k d) f
  end.

Definition deps_1 (t : Tree A B C) (f : A -> B) : list (A * B) :=
  let f' : A -> State (list (A * B)) B := @instr Id f in
    snd ([[t]] _ f' []).

Lemma deps_1_app (t : Tree A B C) (f : A -> B)
                 (l : list (A * B)) :
  let f' : A -> State (list (A * B)) B := @instr Id f in
    snd ([[t]] (State (list (A * B))) f' l) =
    l ++ snd ([[t]] (State (list (A * B))) f' []).
Proof.
intros f'.
revert l.
induction t as [| a k IHt].
- simpl. intros l; now rewrite app_nil_r.
- intros l. simpl.
  rewrite IHt. rewrite <- app_assoc. now rewrite <- IHt.
Qed.

Lemma deps_are_same t f : deps t f = deps_1 t f.
Proof.
induction t as [| a k IHt].
- now unfold deps_1.
- simpl. unfold deps_1; simpl.
  rewrite deps_1_app; simpl.
  now rewrite IHt.
Qed.

Definition valid (f : A -> B) (path : list (A * B)) :=
  forall p, In p path -> let (a, b) := p in b = f a.

Fixpoint legal (t : Tree A B C) (path : list (A * B)) :=
  match t, path with
    | _, nil => True
    | Ans _, _ :: _ => False
    | Que x k, (a, b) :: ps => a = x /\ legal (k b) ps
  end.

Fixpoint subtree (t : Tree A B C) (path : list (A * B)) :=
  match t, path with
    | _, nil => t
    | Ans _, _ => t
    | Que x k, (_, b) :: ps => subtree (k b) ps
  end.

Lemma subtree_nil t : subtree t [] = t.
Proof. now destruct t. Qed.
Hint Resolve subtree_nil.

Lemma subtree_nil_eq t t' :
  subtree t [] = t' -> t = t'.
Proof. now rewrite subtree_nil. Qed.

Lemma subtree_cons t l1 l2 :
  subtree t (l1 ++ l2) = subtree (subtree t l1) l2.
Proof.
revert t l2.
induction l1 as [| [a b] l IH].
- intros t l2. now rewrite app_nil_l, subtree_nil.
- intros t l2.
  rewrite <- app_comm_cons.
  destruct t as [c | a0 t].
  + simpl. now destruct l2.
  + simpl. now rewrite IH.
Qed.

Lemma subtree_step t l x k v :
  subtree t l = Que x k ->
  subtree t (l ++ [(x, v)]) = k v.
Proof.
revert t.
induction l as [| [a b] ps IH].
- intros t e.
  rewrite app_nil_l.
  now rewrite (subtree_nil_eq e); simpl.
- intros t Hsub.
  rewrite subtree_cons, Hsub.
  simpl.
  now rewrite subtree_nil.
Qed.

Lemma subtree_Que x k l c :
  subtree (Que x k) l = Ans c ->
  exists p ps, l = p :: ps.
Proof.
intro H. destruct l as [| p ps]; eauto.
now elim (subtree_nil_eq H).
Qed.

Lemma valid_nil f : valid f nil.
Proof. now firstorder. Qed.
Hint Resolve valid_nil.

Lemma valid_cons_elim f p l :
  valid f (p :: l) -> valid f l.
Proof. now firstorder. Qed.

Lemma valid_cons f a l :
  valid f l -> valid f ((a, f a) :: l).
Proof.
intro H. intros p H1. now inversion H1; subst; firstorder.
Qed.
Hint Resolve valid_cons.

Lemma valid_compat f1 f2 l :
  (forall p, In p l -> f1 (fst p) = f2 (fst p)) ->
  valid f1 l -> valid f2 l.
Proof.
intros Hcomp.
induction l as [| [a b] l IH]; auto.
- intros Hval [x y] H.
  assert (Ex : f1 x = f2 x) by firstorder. rewrite <- Ex; clear Ex.
  case (in_inv H) as [e | i].
  + inversion e; subst; now firstorder.
  + now firstorder.
Qed.

Lemma legal_Ans l c : legal (Ans c) l -> l = nil.
Proof. destruct l; now firstorder. Qed.

Lemma legal_nil t : legal t nil.
Proof. case t; now firstorder. Qed.
Hint Resolve legal_nil.

Lemma legal_cons_elim t p l :
  legal t (p :: l) -> exists f, t = Que (fst p) f.
Proof.
intro H. destruct t as [| x k].
- now firstorder.
- exists k. f_equal. destruct p as [a b]. now firstorder.
Qed.

Lemma legal_step t l x k v :
  legal t l ->
  subtree t l = Que x k ->
  legal t (l ++ [(x,v)]).
Proof.
revert t.
induction l as [| [a b] ps IH].
- intros t _ e.
  rewrite app_nil_l.
  now rewrite (subtree_nil_eq e); simpl; auto.
- intros t Hleg Hsub.
  rewrite <- app_comm_cons.
  elim (legal_cons_elim Hleg); intros k1 e.
  simpl in e; subst t.
  now firstorder.
Qed.

Lemma deps_valid t f : valid f (deps t f).
Proof.
induction t as [| x k H]; now simpl; auto.
Qed.
Hint Resolve deps_valid.

Lemma deps_legal t f : legal t (deps t f).
Proof.
induction t as [| x k H]; now simpl; auto.
Qed.
Hint Resolve deps_legal.

Lemma deps_subtree t sigma :
  let c := [[t]]* sigma in
  subtree t (deps t sigma) = Ans c.
Proof.
intro c. induction t as [| x k H]; now firstorder.
Qed.
Hint Resolve deps_subtree.

Lemma deps_val t f :
  forall p, In p (deps t f) -> snd p = f (fst p).
Proof.
induction t; now firstorder; subst.
Qed.

Lemma deps_split_val t f ps :
  ps = deps t f ->
  forall x, In x (fst (split ps)) -> In (x, f x) ps.
Proof.
revert t.
induction ps as [| [pa pb] ps IH].
- now intuition.
- intros t; case t as [c | a k].
  + now intuition.
  + simpl. intros H x Hin.
    destruct (split ps) as [ps1 ps2] eqn:Eps.
    inversion H; subst; clear H. simpl in *.
    destruct Hin; now intuition; eauto.
Qed.

Lemma deps_compat t l f1 f2 :
  l = deps t f1 ->
  (forall p, In p l -> f1 (fst p) = f2 (fst p)) ->
  deps t f1 = deps t f2.
Proof.
revert l.
induction t as [| a k IH ]; auto.
- intros l H H0. subst l. simpl.
  assert (e : f1 a = f2 a)
    by (apply (H0 (a, f1 a)); firstorder).
  rewrite <- e; clear e.
  f_equal. eapply IH; eauto. now firstorder.
Qed.

Lemma valid_app f l1 l2 :
  valid f l1 -> valid f l2 -> valid f (l1 ++ l2).
Proof.
intros H1 H2. intros p H.
apply in_app_or in H. now case H; firstorder.
Qed.

Lemma legal_app t t1 l1 l2 :
  legal t l1 ->
  subtree t l1 = t1 ->
  legal t1 l2 ->
  legal t (l1 ++ l2).
Proof.
revert t t1 l2.
induction l1 as [| [a b] l1 IH1]; simpl.
- intros t t1 l2 _ e. rewrite subtree_nil in e. now inversion e.
- intros t t1 l2 H1 H2 H3.
  elim (legal_cons_elim H1). intros k e1; subst.
  simpl in *. split; auto. destruct H1 as [_ H1].
  now eapply IH1; eauto.
Qed.

Lemma subtree_app t t1 t2 l1 l2 :
  subtree t l1 = t1 ->
  subtree t1 l2 = t2 ->
  subtree t (l1 ++ l2) = t2.
Proof.
revert t t1 t2 l2.
induction l1 as [| [a b] l1 IH1]; simpl.
- intros t t1 t2 l2 e. now rewrite (subtree_nil_eq e).
- intros t t1 t2 l2 H1 H2.
  rewrite app_comm_cons.
  now rewrite subtree_cons, H1.
Qed.

Lemma valid_legal_subtree_Ans t l sigma c :
  valid sigma l ->
  legal t l ->
  subtree t l = Ans c ->
  l = deps t sigma /\ c = [[t]]* sigma.
Proof.
revert t. induction l as [| [a b] ps IH].
- intros t Hval Hleg Hsub.
  now rewrite (subtree_nil_eq Hsub).
- intros t Hval Hleg Hsub.
  destruct (legal_cons_elim Hleg) as [k ?]; subst t.
  simpl in Hsub, Hleg. destruct Hleg as [_ Hleg].
  assert (e : b = sigma a) by (rewrite (Hval (a, b)); intuition).
  subst b. simpl. split.
  + f_equal. now apply IH; firstorder.
  + rewrite evaltree_Que. now apply IH; firstorder.
Qed.

Lemma deps_val_compat t l f1 f2 :
  l = deps t f1 ->
  (forall p, In p l -> f1 (fst p) = f2 (fst p)) ->
  [[t]]* f1 = [[t]]* f2.
Proof.
intros.
assert (Hdeps : deps t f1 = deps t f2)
  by (eapply deps_compat; eauto).
assert (Hf1 := deps_subtree t f1); simpl in Hf1.
assert (Hf2 := deps_subtree t f2); simpl in Hf2.
rewrite <- Hdeps, Hf1 in Hf2.
now inversion Hf2.
Qed.

(* unique lookup trees *)
Definition uniq_lookup t :=
  forall ps, legal t ps -> NoDup (fst (split ps)).

Lemma uniq_lookup_Que a k b :
  uniq_lookup (Que a k) -> uniq_lookup (k b).
Proof.
intros H ps Hleg.
red in H.
specialize H with ((a,b) :: ps).
assert (H0 :  NoDup (fst (split ((a, b) :: ps))))
  by firstorder.
clear - H0.
destruct (split ps) as [ps1 ps2] eqn:Hps.
simpl in *; rewrite Hps in H0; simpl in *.
now apply NoDup_remove_1 with (l:=[]) (a:=a).
Qed.
Hint Resolve uniq_lookup_Que.

Lemma uniq_Que_deps a k b f x y :
  uniq_lookup (Que a k) ->
  In (x,y) (deps (k b) f) ->
  x <> a.
Proof.
set (ps := deps (k b) f).
intros Huniq Hin e. simpl in e. subst x.
red in Huniq.
specialize Huniq with ((a,b) :: ps).
assert (Habs : NoDup (fst (split ((a,b) :: ps))))
  by (apply Huniq; simpl; now unfold ps; auto).
clear - Habs Hin.
apply in_split_l in Hin; simpl in Hin.
destruct (split ps) as [ps1 ps2] eqn:Hps.
simpl in *; rewrite Hps in Habs; simpl in *.
now apply NoDup_remove_2 with (l:=[]) (a:=a) in Habs.
Qed.

Lemma uniq_deps_f
        (Hdec : forall x y : A, {x = y} + {x <> y})
        t c f ps :
  uniq_lookup t ->
  legal t ps ->
  subtree t ps = Ans c ->
  exists f',
    deps t f' = ps /\
    valid f' ps /\
    let vs := fst (split ps) in
      forall x, ~ In x vs -> f x = f' x.
Proof.
revert t.
induction ps as [| [a b] ps IH].
- intros t Huniq Hleg Hsub.
  rewrite (subtree_nil_eq Hsub); clear dependent t.
  now exists f; auto.
- intros t Huniq Hleg Hsub.
  destruct (legal_cons_elim Hleg) as [k ?]; subst.
  specialize IH with (k b).
  assert (Huniq1 : uniq_lookup (k b)) by eauto.
  simpl in Hleg. destruct Hleg as [_ Hleg].
  simpl in Hsub.
  destruct IH as [f0 H]; auto.
  destruct H as [Hdepsf0 [Hvalf0 Hf0] ].
  pose (f1 := fun y => if Hdec y a then b else f0 y).
  assert (ea : f1 a = b)
    by (unfold f1; case Hdec; intuition).
  exists f1.
  split; [| split].
  + simpl. rewrite ea. f_equal.
    rewrite <- Hdepsf0. symmetry.
    apply deps_compat with (l:=ps); auto.
    intros [pa pb] Hp. simpl.
    rewrite <- Hdepsf0 in Hp.
    assert (ne : pa <> a)
      by (eapply uniq_Que_deps; eauto).
    now unfold f1; case Hdec; intuition.
  + rewrite <- ea. apply valid_cons.
    apply valid_compat with (f1:=f0); auto.
    intros [pa pb] Hp. simpl.
    rewrite <- Hdepsf0 in Hp.
    assert (ne : pa <> a)
      by (eapply uniq_Que_deps; eauto).
    now unfold f1; case Hdec; intuition.
  + simpl.
    destruct (split ps) as [ps1 ps2] eqn:Hps.
    simpl in *.
    intros x Hx.
    case (Hdec x a); [now intuition |].
    case (in_dec Hdec x ps1); [now intuition |].
    intros Hnin ne.
    rewrite Hf0; auto.
    now unfold f1; case Hdec; intuition.
Qed.

End utils.


Require Export XR_Rplus_comm.
Require Export XR_Rplus_lt_reg_l.

Local Open Scope R_scope.

Lemma Rplus_lt_reg_r : forall r r1 r2,
  r1 + r < r2 + r -> r1 < r2.
Proof.
  intros x y z h.
  apply Rplus_lt_reg_l with x.
  repeat rewrite (Rplus_comm x).
  exact h.
Qed.