Require Import Coq.Arith.Wf_nat.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.

Require Export Metalib.Metatheory.
Require Export Metalib.LibLNgen.

Require Export syntax_ott.

(** NOTE: Auxiliary theorems are hidden in generated documentation.
    In general, there is a [_rec] version of every lemma involving
    [open] and [close]. *)

(* *********************************************************************** *)
(** * Induction principles for nonterminals *)

Scheme dexp_ind' := Induction for dexp Sort Prop.

Definition dexp_mutind :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 H13 =>
  dexp_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 H13.

Scheme dexp_rec' := Induction for dexp Sort Set.

Definition dexp_mutrec :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 H13 =>
  dexp_rec' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 H13.

(* *********************************************************************** *)
(** * Close *)

Fixpoint close_dexp_wrt_dexp_rec (n1 : nat) (x1 : var) (ee1 : dexp) {struct ee1} : dexp :=
  match ee1 with
    | de_var_f x2 => if (x1 == x2) then (de_var_b n1) else (de_var_f x2)
    | de_var_b n2 => if (lt_ge_dec n2 n1) then (de_var_b n2) else (de_var_b (S n2))
    | de_top => de_top
    | de_lit i1 => de_lit i1
    | de_abs ee2 => de_abs (close_dexp_wrt_dexp_rec (S n1) x1 ee2)
    | de_app ee2 ee3 => de_app (close_dexp_wrt_dexp_rec n1 x1 ee2) (close_dexp_wrt_dexp_rec n1 x1 ee3)
    | de_merge ee2 ee3 => de_merge (close_dexp_wrt_dexp_rec n1 x1 ee2) (close_dexp_wrt_dexp_rec n1 x1 ee3)
    | de_pair ee2 ee3 => de_pair (close_dexp_wrt_dexp_rec n1 x1 ee2) (close_dexp_wrt_dexp_rec n1 x1 ee3)
    | de_projl ee2 => de_projl (close_dexp_wrt_dexp_rec n1 x1 ee2)
    | de_projr ee2 => de_projr (close_dexp_wrt_dexp_rec n1 x1 ee2)
    | de_ann ee2 A => de_ann (close_dexp_wrt_dexp_rec n1 x1 ee2) A
    | de_fixpoint ee2 => de_fixpoint (close_dexp_wrt_dexp_rec (S n1) x1 ee2)
  end.

Definition close_dexp_wrt_dexp x1 ee1 := close_dexp_wrt_dexp_rec 0 x1 ee1.

(* *********************************************************************** *)
(** * Size *)

Fixpoint size_dexp (ee1 : dexp) {struct ee1} : nat :=
  match ee1 with
    | de_var_f x1 => 1
    | de_var_b n1 => 1
    | de_top => 1
    | de_lit i1 => 1
    | de_abs ee2 => 1 + (size_dexp ee2)
    | de_app ee2 ee3 => 1 + (size_dexp ee2) + (size_dexp ee3)
    | de_merge ee2 ee3 => 1 + (size_dexp ee2) + (size_dexp ee3)
    | de_pair ee2 ee3 => 1 + (size_dexp ee2) + (size_dexp ee3)
    | de_projl ee2 => 1 + (size_dexp ee2)
    | de_projr ee2 => 1 + (size_dexp ee2)
    | de_ann ee2 _ => 1 + (size_dexp ee2)
    | de_fixpoint ee2 => 1 + (size_dexp ee2)
  end.

(* *********************************************************************** *)
(** * Degree *)

(** These define only an upper bound, not a strict upper bound. *)

Inductive degree_dexp_wrt_dexp : nat -> dexp -> Prop :=
  | degree_wrt_dexp_de_var_f : forall n1 x1,
    degree_dexp_wrt_dexp n1 (de_var_f x1)
  | degree_wrt_dexp_de_var_b : forall n1 n2,
    lt n2 n1 ->
    degree_dexp_wrt_dexp n1 (de_var_b n2)
  | degree_wrt_dexp_de_top : forall n1,
    degree_dexp_wrt_dexp n1 (de_top)
  | degree_wrt_dexp_de_lit : forall n1 i1,
    degree_dexp_wrt_dexp n1 (de_lit i1)
  | degree_wrt_dexp_de_abs : forall n1 ee1,
    degree_dexp_wrt_dexp (S n1) ee1 ->
    degree_dexp_wrt_dexp n1 (de_abs ee1)
  | degree_wrt_dexp_de_app : forall n1 ee1 ee2,
    degree_dexp_wrt_dexp n1 ee1 ->
    degree_dexp_wrt_dexp n1 ee2 ->
    degree_dexp_wrt_dexp n1 (de_app ee1 ee2)
  | degree_wrt_dexp_de_merge : forall n1 ee1 ee2,
    degree_dexp_wrt_dexp n1 ee1 ->
    degree_dexp_wrt_dexp n1 ee2 ->
    degree_dexp_wrt_dexp n1 (de_merge ee1 ee2)
  | degree_wrt_dexp_de_pair : forall n1 ee1 ee2,
    degree_dexp_wrt_dexp n1 ee1 ->
    degree_dexp_wrt_dexp n1 ee2 ->
    degree_dexp_wrt_dexp n1 (de_pair ee1 ee2)
  | degree_wrt_dexp_de_projl : forall n1 ee1,
    degree_dexp_wrt_dexp n1 ee1 ->
    degree_dexp_wrt_dexp n1 (de_projl ee1)
  | degree_wrt_dexp_de_projr : forall n1 ee1,
    degree_dexp_wrt_dexp n1 ee1 ->
    degree_dexp_wrt_dexp n1 (de_projr ee1)
  | degree_wrt_dexp_de_ann : forall n1 ee1 A,
    degree_dexp_wrt_dexp n1 ee1 ->
    degree_dexp_wrt_dexp n1 (de_ann ee1 A)
  | degree_wrt_dexp_de_fixpoint : forall n1 ee1,
    degree_dexp_wrt_dexp (S n1) ee1 ->
    degree_dexp_wrt_dexp n1 (de_fixpoint ee1).

Scheme degree_dexp_wrt_dexp_ind' := Induction for degree_dexp_wrt_dexp Sort Prop.

Definition degree_dexp_wrt_dexp_mutind :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 H13 =>
  degree_dexp_wrt_dexp_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 H13.

Hint Constructors degree_dexp_wrt_dexp : core lngen.

(* *********************************************************************** *)
(** * Local closure (version in [Set], induction principles) *)

Inductive lc_set_dexp : dexp -> Set :=
  | lc_set_de_var_f : forall x1,
    lc_set_dexp (de_var_f x1)
  | lc_set_de_top :
    lc_set_dexp (de_top)
  | lc_set_de_lit : forall i1,
    lc_set_dexp (de_lit i1)
  | lc_set_de_abs : forall ee1,
    (forall x1 : var, lc_set_dexp (open_dexp_wrt_dexp ee1 (de_var_f x1))) ->
    lc_set_dexp (de_abs ee1)
  | lc_set_de_app : forall ee1 ee2,
    lc_set_dexp ee1 ->
    lc_set_dexp ee2 ->
    lc_set_dexp (de_app ee1 ee2)
  | lc_set_de_merge : forall ee1 ee2,
    lc_set_dexp ee1 ->
    lc_set_dexp ee2 ->
    lc_set_dexp (de_merge ee1 ee2)
  | lc_set_de_pair : forall ee1 ee2,
    lc_set_dexp ee1 ->
    lc_set_dexp ee2 ->
    lc_set_dexp (de_pair ee1 ee2)
  | lc_set_de_projl : forall ee1,
    lc_set_dexp ee1 ->
    lc_set_dexp (de_projl ee1)
  | lc_set_de_projr : forall ee1,
    lc_set_dexp ee1 ->
    lc_set_dexp (de_projr ee1)
  | lc_set_de_ann : forall ee1 A,
    lc_set_dexp ee1 ->
    lc_set_dexp (de_ann ee1 A)
  | lc_set_de_fixpoint : forall ee1,
    (forall x1 : var, lc_set_dexp (open_dexp_wrt_dexp ee1 (de_var_f x1))) ->
    lc_set_dexp (de_fixpoint ee1).

Scheme lc_dexp_ind' := Induction for lc_dexp Sort Prop.

Definition lc_dexp_mutind :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 =>
  lc_dexp_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12.

Scheme lc_set_dexp_ind' := Induction for lc_set_dexp Sort Prop.

Definition lc_set_dexp_mutind :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 =>
  lc_set_dexp_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12.

Scheme lc_set_dexp_rec' := Induction for lc_set_dexp Sort Set.

Definition lc_set_dexp_mutrec :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 =>
  lc_set_dexp_rec' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12.

Hint Constructors lc_dexp : core lngen.

Hint Constructors lc_set_dexp : core lngen.

(* *********************************************************************** *)
(** * Body *)

Definition body_dexp_wrt_dexp ee1 := forall x1, lc_dexp (open_dexp_wrt_dexp ee1 (de_var_f x1)).

Hint Unfold body_dexp_wrt_dexp : core.

(* *********************************************************************** *)
(** * Tactic support *)

(** Additional hint declarations. *)

Hint Resolve @plus_le_compat : lngen.

(** Redefine some tactics. *)

Ltac default_case_split ::=
  first
    [ progress destruct_notin
    | progress destruct_sum
    | progress safe_f_equal
    ].

(* *********************************************************************** *)
(** * Theorems about [size] *)

Ltac default_auto ::= auto with arith lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma size_dexp_min_mutual :
(forall ee1, 1 <= size_dexp ee1).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma size_dexp_min :
forall ee1, 1 <= size_dexp ee1.
Proof.
pose proof size_dexp_min_mutual as H; intuition eauto.
Qed.

Hint Resolve size_dexp_min : lngen.

(* begin hide *)

Lemma size_dexp_close_dexp_wrt_dexp_rec_mutual :
(forall ee1 x1 n1,
  size_dexp (close_dexp_wrt_dexp_rec n1 x1 ee1) = size_dexp ee1).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_dexp_close_dexp_wrt_dexp_rec :
forall ee1 x1 n1,
  size_dexp (close_dexp_wrt_dexp_rec n1 x1 ee1) = size_dexp ee1.
Proof.
pose proof size_dexp_close_dexp_wrt_dexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve size_dexp_close_dexp_wrt_dexp_rec : lngen.
Hint Rewrite size_dexp_close_dexp_wrt_dexp_rec using solve [auto] : lngen.

(* end hide *)

Lemma size_dexp_close_dexp_wrt_dexp :
forall ee1 x1,
  size_dexp (close_dexp_wrt_dexp x1 ee1) = size_dexp ee1.
Proof.
unfold close_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve size_dexp_close_dexp_wrt_dexp : lngen.
Hint Rewrite size_dexp_close_dexp_wrt_dexp using solve [auto] : lngen.

(* begin hide *)

Lemma size_dexp_open_dexp_wrt_dexp_rec_mutual :
(forall ee1 ee2 n1,
  size_dexp ee1 <= size_dexp (open_dexp_wrt_dexp_rec n1 ee2 ee1)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_dexp_open_dexp_wrt_dexp_rec :
forall ee1 ee2 n1,
  size_dexp ee1 <= size_dexp (open_dexp_wrt_dexp_rec n1 ee2 ee1).
Proof.
pose proof size_dexp_open_dexp_wrt_dexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve size_dexp_open_dexp_wrt_dexp_rec : lngen.

(* end hide *)

Lemma size_dexp_open_dexp_wrt_dexp :
forall ee1 ee2,
  size_dexp ee1 <= size_dexp (open_dexp_wrt_dexp ee1 ee2).
Proof.
unfold open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve size_dexp_open_dexp_wrt_dexp : lngen.

(* begin hide *)

Lemma size_dexp_open_dexp_wrt_dexp_rec_var_mutual :
(forall ee1 x1 n1,
  size_dexp (open_dexp_wrt_dexp_rec n1 (de_var_f x1) ee1) = size_dexp ee1).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_dexp_open_dexp_wrt_dexp_rec_var :
forall ee1 x1 n1,
  size_dexp (open_dexp_wrt_dexp_rec n1 (de_var_f x1) ee1) = size_dexp ee1.
Proof.
pose proof size_dexp_open_dexp_wrt_dexp_rec_var_mutual as H; intuition eauto.
Qed.

Hint Resolve size_dexp_open_dexp_wrt_dexp_rec_var : lngen.
Hint Rewrite size_dexp_open_dexp_wrt_dexp_rec_var using solve [auto] : lngen.

(* end hide *)

Lemma size_dexp_open_dexp_wrt_dexp_var :
forall ee1 x1,
  size_dexp (open_dexp_wrt_dexp ee1 (de_var_f x1)) = size_dexp ee1.
Proof.
unfold open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve size_dexp_open_dexp_wrt_dexp_var : lngen.
Hint Rewrite size_dexp_open_dexp_wrt_dexp_var using solve [auto] : lngen.

(* *********************************************************************** *)
(** * Theorems about [degree] *)

Ltac default_auto ::= auto with lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma degree_dexp_wrt_dexp_S_mutual :
(forall n1 ee1,
  degree_dexp_wrt_dexp n1 ee1 ->
  degree_dexp_wrt_dexp (S n1) ee1).
Proof.
apply_mutual_ind degree_dexp_wrt_dexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma degree_dexp_wrt_dexp_S :
forall n1 ee1,
  degree_dexp_wrt_dexp n1 ee1 ->
  degree_dexp_wrt_dexp (S n1) ee1.
Proof.
pose proof degree_dexp_wrt_dexp_S_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_dexp_wrt_dexp_S : lngen.

Lemma degree_dexp_wrt_dexp_O :
forall n1 ee1,
  degree_dexp_wrt_dexp O ee1 ->
  degree_dexp_wrt_dexp n1 ee1.
Proof.
induction n1; default_simp.
Qed.

Hint Resolve degree_dexp_wrt_dexp_O : lngen.

(* begin hide *)

Lemma degree_dexp_wrt_dexp_close_dexp_wrt_dexp_rec_mutual :
(forall ee1 x1 n1,
  degree_dexp_wrt_dexp n1 ee1 ->
  degree_dexp_wrt_dexp (S n1) (close_dexp_wrt_dexp_rec n1 x1 ee1)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_dexp_wrt_dexp_close_dexp_wrt_dexp_rec :
forall ee1 x1 n1,
  degree_dexp_wrt_dexp n1 ee1 ->
  degree_dexp_wrt_dexp (S n1) (close_dexp_wrt_dexp_rec n1 x1 ee1).
Proof.
pose proof degree_dexp_wrt_dexp_close_dexp_wrt_dexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_dexp_wrt_dexp_close_dexp_wrt_dexp_rec : lngen.

(* end hide *)

Lemma degree_dexp_wrt_dexp_close_dexp_wrt_dexp :
forall ee1 x1,
  degree_dexp_wrt_dexp 0 ee1 ->
  degree_dexp_wrt_dexp 1 (close_dexp_wrt_dexp x1 ee1).
Proof.
unfold close_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve degree_dexp_wrt_dexp_close_dexp_wrt_dexp : lngen.

(* begin hide *)

Lemma degree_dexp_wrt_dexp_close_dexp_wrt_dexp_rec_inv_mutual :
(forall ee1 x1 n1,
  degree_dexp_wrt_dexp (S n1) (close_dexp_wrt_dexp_rec n1 x1 ee1) ->
  degree_dexp_wrt_dexp n1 ee1).
Proof.
apply_mutual_ind dexp_mutind;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_dexp_wrt_dexp_close_dexp_wrt_dexp_rec_inv :
forall ee1 x1 n1,
  degree_dexp_wrt_dexp (S n1) (close_dexp_wrt_dexp_rec n1 x1 ee1) ->
  degree_dexp_wrt_dexp n1 ee1.
Proof.
pose proof degree_dexp_wrt_dexp_close_dexp_wrt_dexp_rec_inv_mutual as H; intuition eauto.
Qed.

Hint Immediate degree_dexp_wrt_dexp_close_dexp_wrt_dexp_rec_inv : lngen.

(* end hide *)

Lemma degree_dexp_wrt_dexp_close_dexp_wrt_dexp_inv :
forall ee1 x1,
  degree_dexp_wrt_dexp 1 (close_dexp_wrt_dexp x1 ee1) ->
  degree_dexp_wrt_dexp 0 ee1.
Proof.
unfold close_dexp_wrt_dexp; eauto with lngen.
Qed.

Hint Immediate degree_dexp_wrt_dexp_close_dexp_wrt_dexp_inv : lngen.

(* begin hide *)

Lemma degree_dexp_wrt_dexp_open_dexp_wrt_dexp_rec_mutual :
(forall ee1 ee2 n1,
  degree_dexp_wrt_dexp (S n1) ee1 ->
  degree_dexp_wrt_dexp n1 ee2 ->
  degree_dexp_wrt_dexp n1 (open_dexp_wrt_dexp_rec n1 ee2 ee1)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_dexp_wrt_dexp_open_dexp_wrt_dexp_rec :
forall ee1 ee2 n1,
  degree_dexp_wrt_dexp (S n1) ee1 ->
  degree_dexp_wrt_dexp n1 ee2 ->
  degree_dexp_wrt_dexp n1 (open_dexp_wrt_dexp_rec n1 ee2 ee1).
Proof.
pose proof degree_dexp_wrt_dexp_open_dexp_wrt_dexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_dexp_wrt_dexp_open_dexp_wrt_dexp_rec : lngen.

(* end hide *)

Lemma degree_dexp_wrt_dexp_open_dexp_wrt_dexp :
forall ee1 ee2,
  degree_dexp_wrt_dexp 1 ee1 ->
  degree_dexp_wrt_dexp 0 ee2 ->
  degree_dexp_wrt_dexp 0 (open_dexp_wrt_dexp ee1 ee2).
Proof.
unfold open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve degree_dexp_wrt_dexp_open_dexp_wrt_dexp : lngen.

(* begin hide *)

Lemma degree_dexp_wrt_dexp_open_dexp_wrt_dexp_rec_inv_mutual :
(forall ee1 ee2 n1,
  degree_dexp_wrt_dexp n1 (open_dexp_wrt_dexp_rec n1 ee2 ee1) ->
  degree_dexp_wrt_dexp (S n1) ee1).
Proof.
apply_mutual_ind dexp_mutind;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_dexp_wrt_dexp_open_dexp_wrt_dexp_rec_inv :
forall ee1 ee2 n1,
  degree_dexp_wrt_dexp n1 (open_dexp_wrt_dexp_rec n1 ee2 ee1) ->
  degree_dexp_wrt_dexp (S n1) ee1.
Proof.
pose proof degree_dexp_wrt_dexp_open_dexp_wrt_dexp_rec_inv_mutual as H; intuition eauto.
Qed.

Hint Immediate degree_dexp_wrt_dexp_open_dexp_wrt_dexp_rec_inv : lngen.

(* end hide *)

Lemma degree_dexp_wrt_dexp_open_dexp_wrt_dexp_inv :
forall ee1 ee2,
  degree_dexp_wrt_dexp 0 (open_dexp_wrt_dexp ee1 ee2) ->
  degree_dexp_wrt_dexp 1 ee1.
Proof.
unfold open_dexp_wrt_dexp; eauto with lngen.
Qed.

Hint Immediate degree_dexp_wrt_dexp_open_dexp_wrt_dexp_inv : lngen.

(* *********************************************************************** *)
(** * Theorems about [open] and [close] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma close_dexp_wrt_dexp_rec_inj_mutual :
(forall ee1 ee2 x1 n1,
  close_dexp_wrt_dexp_rec n1 x1 ee1 = close_dexp_wrt_dexp_rec n1 x1 ee2 ->
  ee1 = ee2).
Proof.
apply_mutual_ind dexp_mutind;
intros; match goal with
          | |- _ = ?term => destruct term
        end;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_dexp_wrt_dexp_rec_inj :
forall ee1 ee2 x1 n1,
  close_dexp_wrt_dexp_rec n1 x1 ee1 = close_dexp_wrt_dexp_rec n1 x1 ee2 ->
  ee1 = ee2.
Proof.
pose proof close_dexp_wrt_dexp_rec_inj_mutual as H; intuition eauto.
Qed.

Hint Immediate close_dexp_wrt_dexp_rec_inj : lngen.

(* end hide *)

Lemma close_dexp_wrt_dexp_inj :
forall ee1 ee2 x1,
  close_dexp_wrt_dexp x1 ee1 = close_dexp_wrt_dexp x1 ee2 ->
  ee1 = ee2.
Proof.
unfold close_dexp_wrt_dexp; eauto with lngen.
Qed.

Hint Immediate close_dexp_wrt_dexp_inj : lngen.

(* begin hide *)

Lemma close_dexp_wrt_dexp_rec_open_dexp_wrt_dexp_rec_mutual :
(forall ee1 x1 n1,
  x1 `notin` fv_dexp ee1 ->
  close_dexp_wrt_dexp_rec n1 x1 (open_dexp_wrt_dexp_rec n1 (de_var_f x1) ee1) = ee1).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_dexp_wrt_dexp_rec_open_dexp_wrt_dexp_rec :
forall ee1 x1 n1,
  x1 `notin` fv_dexp ee1 ->
  close_dexp_wrt_dexp_rec n1 x1 (open_dexp_wrt_dexp_rec n1 (de_var_f x1) ee1) = ee1.
Proof.
pose proof close_dexp_wrt_dexp_rec_open_dexp_wrt_dexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve close_dexp_wrt_dexp_rec_open_dexp_wrt_dexp_rec : lngen.
Hint Rewrite close_dexp_wrt_dexp_rec_open_dexp_wrt_dexp_rec using solve [auto] : lngen.

(* end hide *)

Lemma close_dexp_wrt_dexp_open_dexp_wrt_dexp :
forall ee1 x1,
  x1 `notin` fv_dexp ee1 ->
  close_dexp_wrt_dexp x1 (open_dexp_wrt_dexp ee1 (de_var_f x1)) = ee1.
Proof.
unfold close_dexp_wrt_dexp; unfold open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve close_dexp_wrt_dexp_open_dexp_wrt_dexp : lngen.
Hint Rewrite close_dexp_wrt_dexp_open_dexp_wrt_dexp using solve [auto] : lngen.

(* begin hide *)

Lemma open_dexp_wrt_dexp_rec_close_dexp_wrt_dexp_rec_mutual :
(forall ee1 x1 n1,
  open_dexp_wrt_dexp_rec n1 (de_var_f x1) (close_dexp_wrt_dexp_rec n1 x1 ee1) = ee1).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_dexp_wrt_dexp_rec_close_dexp_wrt_dexp_rec :
forall ee1 x1 n1,
  open_dexp_wrt_dexp_rec n1 (de_var_f x1) (close_dexp_wrt_dexp_rec n1 x1 ee1) = ee1.
Proof.
pose proof open_dexp_wrt_dexp_rec_close_dexp_wrt_dexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve open_dexp_wrt_dexp_rec_close_dexp_wrt_dexp_rec : lngen.
Hint Rewrite open_dexp_wrt_dexp_rec_close_dexp_wrt_dexp_rec using solve [auto] : lngen.

(* end hide *)

Lemma open_dexp_wrt_dexp_close_dexp_wrt_dexp :
forall ee1 x1,
  open_dexp_wrt_dexp (close_dexp_wrt_dexp x1 ee1) (de_var_f x1) = ee1.
Proof.
unfold close_dexp_wrt_dexp; unfold open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve open_dexp_wrt_dexp_close_dexp_wrt_dexp : lngen.
Hint Rewrite open_dexp_wrt_dexp_close_dexp_wrt_dexp using solve [auto] : lngen.

(* begin hide *)

Lemma open_dexp_wrt_dexp_rec_inj_mutual :
(forall ee2 ee1 x1 n1,
  x1 `notin` fv_dexp ee2 ->
  x1 `notin` fv_dexp ee1 ->
  open_dexp_wrt_dexp_rec n1 (de_var_f x1) ee2 = open_dexp_wrt_dexp_rec n1 (de_var_f x1) ee1 ->
  ee2 = ee1).
Proof.
apply_mutual_ind dexp_mutind;
intros; match goal with
          | |- _ = ?term => destruct term
        end;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_dexp_wrt_dexp_rec_inj :
forall ee2 ee1 x1 n1,
  x1 `notin` fv_dexp ee2 ->
  x1 `notin` fv_dexp ee1 ->
  open_dexp_wrt_dexp_rec n1 (de_var_f x1) ee2 = open_dexp_wrt_dexp_rec n1 (de_var_f x1) ee1 ->
  ee2 = ee1.
Proof.
pose proof open_dexp_wrt_dexp_rec_inj_mutual as H; intuition eauto.
Qed.

Hint Immediate open_dexp_wrt_dexp_rec_inj : lngen.

(* end hide *)

Lemma open_dexp_wrt_dexp_inj :
forall ee2 ee1 x1,
  x1 `notin` fv_dexp ee2 ->
  x1 `notin` fv_dexp ee1 ->
  open_dexp_wrt_dexp ee2 (de_var_f x1) = open_dexp_wrt_dexp ee1 (de_var_f x1) ->
  ee2 = ee1.
Proof.
unfold open_dexp_wrt_dexp; eauto with lngen.
Qed.

Hint Immediate open_dexp_wrt_dexp_inj : lngen.

(* *********************************************************************** *)
(** * Theorems about [lc] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma degree_dexp_wrt_dexp_of_lc_dexp_mutual :
(forall ee1,
  lc_dexp ee1 ->
  degree_dexp_wrt_dexp 0 ee1).
Proof.
apply_mutual_ind lc_dexp_mutind;
intros;
let x1 := fresh "x1" in pick_fresh x1;
repeat (match goal with
          | H1 : _, H2 : _ |- _ => specialize H1 with H2
        end);
default_simp; eauto with lngen.
Qed.

(* end hide *)

Lemma degree_dexp_wrt_dexp_of_lc_dexp :
forall ee1,
  lc_dexp ee1 ->
  degree_dexp_wrt_dexp 0 ee1.
Proof.
pose proof degree_dexp_wrt_dexp_of_lc_dexp_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_dexp_wrt_dexp_of_lc_dexp : lngen.

(* begin hide *)

Lemma lc_dexp_of_degree_size_mutual :
forall i1,
(forall ee1,
  size_dexp ee1 = i1 ->
  degree_dexp_wrt_dexp 0 ee1 ->
  lc_dexp ee1).
Proof.
intros i1; pattern i1; apply lt_wf_rec;
clear i1; intros i1 H1;
apply_mutual_ind dexp_mutind;
default_simp;
(* non-trivial cases *)
constructor; default_simp; eapply_first_lt_hyp;
(* instantiate the size *)
match goal with
  | |- _ = _ => reflexivity
  | _ => idtac
end;
instantiate;
(* everything should be easy now *)
default_simp.
Qed.

(* end hide *)

Lemma lc_dexp_of_degree :
forall ee1,
  degree_dexp_wrt_dexp 0 ee1 ->
  lc_dexp ee1.
Proof.
intros ee1; intros;
pose proof (lc_dexp_of_degree_size_mutual (size_dexp ee1));
intuition eauto.
Qed.

Hint Resolve lc_dexp_of_degree : lngen.

Ltac dexp_lc_exists_tac :=
  repeat (match goal with
            | H : _ |- _ =>
              let J1 := fresh in pose proof H as J1; apply degree_dexp_wrt_dexp_of_lc_dexp in J1; clear H
          end).

Lemma lc_de_abs_exists :
forall x1 ee1,
  lc_dexp (open_dexp_wrt_dexp ee1 (de_var_f x1)) ->
  lc_dexp (de_abs ee1).
Proof.
intros; dexp_lc_exists_tac; eauto with lngen.
Qed.

Lemma lc_de_fixpoint_exists :
forall x1 ee1,
  lc_dexp (open_dexp_wrt_dexp ee1 (de_var_f x1)) ->
  lc_dexp (de_fixpoint ee1).
Proof.
intros; dexp_lc_exists_tac; eauto with lngen.
Qed.

Hint Extern 1 (lc_dexp (de_abs _)) =>
  let x1 := fresh in
  pick_fresh x1;
  apply (lc_de_abs_exists x1) : core.

Hint Extern 1 (lc_dexp (de_fixpoint _)) =>
  let x1 := fresh in
  pick_fresh x1;
  apply (lc_de_fixpoint_exists x1) : core.

Lemma lc_body_dexp_wrt_dexp :
forall ee1 ee2,
  body_dexp_wrt_dexp ee1 ->
  lc_dexp ee2 ->
  lc_dexp (open_dexp_wrt_dexp ee1 ee2).
Proof.
unfold body_dexp_wrt_dexp;
default_simp;
let x1 := fresh "x" in
pick_fresh x1;
specialize_all x1;
dexp_lc_exists_tac;
eauto with lngen.
Qed.

Hint Resolve lc_body_dexp_wrt_dexp : lngen.

Lemma lc_body_de_abs_1 :
forall ee1,
  lc_dexp (de_abs ee1) ->
  body_dexp_wrt_dexp ee1.
Proof.
default_simp.
Qed.

Hint Resolve lc_body_de_abs_1 : lngen.

Lemma lc_body_de_fixpoint_1 :
forall ee1,
  lc_dexp (de_fixpoint ee1) ->
  body_dexp_wrt_dexp ee1.
Proof.
default_simp.
Qed.

Hint Resolve lc_body_de_fixpoint_1 : lngen.

(* begin hide *)

Lemma lc_dexp_unique_mutual :
(forall ee1 (proof2 proof3 : lc_dexp ee1), proof2 = proof3).
Proof.
apply_mutual_ind lc_dexp_mutind;
intros;
let proof1 := fresh "proof1" in
rename_last_into proof1; dependent destruction proof1;
f_equal; default_simp; auto using @functional_extensionality_dep with lngen.
Qed.

(* end hide *)

Lemma lc_dexp_unique :
forall ee1 (proof2 proof3 : lc_dexp ee1), proof2 = proof3.
Proof.
pose proof lc_dexp_unique_mutual as H; intuition eauto.
Qed.

Hint Resolve lc_dexp_unique : lngen.

(* begin hide *)

Lemma lc_dexp_of_lc_set_dexp_mutual :
(forall ee1, lc_set_dexp ee1 -> lc_dexp ee1).
Proof.
apply_mutual_ind lc_set_dexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma lc_dexp_of_lc_set_dexp :
forall ee1, lc_set_dexp ee1 -> lc_dexp ee1.
Proof.
pose proof lc_dexp_of_lc_set_dexp_mutual as H; intuition eauto.
Qed.

Hint Resolve lc_dexp_of_lc_set_dexp : lngen.

(* begin hide *)

Lemma lc_set_dexp_of_lc_dexp_size_mutual :
forall i1,
(forall ee1,
  size_dexp ee1 = i1 ->
  lc_dexp ee1 ->
  lc_set_dexp ee1).
Proof.
intros i1; pattern i1; apply lt_wf_rec;
clear i1; intros i1 H1;
apply_mutual_ind dexp_mutrec;
default_simp;
try solve [assert False by default_simp; tauto];
(* non-trivial cases *)
constructor; default_simp;
try first [apply lc_set_dexp_of_lc_dexp];
default_simp; eapply_first_lt_hyp;
(* instantiate the size *)
match goal with
  | |- _ = _ => reflexivity
  | _ => idtac
end;
instantiate;
(* everything should be easy now *)
default_simp.
Qed.

(* end hide *)

Lemma lc_set_dexp_of_lc_dexp :
forall ee1,
  lc_dexp ee1 ->
  lc_set_dexp ee1.
Proof.
intros ee1; intros;
pose proof (lc_set_dexp_of_lc_dexp_size_mutual (size_dexp ee1));
intuition eauto.
Qed.

Hint Resolve lc_set_dexp_of_lc_dexp : lngen.

(* *********************************************************************** *)
(** * More theorems about [open] and [close] *)

Ltac default_auto ::= auto with lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma close_dexp_wrt_dexp_rec_degree_dexp_wrt_dexp_mutual :
(forall ee1 x1 n1,
  degree_dexp_wrt_dexp n1 ee1 ->
  x1 `notin` fv_dexp ee1 ->
  close_dexp_wrt_dexp_rec n1 x1 ee1 = ee1).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_dexp_wrt_dexp_rec_degree_dexp_wrt_dexp :
forall ee1 x1 n1,
  degree_dexp_wrt_dexp n1 ee1 ->
  x1 `notin` fv_dexp ee1 ->
  close_dexp_wrt_dexp_rec n1 x1 ee1 = ee1.
Proof.
pose proof close_dexp_wrt_dexp_rec_degree_dexp_wrt_dexp_mutual as H; intuition eauto.
Qed.

Hint Resolve close_dexp_wrt_dexp_rec_degree_dexp_wrt_dexp : lngen.
Hint Rewrite close_dexp_wrt_dexp_rec_degree_dexp_wrt_dexp using solve [auto] : lngen.

(* end hide *)

Lemma close_dexp_wrt_dexp_lc_dexp :
forall ee1 x1,
  lc_dexp ee1 ->
  x1 `notin` fv_dexp ee1 ->
  close_dexp_wrt_dexp x1 ee1 = ee1.
Proof.
unfold close_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve close_dexp_wrt_dexp_lc_dexp : lngen.
Hint Rewrite close_dexp_wrt_dexp_lc_dexp using solve [auto] : lngen.

(* begin hide *)

Lemma open_dexp_wrt_dexp_rec_degree_dexp_wrt_dexp_mutual :
(forall ee2 ee1 n1,
  degree_dexp_wrt_dexp n1 ee2 ->
  open_dexp_wrt_dexp_rec n1 ee1 ee2 = ee2).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_dexp_wrt_dexp_rec_degree_dexp_wrt_dexp :
forall ee2 ee1 n1,
  degree_dexp_wrt_dexp n1 ee2 ->
  open_dexp_wrt_dexp_rec n1 ee1 ee2 = ee2.
Proof.
pose proof open_dexp_wrt_dexp_rec_degree_dexp_wrt_dexp_mutual as H; intuition eauto.
Qed.

Hint Resolve open_dexp_wrt_dexp_rec_degree_dexp_wrt_dexp : lngen.
Hint Rewrite open_dexp_wrt_dexp_rec_degree_dexp_wrt_dexp using solve [auto] : lngen.

(* end hide *)

Lemma open_dexp_wrt_dexp_lc_dexp :
forall ee2 ee1,
  lc_dexp ee2 ->
  open_dexp_wrt_dexp ee2 ee1 = ee2.
Proof.
unfold open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve open_dexp_wrt_dexp_lc_dexp : lngen.
Hint Rewrite open_dexp_wrt_dexp_lc_dexp using solve [auto] : lngen.

(* *********************************************************************** *)
(** * Theorems about [fv] *)

Ltac default_auto ::= auto with set lngen; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma fv_dexp_close_dexp_wrt_dexp_rec_mutual :
(forall ee1 x1 n1,
  fv_dexp (close_dexp_wrt_dexp_rec n1 x1 ee1) [=] remove x1 (fv_dexp ee1)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_dexp_close_dexp_wrt_dexp_rec :
forall ee1 x1 n1,
  fv_dexp (close_dexp_wrt_dexp_rec n1 x1 ee1) [=] remove x1 (fv_dexp ee1).
Proof.
pose proof fv_dexp_close_dexp_wrt_dexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_dexp_close_dexp_wrt_dexp_rec : lngen.
Hint Rewrite fv_dexp_close_dexp_wrt_dexp_rec using solve [auto] : lngen.

(* end hide *)

Lemma fv_dexp_close_dexp_wrt_dexp :
forall ee1 x1,
  fv_dexp (close_dexp_wrt_dexp x1 ee1) [=] remove x1 (fv_dexp ee1).
Proof.
unfold close_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve fv_dexp_close_dexp_wrt_dexp : lngen.
Hint Rewrite fv_dexp_close_dexp_wrt_dexp using solve [auto] : lngen.

(* begin hide *)

Lemma fv_dexp_open_dexp_wrt_dexp_rec_lower_mutual :
(forall ee1 ee2 n1,
  fv_dexp ee1 [<=] fv_dexp (open_dexp_wrt_dexp_rec n1 ee2 ee1)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_dexp_open_dexp_wrt_dexp_rec_lower :
forall ee1 ee2 n1,
  fv_dexp ee1 [<=] fv_dexp (open_dexp_wrt_dexp_rec n1 ee2 ee1).
Proof.
pose proof fv_dexp_open_dexp_wrt_dexp_rec_lower_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_dexp_open_dexp_wrt_dexp_rec_lower : lngen.

(* end hide *)

Lemma fv_dexp_open_dexp_wrt_dexp_lower :
forall ee1 ee2,
  fv_dexp ee1 [<=] fv_dexp (open_dexp_wrt_dexp ee1 ee2).
Proof.
unfold open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve fv_dexp_open_dexp_wrt_dexp_lower : lngen.

(* begin hide *)

Lemma fv_dexp_open_dexp_wrt_dexp_rec_upper_mutual :
(forall ee1 ee2 n1,
  fv_dexp (open_dexp_wrt_dexp_rec n1 ee2 ee1) [<=] fv_dexp ee2 `union` fv_dexp ee1).
Proof.
apply_mutual_ind dexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_dexp_open_dexp_wrt_dexp_rec_upper :
forall ee1 ee2 n1,
  fv_dexp (open_dexp_wrt_dexp_rec n1 ee2 ee1) [<=] fv_dexp ee2 `union` fv_dexp ee1.
Proof.
pose proof fv_dexp_open_dexp_wrt_dexp_rec_upper_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_dexp_open_dexp_wrt_dexp_rec_upper : lngen.

(* end hide *)

Lemma fv_dexp_open_dexp_wrt_dexp_upper :
forall ee1 ee2,
  fv_dexp (open_dexp_wrt_dexp ee1 ee2) [<=] fv_dexp ee2 `union` fv_dexp ee1.
Proof.
unfold open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve fv_dexp_open_dexp_wrt_dexp_upper : lngen.

(* begin hide *)

Lemma fv_dexp_subst_dexp_fresh_mutual :
(forall ee1 ee2 x1,
  x1 `notin` fv_dexp ee1 ->
  fv_dexp (subst_dexp ee2 x1 ee1) [=] fv_dexp ee1).
Proof.
apply_mutual_ind dexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_dexp_subst_dexp_fresh :
forall ee1 ee2 x1,
  x1 `notin` fv_dexp ee1 ->
  fv_dexp (subst_dexp ee2 x1 ee1) [=] fv_dexp ee1.
Proof.
pose proof fv_dexp_subst_dexp_fresh_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_dexp_subst_dexp_fresh : lngen.
Hint Rewrite fv_dexp_subst_dexp_fresh using solve [auto] : lngen.

(* begin hide *)

Lemma fv_dexp_subst_dexp_lower_mutual :
(forall ee1 ee2 x1,
  remove x1 (fv_dexp ee1) [<=] fv_dexp (subst_dexp ee2 x1 ee1)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_dexp_subst_dexp_lower :
forall ee1 ee2 x1,
  remove x1 (fv_dexp ee1) [<=] fv_dexp (subst_dexp ee2 x1 ee1).
Proof.
pose proof fv_dexp_subst_dexp_lower_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_dexp_subst_dexp_lower : lngen.

(* begin hide *)

Lemma fv_dexp_subst_dexp_notin_mutual :
(forall ee1 ee2 x1 x2,
  x2 `notin` fv_dexp ee1 ->
  x2 `notin` fv_dexp ee2 ->
  x2 `notin` fv_dexp (subst_dexp ee2 x1 ee1)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_dexp_subst_dexp_notin :
forall ee1 ee2 x1 x2,
  x2 `notin` fv_dexp ee1 ->
  x2 `notin` fv_dexp ee2 ->
  x2 `notin` fv_dexp (subst_dexp ee2 x1 ee1).
Proof.
pose proof fv_dexp_subst_dexp_notin_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_dexp_subst_dexp_notin : lngen.

(* begin hide *)

Lemma fv_dexp_subst_dexp_upper_mutual :
(forall ee1 ee2 x1,
  fv_dexp (subst_dexp ee2 x1 ee1) [<=] fv_dexp ee2 `union` remove x1 (fv_dexp ee1)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_dexp_subst_dexp_upper :
forall ee1 ee2 x1,
  fv_dexp (subst_dexp ee2 x1 ee1) [<=] fv_dexp ee2 `union` remove x1 (fv_dexp ee1).
Proof.
pose proof fv_dexp_subst_dexp_upper_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_dexp_subst_dexp_upper : lngen.

(* *********************************************************************** *)
(** * Theorems about [subst] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma subst_dexp_close_dexp_wrt_dexp_rec_mutual :
(forall ee2 ee1 x1 x2 n1,
  degree_dexp_wrt_dexp n1 ee1 ->
  x1 <> x2 ->
  x2 `notin` fv_dexp ee1 ->
  subst_dexp ee1 x1 (close_dexp_wrt_dexp_rec n1 x2 ee2) = close_dexp_wrt_dexp_rec n1 x2 (subst_dexp ee1 x1 ee2)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_dexp_close_dexp_wrt_dexp_rec :
forall ee2 ee1 x1 x2 n1,
  degree_dexp_wrt_dexp n1 ee1 ->
  x1 <> x2 ->
  x2 `notin` fv_dexp ee1 ->
  subst_dexp ee1 x1 (close_dexp_wrt_dexp_rec n1 x2 ee2) = close_dexp_wrt_dexp_rec n1 x2 (subst_dexp ee1 x1 ee2).
Proof.
pose proof subst_dexp_close_dexp_wrt_dexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_dexp_close_dexp_wrt_dexp_rec : lngen.

Lemma subst_dexp_close_dexp_wrt_dexp :
forall ee2 ee1 x1 x2,
  lc_dexp ee1 ->  x1 <> x2 ->
  x2 `notin` fv_dexp ee1 ->
  subst_dexp ee1 x1 (close_dexp_wrt_dexp x2 ee2) = close_dexp_wrt_dexp x2 (subst_dexp ee1 x1 ee2).
Proof.
unfold close_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve subst_dexp_close_dexp_wrt_dexp : lngen.

(* begin hide *)

Lemma subst_dexp_degree_dexp_wrt_dexp_mutual :
(forall ee1 ee2 x1 n1,
  degree_dexp_wrt_dexp n1 ee1 ->
  degree_dexp_wrt_dexp n1 ee2 ->
  degree_dexp_wrt_dexp n1 (subst_dexp ee2 x1 ee1)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_dexp_degree_dexp_wrt_dexp :
forall ee1 ee2 x1 n1,
  degree_dexp_wrt_dexp n1 ee1 ->
  degree_dexp_wrt_dexp n1 ee2 ->
  degree_dexp_wrt_dexp n1 (subst_dexp ee2 x1 ee1).
Proof.
pose proof subst_dexp_degree_dexp_wrt_dexp_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_dexp_degree_dexp_wrt_dexp : lngen.

(* begin hide *)

Lemma subst_dexp_fresh_eq_mutual :
(forall ee2 ee1 x1,
  x1 `notin` fv_dexp ee2 ->
  subst_dexp ee1 x1 ee2 = ee2).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_dexp_fresh_eq :
forall ee2 ee1 x1,
  x1 `notin` fv_dexp ee2 ->
  subst_dexp ee1 x1 ee2 = ee2.
Proof.
pose proof subst_dexp_fresh_eq_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_dexp_fresh_eq : lngen.
Hint Rewrite subst_dexp_fresh_eq using solve [auto] : lngen.

(* begin hide *)

Lemma subst_dexp_fresh_same_mutual :
(forall ee2 ee1 x1,
  x1 `notin` fv_dexp ee1 ->
  x1 `notin` fv_dexp (subst_dexp ee1 x1 ee2)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_dexp_fresh_same :
forall ee2 ee1 x1,
  x1 `notin` fv_dexp ee1 ->
  x1 `notin` fv_dexp (subst_dexp ee1 x1 ee2).
Proof.
pose proof subst_dexp_fresh_same_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_dexp_fresh_same : lngen.

(* begin hide *)

Lemma subst_dexp_fresh_mutual :
(forall ee2 ee1 x1 x2,
  x1 `notin` fv_dexp ee2 ->
  x1 `notin` fv_dexp ee1 ->
  x1 `notin` fv_dexp (subst_dexp ee1 x2 ee2)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_dexp_fresh :
forall ee2 ee1 x1 x2,
  x1 `notin` fv_dexp ee2 ->
  x1 `notin` fv_dexp ee1 ->
  x1 `notin` fv_dexp (subst_dexp ee1 x2 ee2).
Proof.
pose proof subst_dexp_fresh_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_dexp_fresh : lngen.

Lemma subst_dexp_lc_dexp :
forall ee1 ee2 x1,
  lc_dexp ee1 ->
  lc_dexp ee2 ->
  lc_dexp (subst_dexp ee2 x1 ee1).
Proof.
default_simp.
Qed.

Hint Resolve subst_dexp_lc_dexp : lngen.

(* begin hide *)

Lemma subst_dexp_open_dexp_wrt_dexp_rec_mutual :
(forall ee3 ee1 ee2 x1 n1,
  lc_dexp ee1 ->
  subst_dexp ee1 x1 (open_dexp_wrt_dexp_rec n1 ee2 ee3) = open_dexp_wrt_dexp_rec n1 (subst_dexp ee1 x1 ee2) (subst_dexp ee1 x1 ee3)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_dexp_open_dexp_wrt_dexp_rec :
forall ee3 ee1 ee2 x1 n1,
  lc_dexp ee1 ->
  subst_dexp ee1 x1 (open_dexp_wrt_dexp_rec n1 ee2 ee3) = open_dexp_wrt_dexp_rec n1 (subst_dexp ee1 x1 ee2) (subst_dexp ee1 x1 ee3).
Proof.
pose proof subst_dexp_open_dexp_wrt_dexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_dexp_open_dexp_wrt_dexp_rec : lngen.

(* end hide *)

Lemma subst_dexp_open_dexp_wrt_dexp :
forall ee3 ee1 ee2 x1,
  lc_dexp ee1 ->
  subst_dexp ee1 x1 (open_dexp_wrt_dexp ee3 ee2) = open_dexp_wrt_dexp (subst_dexp ee1 x1 ee3) (subst_dexp ee1 x1 ee2).
Proof.
unfold open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve subst_dexp_open_dexp_wrt_dexp : lngen.

Lemma subst_dexp_open_dexp_wrt_dexp_var :
forall ee2 ee1 x1 x2,
  x1 <> x2 ->
  lc_dexp ee1 ->
  open_dexp_wrt_dexp (subst_dexp ee1 x1 ee2) (de_var_f x2) = subst_dexp ee1 x1 (open_dexp_wrt_dexp ee2 (de_var_f x2)).
Proof.
intros; rewrite subst_dexp_open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve subst_dexp_open_dexp_wrt_dexp_var : lngen.

(* begin hide *)

Lemma subst_dexp_spec_rec_mutual :
(forall ee1 ee2 x1 n1,
  subst_dexp ee2 x1 ee1 = open_dexp_wrt_dexp_rec n1 ee2 (close_dexp_wrt_dexp_rec n1 x1 ee1)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_dexp_spec_rec :
forall ee1 ee2 x1 n1,
  subst_dexp ee2 x1 ee1 = open_dexp_wrt_dexp_rec n1 ee2 (close_dexp_wrt_dexp_rec n1 x1 ee1).
Proof.
pose proof subst_dexp_spec_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_dexp_spec_rec : lngen.

(* end hide *)

Lemma subst_dexp_spec :
forall ee1 ee2 x1,
  subst_dexp ee2 x1 ee1 = open_dexp_wrt_dexp (close_dexp_wrt_dexp x1 ee1) ee2.
Proof.
unfold close_dexp_wrt_dexp; unfold open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve subst_dexp_spec : lngen.

(* begin hide *)

Lemma subst_dexp_subst_dexp_mutual :
(forall ee1 ee2 ee3 x2 x1,
  x2 `notin` fv_dexp ee2 ->
  x2 <> x1 ->
  subst_dexp ee2 x1 (subst_dexp ee3 x2 ee1) = subst_dexp (subst_dexp ee2 x1 ee3) x2 (subst_dexp ee2 x1 ee1)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_dexp_subst_dexp :
forall ee1 ee2 ee3 x2 x1,
  x2 `notin` fv_dexp ee2 ->
  x2 <> x1 ->
  subst_dexp ee2 x1 (subst_dexp ee3 x2 ee1) = subst_dexp (subst_dexp ee2 x1 ee3) x2 (subst_dexp ee2 x1 ee1).
Proof.
pose proof subst_dexp_subst_dexp_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_dexp_subst_dexp : lngen.

(* begin hide *)

Lemma subst_dexp_close_dexp_wrt_dexp_rec_open_dexp_wrt_dexp_rec_mutual :
(forall ee2 ee1 x1 x2 n1,
  x2 `notin` fv_dexp ee2 ->
  x2 `notin` fv_dexp ee1 ->
  x2 <> x1 ->
  degree_dexp_wrt_dexp n1 ee1 ->
  subst_dexp ee1 x1 ee2 = close_dexp_wrt_dexp_rec n1 x2 (subst_dexp ee1 x1 (open_dexp_wrt_dexp_rec n1 (de_var_f x2) ee2))).
Proof.
apply_mutual_ind dexp_mutrec;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_dexp_close_dexp_wrt_dexp_rec_open_dexp_wrt_dexp_rec :
forall ee2 ee1 x1 x2 n1,
  x2 `notin` fv_dexp ee2 ->
  x2 `notin` fv_dexp ee1 ->
  x2 <> x1 ->
  degree_dexp_wrt_dexp n1 ee1 ->
  subst_dexp ee1 x1 ee2 = close_dexp_wrt_dexp_rec n1 x2 (subst_dexp ee1 x1 (open_dexp_wrt_dexp_rec n1 (de_var_f x2) ee2)).
Proof.
pose proof subst_dexp_close_dexp_wrt_dexp_rec_open_dexp_wrt_dexp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_dexp_close_dexp_wrt_dexp_rec_open_dexp_wrt_dexp_rec : lngen.

(* end hide *)

Lemma subst_dexp_close_dexp_wrt_dexp_open_dexp_wrt_dexp :
forall ee2 ee1 x1 x2,
  x2 `notin` fv_dexp ee2 ->
  x2 `notin` fv_dexp ee1 ->
  x2 <> x1 ->
  lc_dexp ee1 ->
  subst_dexp ee1 x1 ee2 = close_dexp_wrt_dexp x2 (subst_dexp ee1 x1 (open_dexp_wrt_dexp ee2 (de_var_f x2))).
Proof.
unfold close_dexp_wrt_dexp; unfold open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve subst_dexp_close_dexp_wrt_dexp_open_dexp_wrt_dexp : lngen.

Lemma subst_dexp_de_abs :
forall x2 ee2 ee1 x1,
  lc_dexp ee1 ->
  x2 `notin` fv_dexp ee1 `union` fv_dexp ee2 `union` singleton x1 ->
  subst_dexp ee1 x1 (de_abs ee2) = de_abs (close_dexp_wrt_dexp x2 (subst_dexp ee1 x1 (open_dexp_wrt_dexp ee2 (de_var_f x2)))).
Proof.
default_simp.
Qed.

Hint Resolve subst_dexp_de_abs : lngen.

Lemma subst_dexp_de_fixpoint :
forall x2 ee2 ee1 x1,
  lc_dexp ee1 ->
  x2 `notin` fv_dexp ee1 `union` fv_dexp ee2 `union` singleton x1 ->
  subst_dexp ee1 x1 (de_fixpoint ee2) = de_fixpoint (close_dexp_wrt_dexp x2 (subst_dexp ee1 x1 (open_dexp_wrt_dexp ee2 (de_var_f x2)))).
Proof.
default_simp.
Qed.

Hint Resolve subst_dexp_de_fixpoint : lngen.

(* begin hide *)

Lemma subst_dexp_intro_rec_mutual :
(forall ee1 x1 ee2 n1,
  x1 `notin` fv_dexp ee1 ->
  open_dexp_wrt_dexp_rec n1 ee2 ee1 = subst_dexp ee2 x1 (open_dexp_wrt_dexp_rec n1 (de_var_f x1) ee1)).
Proof.
apply_mutual_ind dexp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_dexp_intro_rec :
forall ee1 x1 ee2 n1,
  x1 `notin` fv_dexp ee1 ->
  open_dexp_wrt_dexp_rec n1 ee2 ee1 = subst_dexp ee2 x1 (open_dexp_wrt_dexp_rec n1 (de_var_f x1) ee1).
Proof.
pose proof subst_dexp_intro_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_dexp_intro_rec : lngen.
Hint Rewrite subst_dexp_intro_rec using solve [auto] : lngen.

Lemma subst_dexp_intro :
forall x1 ee1 ee2,
  x1 `notin` fv_dexp ee1 ->
  open_dexp_wrt_dexp ee1 ee2 = subst_dexp ee2 x1 (open_dexp_wrt_dexp ee1 (de_var_f x1)).
Proof.
unfold open_dexp_wrt_dexp; default_simp.
Qed.

Hint Resolve subst_dexp_intro : lngen.

(* *********************************************************************** *)
(** * "Restore" tactics *)

Ltac default_auto ::= auto; tauto.
Ltac default_autorewrite ::= fail.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e383m421_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e495m31_20limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e495m31_21limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Coq.Lists.List.
Require Import VCF.TraceGeneral.

Record FDvgTrace (A: Type) (B: Type) :=
{
  head_events: list A;
  tail_event: B;
}.

Inductive DvgTrace (A: Type) (B: Type): Type :=
| Finite_Diverge (tr: FDvgTrace A B)
| Infinite_Diverge (tr: nat -> A).

Arguments head_events {A} {B} (_).
Arguments tail_event {A} {B} (_).
Arguments Finite_Diverge {A} {B} (_).
Arguments Infinite_Diverge {A} {B} (_).

Definition fd_trace_app {A B} (l1: list A) (l2: FDvgTrace A B): FDvgTrace A B :=
{|
  head_events := app l1 (head_events l2);
  tail_event := tail_event l2;
|}.

Definition diverge_trace_app {A B} (l1: list A) (l2: DvgTrace A B): DvgTrace A B :=
  match l2 with
  | Finite_Diverge l2' => Finite_Diverge (fd_trace_app l1 l2')
  | Infinite_Diverge l2' => Infinite_Diverge (natfunc_app l1 l2')
  end.

Lemma app_fd_trace_app: forall {A B} (l1 l2: list A) (l3: FDvgTrace A B),
  fd_trace_app l1 (fd_trace_app l2 l3) = fd_trace_app (l1 ++ l2) l3.
Proof.
  intros.
  unfold fd_trace_app; simpl.
  f_equal; apply app_assoc.
Qed.

Lemma app_diverge_trace_app: forall {A B} (l1 l2: list A) (l3: DvgTrace A B),
  diverge_trace_app l1 (diverge_trace_app l2 l3) = diverge_trace_app (l1 ++ l2) l3.
Proof.
  intros.
  destruct l3 as [l3' | l3'].
  + simpl.
    f_equal.
    apply app_fd_trace_app.
  + simpl.
    f_equal.
    apply app_natfunc_app.
Qed.

Lemma fd_trace_app_nil_l: forall {A B} (l: FDvgTrace A B),
  fd_trace_app nil l = l.
Proof. intros. destruct l; reflexivity. Qed.

Lemma diverge_trace_app_nil_l: forall {A B} (l: DvgTrace A B),
  diverge_trace_app nil l = l.
Proof.
  intros.
  destruct l as [l' | l'].
  + simpl.
    f_equal.
    apply fd_trace_app_nil_l.
  + simpl.
    reflexivity.
Qed.

Instance FDvgTrace_InfTrace (A B: Type): Trace.InfTrace (list A) (FDvgTrace A B) :=
{|
  Trace.inf_concat := fd_trace_app;
  Trace.fin_concat_inf_concat_assoc := app_fd_trace_app;
  Trace.empty_inf_concat := fd_trace_app_nil_l;
|}.

Instance DvgTrace_InfTrace (A B: Type): Trace.InfTrace (list A) (DvgTrace A B) :=
{|
  Trace.inf_concat := diverge_trace_app;
  Trace.fin_concat_inf_concat_assoc := app_diverge_trace_app;
  Trace.empty_inf_concat := diverge_trace_app_nil_l;
|}.


(** ** Variadic Preservation *)

Require Export ARS Program.Equality.
Require Import core fintype.
Import ScopedNotations.
From Chapter6 Require Export variadic_fin.
Set Implicit Arguments.
Unset Strict Implicit.

Ltac inv H := dependent destruction H.
Hint Constructors star.

(** *** Single-step reduction *)
Inductive step {n} : tm n -> tm n -> Prop :=
| step_beta p b (t: fin p -> tm n) : step (app _ (lam p b) t) (b[scons_p p t ids])
| step_abs  p b1 b2 : @step (p + n) b1 b2 -> step (lam p b1) (lam p b2)
| step_appL p s1 s2 t : step s1 s2 -> step (app p s1 t) (app _ s2 t).

Hint Constructors step.

Lemma step_beta' n p b (t: fin p -> tm n) t':
  t' = b[scons_p p t ids] -> step (app _ (lam p b) t) t'.
Proof. intros ->. now constructor. Qed.

(** *** Substitutivity *)

Require Import Setoid Morphisms.

Require Import core_axioms.

Lemma step_inst {m n} (f : fin m -> tm n) (s t : tm m) :
  step s t -> step (subst_tm f s) (subst_tm f t).
Proof.
  intros st. revert n f.  induction st; intros; cbn.
  - apply step_beta'.
    asimpl.
    (* DONE a.d. cod_map not unfolded because it's part of core_axioms *)
    unfold cod_map.
    now asimpl.
  - apply step_abs. eapply IHst.
  - apply step_appL, IHst.
Qed.

Lemma mstep_inst m n (f : fin m -> tm n) (s t : tm m) :
  star step s t -> star step (s[f]) (t[f]).
Proof. induction 1; eauto using step_inst. Qed.

(** *** Variadic typing *)

Inductive ty  : Type :=
  | Base : ty
  | arr p : (fin p -> ty)  -> ty  -> ty .

Definition ctx n := fin n -> ty.

Inductive has_type {n} (Gamma : ctx n) : tm n -> ty -> Prop :=
| ty_var (x : fin n) :
    has_type Gamma (var_tm x) (Gamma x)
| ty_abs p (S1 : fin p -> ty) ( S2 : ty) (M : tm (p + n)) :
    @has_type (p + n) (scons_p p S1 Gamma) M S2 ->
    has_type Gamma (lam p M) (arr S1 S2)
| ty_app p (T : fin p -> ty) ( S : ty) (M  : tm n) N :
    has_type Gamma M (arr T S) ->
    (forall x, has_type Gamma (N x) (T x)) ->
    has_type Gamma (app p M N) S.
Notation "Gamma |- M : T" := (has_type Gamma M T) (at level 20, M at level 99).

Lemma ty_var' n  (x : fin n) A Gamma:
  A = Gamma x ->  has_type Gamma (var_tm x) A.
Proof. intros. subst. constructor. Qed.

Definition ltc {k k'} (Gamma: ctx k) (Delta: ctx k') rho := forall x, Delta (rho x) = Gamma x.

Lemma typing_ren n k (Gamma: ctx n) (Delta: ctx k) (rho: fin n -> fin k) (M: tm n) T :
  ltc Gamma Delta rho  -> Gamma |- M : T ->  Delta |- (M⟨rho⟩) : T.
Proof.
  intros C H. revert k Delta rho C. induction H; intros; asimpl; eauto using has_type.
  - unfold ltc in C. rewrite <- C. constructor.
  - constructor. apply IHhas_type. intros x.
    destruct (destruct_fin x) as [(?&->)|(?&->)]; eauto; asimpl; unfold upRen_p; asimpl; eauto.
  - econstructor; eauto.
Qed.

Lemma typing_inst n k (Gamma: ctx n) (Delta: ctx k) (sigma: fin n -> tm k) (M: tm n) T :
  (forall x, Delta |- sigma x : Gamma x) -> Gamma |- M : T ->  Delta |- (M[sigma]) : T.
Proof.
Proof.
  intros C H. revert k Delta sigma C. induction H; intros; asimpl; eauto using has_type.
  - unfold ltc in C. apply C.
  - constructor. apply IHhas_type. intros x.
    destruct (destruct_fin x) as [(?&->)|(?&->)]; asimpl.
    + apply ty_var'. now asimpl.
    + eapply typing_ren; eauto. intros x. now asimpl.
 - econstructor; eauto.
Qed.

(** *** Preservation *)

Lemma step_typing k (Gamma: ctx k) M T :
  Gamma |- M : T -> forall M', step M M' -> Gamma |- M' : T.
Proof.
  induction 1; intros; cbn.
  - inv H.
  - inv H0. econstructor. now apply IHhas_type.
  - inv H2.
    + inv H. eapply typing_inst; try eassumption.
      intros x. destruct (destruct_fin x) as [(?&->)|(?&->)]; asimpl; eauto.
      * apply ty_var'; eauto.
    + eapply ty_app; eauto.
Qed.


Require Import Lists.List.

(**

  Some more facts about removing an item from a list.

  *)

Section remove.
  Variable A : Type.
  Hypothesis decA : forall a a' : A, {a = a'} + {a <> a'}.

  Lemma remove_eq (a : A) (l : list A)
    : remove decA a (a :: l) = remove decA a l.
  Proof.
    unfold remove; fold (remove decA a).
    case (decA a a); auto. contradiction.
  Qed.

  Lemma remove_neq {a a' : A} {l : list A}
    : a <> a' -> remove decA a (a' :: l) = a' :: remove decA a l.
  Proof.
    unfold remove; fold (remove decA a).
    case (decA a a'); tauto.
  Qed.

  Lemma remove_cons {a a' : A} {l : list A}
    : remove decA a (a' :: l) =
      if decA a a' then remove decA a l else a' :: remove decA a l.
  Proof.
    unfold remove; fold (remove decA); auto.
  Qed.

  Lemma in_remove a a' l
    : In a l -> a <> a' -> In a (remove decA a' l).
  Proof.
    intros inH neH.
    induction l as [ | a'' l IH ]; try contradiction.
    destruct (decA a' a'') as [ <- | neH' ].
    - rewrite remove_eq.
      destruct (in_inv inH) as [ <- | ]; tauto.
    - rewrite (remove_neq neH').
      destruct (in_inv inH) as [ <- | ];
        auto with datatypes.
  Qed.

  Lemma in_remove_means_in_original a a' l
    : In a (remove decA a' l) -> In a l.
  Proof.
    induction l as [ | a'' l IH ]; auto.
    destruct (decA a' a'') as [ <- | neH' ].
    - rewrite remove_eq; auto using in_cons.
    - rewrite (remove_neq neH').
      destruct 1 as [ -> | neH ]; auto with datatypes.
  Qed.

End remove.

Arguments remove_eq {A} decA a l.
Arguments remove_neq {A} decA {a a'} l.
Arguments in_remove {A} decA {a a' l}.
Arguments in_remove_means_in_original {A} decA {a a' l}.

Hint Rewrite @remove_eq : remove.
Hint Rewrite @remove_neq : remove.
Hint Rewrite @remove_cons : remove.

Section remove_under.
  Variables A B : Type.
  Hypothesis decB : forall b b' : B, {b = b'} + {b <> b'}.
  Variable f : A -> B.

  Fixpoint remove_under (b : B) (l : list A) :=
    match l with
    | nil => nil
    | a :: tl => if decB b (f a)
                 then remove_under b tl
                 else a :: remove_under b tl
    end.

  Lemma remove_under_eq a l
    : remove_under (f a) (a :: l) = remove_under (f a) l.
  Proof.
    simpl; destruct (decB (f a) (f a)); [ auto | contradiction ].
  Qed.

  Lemma remove_under_neq a b l
    : b <> f a -> remove_under b (a :: l) = a :: remove_under b l.
  Proof.
    simpl; destruct (decB b (f a)); [ contradiction | auto ].
  Qed.

  Lemma remove_under_cons a b l
    : remove_under b (a :: l) =
      if decB b (f a) then remove_under b l else a :: remove_under b l.
  Proof.
    auto.
  Qed.

  Fixpoint in_under (b : B) (l : list A) :=
    match l with
    | nil => False
    | a :: tl => b = f a \/ in_under b tl
    end.

  Lemma in_under_remove b b' l
    : in_under b l -> b <> b' -> in_under b (remove_under b' l).
  Proof.
    intros inH neH.
    induction l as [ | a l IH ]; [ contradiction | ].
    simpl; destruct (decB b' (f a)) as [ -> | neH' ];
      simpl; destruct inH; tauto.
  Qed.

  Lemma in_under_remove_means_in_original b b' l
    : in_under b (remove_under b' l) -> in_under b l.
  Proof.
    induction l as [ | a l IH ]; auto.
    simpl; destruct (decB b' (f a)); [ | destruct 1 ]; auto.
  Qed.

  Lemma in_under_preimage a b l
    : In a l -> f a = b -> in_under b l.
  Proof.
    induction l as [ | x l IH ]; [ inversion 1 | ].
    simpl; destruct 1 as [ -> | ]; auto.
  Qed.

End remove_under.

Arguments remove_under {A B} decB f b l.
Arguments remove_under_eq {A B} decB f a l.
Arguments remove_under_neq {A B} decB {f a b} l neH.
Arguments remove_under_cons {A B} decB f a b l.
Arguments in_under {A B} f b l.
Arguments in_under_remove {A B} decB f {b b' l} inH neH.
Arguments in_under_remove_means_in_original {A B} decB f {b b' l} inH.
Arguments in_under_preimage {A B} {f a b l} inH abH.

Hint Rewrite @remove_under_eq : remove.
Hint Rewrite @remove_under_neq : remove.
Hint Rewrite @remove_under_cons : remove.

Section lift.
  Variables A B : Type.
  Variable p : A -> B.

  Lemma lift_in_under_iff b l
    : in_under p b l <-> (exists a, In a l /\ p a = b).
  Proof.
    split.
    - induction l as [ | a l IH ]; [ inversion 1 | ].
      destruct 1 as [ -> | consH ].
      + exists a; auto with datatypes.
      + destruct (IH consH) as [ a' [ inH pa'H ] ].
        exists a'; auto with datatypes.
    - destruct 1 as [ a [ inH paH ] ].
      induction l as [ | a' l IH ]; [ inversion inH | ].
      destruct inH as [ -> | consH ].
      + left; auto.
      + right; auto.
  Qed.
End lift.

Arguments lift_in_under_iff {A B} p b l.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** This file provides indefinite description under the form of
    Hilbert's epsilon operator; it does not assume classical logic. *)

Require Import ChoiceFacts.

Set Implicit Arguments.

(** Hilbert's epsilon: operator and specification in one statement *)

Axiom epsilon_statement :
  forall (A : Type) (P : A->Prop), inhabited A ->
    { x : A | (exists x, P x) -> P x }.

Lemma constructive_indefinite_description :
  forall (A : Type) (P : A->Prop),
    (exists x, P x) -> { x : A | P x }.
Proof.
  apply epsilon_imp_constructive_indefinite_description.
  exact epsilon_statement.
Qed.

Lemma small_drinkers'_paradox :
  forall (A:Type) (P:A -> Prop), inhabited A ->
    exists x, (exists x, P x) -> P x.
Proof.
  apply epsilon_imp_small_drinker.
  exact epsilon_statement.
Qed.

Theorem iota_statement :
  forall (A : Type) (P : A->Prop), inhabited A ->
  { x : A | (exists! x : A, P x) -> P x }.
Proof.
  intros; destruct epsilon_statement with (P:=P); firstorder.
Qed.

Lemma constructive_definite_description :
  forall (A : Type) (P : A->Prop),
    (exists! x, P x) -> { x : A | P x }.
Proof.
  apply iota_imp_constructive_definite_description.
  exact iota_statement.
Qed.

(** Hilbert's epsilon operator and its specification *)

Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A
  := proj1_sig (epsilon_statement P i).

Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) :
  (exists x, P x) -> P (epsilon i P)
  := proj2_sig (epsilon_statement P i).

(** Church's iota operator and its specification *)

Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A
  := proj1_sig (iota_statement P i).

Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) :
  (exists! x:A, P x) -> P (iota i P)
  := proj2_sig (iota_statement P i).


Require Export euclidean__axioms.
Require Export euclidean__tactics.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__inequalitysymmetric.
Require Export logic.
Definition lemma__9__5b : forall A B C P Q R, (euclidean__axioms.TS P A B C) -> ((euclidean__axioms.BetS R Q P) -> ((euclidean__axioms.nCol C P R) -> ((euclidean__axioms.Col A B R) -> (euclidean__axioms.TS Q A B C)))).
Proof.
intro A.
intro B.
intro C.
intro P.
intro Q.
intro R.
intro H.
intro H0.
intro H1.
intro H2.
assert (exists S, (euclidean__axioms.BetS P S C) /\ ((euclidean__axioms.Col A B S) /\ (euclidean__axioms.nCol A B P))) as H3 by exact H.
destruct H3 as [S H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
assert (* Cut *) (euclidean__axioms.BetS C S P) as H9.
- apply (@euclidean__axioms.axiom__betweennesssymmetry P S C H5).
- assert (* Cut *) (exists F, (euclidean__axioms.BetS C F Q) /\ (euclidean__axioms.BetS R F S)) as H10.
-- apply (@euclidean__axioms.postulate__Pasch__inner C R P S Q H9 H0 H1).
-- destruct H10 as [F H11].
destruct H11 as [H12 H13].
assert (* Cut *) (euclidean__axioms.Col R S F) as H14.
--- right.
right.
right.
right.
right.
exact H13.
--- assert (* Cut *) (~(A = B)) as H15.
---- intro H15.
assert (* Cut *) (euclidean__axioms.Col A B P) as H16.
----- left.
exact H15.
----- apply (@euclidean__tactics.Col__nCol__False A B P H8 H16).
---- assert (* Cut *) (euclidean__axioms.neq B A) as H16.
----- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A B H15).
----- assert (* Cut *) (euclidean__axioms.Col B R S) as H17.
------ apply (@euclidean__tactics.not__nCol__Col B R S).
-------intro H17.
apply (@euclidean__tactics.Col__nCol__False B R S H17).
--------apply (@lemma__collinear4.lemma__collinear4 A B R S H2 H7 H15).

------ assert (* Cut *) (euclidean__axioms.Col R S B) as H18.
------- assert (* Cut *) ((euclidean__axioms.Col R B S) /\ ((euclidean__axioms.Col R S B) /\ ((euclidean__axioms.Col S B R) /\ ((euclidean__axioms.Col B S R) /\ (euclidean__axioms.Col S R B))))) as H18.
-------- apply (@lemma__collinearorder.lemma__collinearorder B R S H17).
-------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
exact H21.
------- assert (* Cut *) (euclidean__axioms.neq R S) as H19.
-------- assert (* Cut *) ((euclidean__axioms.neq F S) /\ ((euclidean__axioms.neq R F) /\ (euclidean__axioms.neq R S))) as H19.
--------- apply (@lemma__betweennotequal.lemma__betweennotequal R F S H13).
--------- destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
exact H23.
-------- assert (* Cut *) (euclidean__axioms.Col S F B) as H20.
--------- apply (@euclidean__tactics.not__nCol__Col S F B).
----------intro H20.
apply (@euclidean__tactics.Col__nCol__False S F B H20).
-----------apply (@lemma__collinear4.lemma__collinear4 R S F B H14 H18 H19).

--------- assert (* Cut *) (euclidean__axioms.Col S B A) as H21.
---------- assert (* Cut *) ((euclidean__axioms.Col B A S) /\ ((euclidean__axioms.Col B S A) /\ ((euclidean__axioms.Col S A B) /\ ((euclidean__axioms.Col A S B) /\ (euclidean__axioms.Col S B A))))) as H21.
----------- apply (@lemma__collinearorder.lemma__collinearorder A B S H7).
----------- destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
exact H29.
---------- assert (* Cut *) (euclidean__axioms.Col S B F) as H22.
----------- assert (* Cut *) ((euclidean__axioms.Col F S B) /\ ((euclidean__axioms.Col F B S) /\ ((euclidean__axioms.Col B S F) /\ ((euclidean__axioms.Col S B F) /\ (euclidean__axioms.Col B F S))))) as H22.
------------ apply (@lemma__collinearorder.lemma__collinearorder S F B H20).
------------ destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
exact H29.
----------- assert (* Cut *) (euclidean__axioms.Col A B F) as H23.
------------ assert (* Cut *) ((S = B) \/ (euclidean__axioms.neq S B)) as H23.
------------- apply (@euclidean__tactics.eq__or__neq S B).
------------- assert ((S = B) \/ (euclidean__axioms.neq S B)) as H24 by exact H23.
assert ((S = B) \/ (euclidean__axioms.neq S B)) as __TmpHyp by exact H24.
destruct __TmpHyp as [H25|H25].
-------------- assert (* Cut *) (euclidean__axioms.Col B A S) as H26.
--------------- assert (* Cut *) ((euclidean__axioms.Col B S A) /\ ((euclidean__axioms.Col B A S) /\ ((euclidean__axioms.Col A S B) /\ ((euclidean__axioms.Col S A B) /\ (euclidean__axioms.Col A B S))))) as H26.
---------------- apply (@lemma__collinearorder.lemma__collinearorder S B A H21).
---------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
exact H29.
--------------- assert (euclidean__axioms.Col R S F) as H27 by exact H14.
assert (* Cut *) (euclidean__axioms.Col R B F) as H28.
---------------- apply (@eq__ind__r euclidean__axioms.Point B (fun S0 => (euclidean__axioms.BetS P S0 C) -> ((euclidean__axioms.Col A B S0) -> ((euclidean__axioms.BetS C S0 P) -> ((euclidean__axioms.BetS R F S0) -> ((euclidean__axioms.Col R S0 F) -> ((euclidean__axioms.Col B R S0) -> ((euclidean__axioms.Col R S0 B) -> ((euclidean__axioms.neq R S0) -> ((euclidean__axioms.Col S0 F B) -> ((euclidean__axioms.Col S0 B A) -> ((euclidean__axioms.Col S0 B F) -> ((euclidean__axioms.Col B A S0) -> ((euclidean__axioms.Col R S0 F) -> (euclidean__axioms.Col R B F))))))))))))))) with (x := S).
-----------------intro H28.
intro H29.
intro H30.
intro H31.
intro H32.
intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
intro H38.
intro H39.
intro H40.
exact H40.

----------------- exact H25.
----------------- exact H5.
----------------- exact H7.
----------------- exact H9.
----------------- exact H13.
----------------- exact H14.
----------------- exact H17.
----------------- exact H18.
----------------- exact H19.
----------------- exact H20.
----------------- exact H21.
----------------- exact H22.
----------------- exact H26.
----------------- exact H27.
---------------- assert (* Cut *) (euclidean__axioms.Col R B A) as H29.
----------------- assert (* Cut *) ((euclidean__axioms.Col B A R) /\ ((euclidean__axioms.Col B R A) /\ ((euclidean__axioms.Col R A B) /\ ((euclidean__axioms.Col A R B) /\ (euclidean__axioms.Col R B A))))) as H29.
------------------ apply (@lemma__collinearorder.lemma__collinearorder A B R H2).
------------------ destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
exact H37.
----------------- assert (* Cut *) (~(R = B)) as H30.
------------------ intro H30.
assert (* Cut *) (R = S) as H31.
------------------- apply (@logic.eq__trans Point R B S H30).
--------------------apply (@logic.eq__sym Point S B H25).

------------------- assert (* Cut *) (euclidean__axioms.neq R S) as H32.
-------------------- assert (* Cut *) ((euclidean__axioms.neq F S) /\ ((euclidean__axioms.neq R F) /\ (euclidean__axioms.neq R S))) as H32.
--------------------- apply (@lemma__betweennotequal.lemma__betweennotequal R F S H13).
--------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
exact H19.
-------------------- assert (* Cut *) (euclidean__axioms.neq R B) as H33.
--------------------- apply (@eq__ind__r euclidean__axioms.Point B (fun R0 => (euclidean__axioms.BetS R0 Q P) -> ((euclidean__axioms.nCol C P R0) -> ((euclidean__axioms.Col A B R0) -> ((euclidean__axioms.BetS R0 F S) -> ((euclidean__axioms.Col R0 S F) -> ((euclidean__axioms.Col B R0 S) -> ((euclidean__axioms.Col R0 S B) -> ((euclidean__axioms.neq R0 S) -> ((euclidean__axioms.Col R0 S F) -> ((euclidean__axioms.Col R0 B F) -> ((euclidean__axioms.Col R0 B A) -> ((R0 = S) -> ((euclidean__axioms.neq R0 S) -> (euclidean__axioms.neq R0 B))))))))))))))) with (x := R).
----------------------intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
intro H38.
intro H39.
intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
apply (@eq__ind__r euclidean__axioms.Point B (fun S0 => (euclidean__axioms.BetS P S0 C) -> ((euclidean__axioms.Col A B S0) -> ((euclidean__axioms.BetS C S0 P) -> ((euclidean__axioms.Col B S0 F) -> ((euclidean__axioms.BetS B F S0) -> ((euclidean__axioms.neq B S0) -> ((euclidean__axioms.Col B S0 B) -> ((euclidean__axioms.Col B B S0) -> ((euclidean__axioms.Col S0 F B) -> ((euclidean__axioms.Col S0 B A) -> ((euclidean__axioms.Col S0 B F) -> ((euclidean__axioms.Col B A S0) -> ((euclidean__axioms.Col B S0 F) -> ((euclidean__axioms.neq B S0) -> ((B = S0) -> (euclidean__axioms.neq B B))))))))))))))))) with (x := S).
-----------------------intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
intro H53.
intro H54.
intro H55.
intro H56.
intro H57.
intro H58.
intro H59.
intro H60.
exact H59.

----------------------- exact H25.
----------------------- exact H5.
----------------------- exact H7.
----------------------- exact H9.
----------------------- exact H37.
----------------------- exact H36.
----------------------- exact H40.
----------------------- exact H39.
----------------------- exact H38.
----------------------- exact H20.
----------------------- exact H21.
----------------------- exact H22.
----------------------- exact H26.
----------------------- exact H41.
----------------------- exact H45.
----------------------- exact H44.

---------------------- exact H30.
---------------------- exact H0.
---------------------- exact H1.
---------------------- exact H2.
---------------------- exact H13.
---------------------- exact H14.
---------------------- exact H17.
---------------------- exact H18.
---------------------- exact H19.
---------------------- exact H27.
---------------------- exact H28.
---------------------- exact H29.
---------------------- exact H31.
---------------------- exact H32.
--------------------- apply (@H19 H31).
------------------ assert (* Cut *) (euclidean__axioms.Col B F A) as H31.
------------------- apply (@euclidean__tactics.not__nCol__Col B F A).
--------------------intro H31.
apply (@euclidean__tactics.Col__nCol__False B F A H31).
---------------------apply (@lemma__collinear4.lemma__collinear4 R B F A H28 H29 H30).

------------------- assert (* Cut *) (euclidean__axioms.Col A B F) as H32.
-------------------- assert (* Cut *) ((euclidean__axioms.Col F B A) /\ ((euclidean__axioms.Col F A B) /\ ((euclidean__axioms.Col A B F) /\ ((euclidean__axioms.Col B A F) /\ (euclidean__axioms.Col A F B))))) as H32.
--------------------- apply (@lemma__collinearorder.lemma__collinearorder B F A H31).
--------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
exact H37.
-------------------- exact H32.
-------------- assert (* Cut *) (euclidean__axioms.Col B A F) as H26.
--------------- apply (@euclidean__tactics.not__nCol__Col B A F).
----------------intro H26.
apply (@euclidean__tactics.Col__nCol__False B A F H26).
-----------------apply (@lemma__collinear4.lemma__collinear4 S B A F H21 H22 H25).

--------------- assert (* Cut *) (euclidean__axioms.Col A B F) as H27.
---------------- assert (* Cut *) ((euclidean__axioms.Col A B F) /\ ((euclidean__axioms.Col A F B) /\ ((euclidean__axioms.Col F B A) /\ ((euclidean__axioms.Col B F A) /\ (euclidean__axioms.Col F A B))))) as H27.
----------------- apply (@lemma__collinearorder.lemma__collinearorder B A F H26).
----------------- destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
exact H28.
---------------- exact H27.
------------ assert (* Cut *) (~(euclidean__axioms.Col A B Q)) as H24.
------------- intro H24.
assert (* Cut *) (euclidean__axioms.Col B Q R) as H25.
-------------- apply (@euclidean__tactics.not__nCol__Col B Q R).
---------------intro H25.
apply (@euclidean__tactics.Col__nCol__False B Q R H25).
----------------apply (@lemma__collinear4.lemma__collinear4 A B Q R H24 H2 H15).

-------------- assert (* Cut *) (euclidean__axioms.Col B R Q) as H26.
--------------- assert (* Cut *) ((euclidean__axioms.Col Q B R) /\ ((euclidean__axioms.Col Q R B) /\ ((euclidean__axioms.Col R B Q) /\ ((euclidean__axioms.Col B R Q) /\ (euclidean__axioms.Col R Q B))))) as H26.
---------------- apply (@lemma__collinearorder.lemma__collinearorder B Q R H25).
---------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
exact H33.
--------------- assert (* Cut *) (euclidean__axioms.Col B R F) as H27.
---------------- apply (@euclidean__tactics.not__nCol__Col B R F).
-----------------intro H27.
apply (@euclidean__tactics.Col__nCol__False B R F H27).
------------------apply (@lemma__collinear4.lemma__collinear4 A B R F H2 H23 H15).

---------------- assert (* Cut *) (euclidean__axioms.Col R Q F) as H28.
----------------- assert (* Cut *) ((B = R) \/ (euclidean__axioms.neq B R)) as H28.
------------------ apply (@euclidean__tactics.eq__or__neq B R).
------------------ assert ((B = R) \/ (euclidean__axioms.neq B R)) as H29 by exact H28.
assert ((B = R) \/ (euclidean__axioms.neq B R)) as __TmpHyp by exact H29.
destruct __TmpHyp as [H30|H30].
------------------- assert (* Cut *) (~(A = R)) as H31.
-------------------- intro H31.
assert (* Cut *) (A = B) as H32.
--------------------- apply (@logic.eq__trans Point A R B H31).
----------------------apply (@logic.eq__sym Point B R H30).

--------------------- apply (@H15 H32).
-------------------- assert (* Cut *) (euclidean__axioms.Col B A R) as H32.
--------------------- assert (* Cut *) ((euclidean__axioms.Col B A R) /\ ((euclidean__axioms.Col B R A) /\ ((euclidean__axioms.Col R A B) /\ ((euclidean__axioms.Col A R B) /\ (euclidean__axioms.Col R B A))))) as H32.
---------------------- apply (@lemma__collinearorder.lemma__collinearorder A B R H2).
---------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
exact H33.
--------------------- assert (* Cut *) (euclidean__axioms.Col B A F) as H33.
---------------------- assert (* Cut *) ((euclidean__axioms.Col B A F) /\ ((euclidean__axioms.Col B F A) /\ ((euclidean__axioms.Col F A B) /\ ((euclidean__axioms.Col A F B) /\ (euclidean__axioms.Col F B A))))) as H33.
----------------------- apply (@lemma__collinearorder.lemma__collinearorder A B F H23).
----------------------- destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
exact H34.
---------------------- assert (* Cut *) (euclidean__axioms.Col A R F) as H34.
----------------------- apply (@eq__ind__r euclidean__axioms.Point R (fun B0 => (euclidean__axioms.TS P A B0 C) -> ((euclidean__axioms.Col A B0 R) -> ((euclidean__axioms.Col A B0 S) -> ((euclidean__axioms.nCol A B0 P) -> ((~(A = B0)) -> ((euclidean__axioms.neq B0 A) -> ((euclidean__axioms.Col B0 R S) -> ((euclidean__axioms.Col R S B0) -> ((euclidean__axioms.Col S F B0) -> ((euclidean__axioms.Col S B0 A) -> ((euclidean__axioms.Col S B0 F) -> ((euclidean__axioms.Col A B0 F) -> ((euclidean__axioms.Col A B0 Q) -> ((euclidean__axioms.Col B0 Q R) -> ((euclidean__axioms.Col B0 R Q) -> ((euclidean__axioms.Col B0 R F) -> ((euclidean__axioms.Col B0 A R) -> ((euclidean__axioms.Col B0 A F) -> (euclidean__axioms.Col A R F)))))))))))))))))))) with (x := B).
------------------------intro H34.
intro H35.
intro H36.
intro H37.
intro H38.
intro H39.
intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
exact H45.

------------------------ exact H30.
------------------------ exact H.
------------------------ exact H2.
------------------------ exact H7.
------------------------ exact H8.
------------------------ exact H15.
------------------------ exact H16.
------------------------ exact H17.
------------------------ exact H18.
------------------------ exact H20.
------------------------ exact H21.
------------------------ exact H22.
------------------------ exact H23.
------------------------ exact H24.
------------------------ exact H25.
------------------------ exact H26.
------------------------ exact H27.
------------------------ exact H32.
------------------------ exact H33.
----------------------- assert (* Cut *) (euclidean__axioms.Col B A Q) as H35.
------------------------ assert (* Cut *) ((euclidean__axioms.Col B A Q) /\ ((euclidean__axioms.Col B Q A) /\ ((euclidean__axioms.Col Q A B) /\ ((euclidean__axioms.Col A Q B) /\ (euclidean__axioms.Col Q B A))))) as H35.
------------------------- apply (@lemma__collinearorder.lemma__collinearorder A B Q H24).
------------------------- destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H36.
------------------------ assert (* Cut *) (euclidean__axioms.Col B A R) as H36.
------------------------- assert (* Cut *) ((euclidean__axioms.Col A B Q) /\ ((euclidean__axioms.Col A Q B) /\ ((euclidean__axioms.Col Q B A) /\ ((euclidean__axioms.Col B Q A) /\ (euclidean__axioms.Col Q A B))))) as H36.
-------------------------- apply (@lemma__collinearorder.lemma__collinearorder B A Q H35).
-------------------------- destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
exact H32.
------------------------- assert (* Cut *) (euclidean__axioms.Col A R Q) as H37.
-------------------------- apply (@eq__ind__r euclidean__axioms.Point R (fun B0 => (euclidean__axioms.TS P A B0 C) -> ((euclidean__axioms.Col A B0 R) -> ((euclidean__axioms.Col A B0 S) -> ((euclidean__axioms.nCol A B0 P) -> ((~(A = B0)) -> ((euclidean__axioms.neq B0 A) -> ((euclidean__axioms.Col B0 R S) -> ((euclidean__axioms.Col R S B0) -> ((euclidean__axioms.Col S F B0) -> ((euclidean__axioms.Col S B0 A) -> ((euclidean__axioms.Col S B0 F) -> ((euclidean__axioms.Col A B0 F) -> ((euclidean__axioms.Col A B0 Q) -> ((euclidean__axioms.Col B0 Q R) -> ((euclidean__axioms.Col B0 R Q) -> ((euclidean__axioms.Col B0 R F) -> ((euclidean__axioms.Col B0 A R) -> ((euclidean__axioms.Col B0 A F) -> ((euclidean__axioms.Col B0 A Q) -> ((euclidean__axioms.Col B0 A R) -> (euclidean__axioms.Col A R Q)))))))))))))))))))))) with (x := B).
---------------------------intro H37.
intro H38.
intro H39.
intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
intro H49.
intro H50.
intro H51.
intro H52.
intro H53.
intro H54.
intro H55.
intro H56.
exact H49.

--------------------------- exact H30.
--------------------------- exact H.
--------------------------- exact H2.
--------------------------- exact H7.
--------------------------- exact H8.
--------------------------- exact H15.
--------------------------- exact H16.
--------------------------- exact H17.
--------------------------- exact H18.
--------------------------- exact H20.
--------------------------- exact H21.
--------------------------- exact H22.
--------------------------- exact H23.
--------------------------- exact H24.
--------------------------- exact H25.
--------------------------- exact H26.
--------------------------- exact H27.
--------------------------- exact H32.
--------------------------- exact H33.
--------------------------- exact H35.
--------------------------- exact H36.
-------------------------- assert (* Cut *) (euclidean__axioms.Col R F Q) as H38.
--------------------------- apply (@euclidean__tactics.not__nCol__Col R F Q).
----------------------------intro H38.
apply (@euclidean__tactics.Col__nCol__False R F Q H38).
-----------------------------apply (@lemma__collinear4.lemma__collinear4 A R F Q H34 H37 H31).

--------------------------- assert (* Cut *) (euclidean__axioms.Col R Q F) as H39.
---------------------------- assert (* Cut *) ((euclidean__axioms.Col F R Q) /\ ((euclidean__axioms.Col F Q R) /\ ((euclidean__axioms.Col Q R F) /\ ((euclidean__axioms.Col R Q F) /\ (euclidean__axioms.Col Q F R))))) as H39.
----------------------------- apply (@lemma__collinearorder.lemma__collinearorder R F Q H38).
----------------------------- destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
exact H46.
---------------------------- exact H39.
------------------- assert (* Cut *) (euclidean__axioms.Col R Q F) as H31.
-------------------- apply (@euclidean__tactics.not__nCol__Col R Q F).
---------------------intro H31.
apply (@euclidean__tactics.Col__nCol__False R Q F H31).
----------------------apply (@lemma__collinear4.lemma__collinear4 B R Q F H26 H27 H30).

-------------------- exact H31.
----------------- assert (* Cut *) (euclidean__axioms.Col F Q R) as H29.
------------------ assert (* Cut *) ((euclidean__axioms.Col Q R F) /\ ((euclidean__axioms.Col Q F R) /\ ((euclidean__axioms.Col F R Q) /\ ((euclidean__axioms.Col R F Q) /\ (euclidean__axioms.Col F Q R))))) as H29.
------------------- apply (@lemma__collinearorder.lemma__collinearorder R Q F H28).
------------------- destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
exact H37.
------------------ assert (* Cut *) (euclidean__axioms.Col C F Q) as H30.
------------------- right.
right.
right.
right.
left.
exact H12.
------------------- assert (* Cut *) (euclidean__axioms.Col F Q C) as H31.
-------------------- assert (* Cut *) ((euclidean__axioms.Col F C Q) /\ ((euclidean__axioms.Col F Q C) /\ ((euclidean__axioms.Col Q C F) /\ ((euclidean__axioms.Col C Q F) /\ (euclidean__axioms.Col Q F C))))) as H31.
--------------------- apply (@lemma__collinearorder.lemma__collinearorder C F Q H30).
--------------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
exact H34.
-------------------- assert (* Cut *) (euclidean__axioms.neq F Q) as H32.
--------------------- assert (* Cut *) ((euclidean__axioms.neq F Q) /\ ((euclidean__axioms.neq C F) /\ (euclidean__axioms.neq C Q))) as H32.
---------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C F Q H12).
---------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
exact H33.
--------------------- assert (* Cut *) (euclidean__axioms.Col Q R C) as H33.
---------------------- apply (@euclidean__tactics.not__nCol__Col Q R C).
-----------------------intro H33.
apply (@euclidean__tactics.Col__nCol__False Q R C H33).
------------------------apply (@lemma__collinear4.lemma__collinear4 F Q R C H29 H31 H32).

---------------------- assert (* Cut *) (euclidean__axioms.Col R Q C) as H34.
----------------------- assert (* Cut *) ((euclidean__axioms.Col R Q C) /\ ((euclidean__axioms.Col R C Q) /\ ((euclidean__axioms.Col C Q R) /\ ((euclidean__axioms.Col Q C R) /\ (euclidean__axioms.Col C R Q))))) as H34.
------------------------ apply (@lemma__collinearorder.lemma__collinearorder Q R C H33).
------------------------ destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H35.
----------------------- assert (* Cut *) (euclidean__axioms.Col R Q P) as H35.
------------------------ right.
right.
right.
right.
left.
exact H0.
------------------------ assert (* Cut *) (euclidean__axioms.Col Q R C) as H36.
------------------------- assert (* Cut *) ((euclidean__axioms.Col Q R P) /\ ((euclidean__axioms.Col Q P R) /\ ((euclidean__axioms.Col P R Q) /\ ((euclidean__axioms.Col R P Q) /\ (euclidean__axioms.Col P Q R))))) as H36.
-------------------------- apply (@lemma__collinearorder.lemma__collinearorder R Q P H35).
-------------------------- destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
exact H33.
------------------------- assert (* Cut *) (euclidean__axioms.Col Q R P) as H37.
-------------------------- assert (* Cut *) ((euclidean__axioms.Col Q R P) /\ ((euclidean__axioms.Col Q P R) /\ ((euclidean__axioms.Col P R Q) /\ ((euclidean__axioms.Col R P Q) /\ (euclidean__axioms.Col P Q R))))) as H37.
--------------------------- apply (@lemma__collinearorder.lemma__collinearorder R Q P H35).
--------------------------- destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
exact H38.
-------------------------- assert (* Cut *) (euclidean__axioms.neq R Q) as H38.
--------------------------- assert (* Cut *) ((euclidean__axioms.neq Q P) /\ ((euclidean__axioms.neq R Q) /\ (euclidean__axioms.neq R P))) as H38.
---------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal R Q P H0).
---------------------------- destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H41.
--------------------------- assert (* Cut *) (euclidean__axioms.neq Q R) as H39.
---------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric R Q H38).
---------------------------- assert (* Cut *) (euclidean__axioms.Col R C P) as H40.
----------------------------- apply (@euclidean__tactics.not__nCol__Col R C P).
------------------------------intro H40.
apply (@euclidean__tactics.Col__nCol__False R C P H40).
-------------------------------apply (@lemma__collinear4.lemma__collinear4 Q R C P H36 H37 H39).

----------------------------- assert (* Cut *) (euclidean__axioms.Col C P R) as H41.
------------------------------ assert (* Cut *) ((euclidean__axioms.Col C R P) /\ ((euclidean__axioms.Col C P R) /\ ((euclidean__axioms.Col P R C) /\ ((euclidean__axioms.Col R P C) /\ (euclidean__axioms.Col P C R))))) as H41.
------------------------------- apply (@lemma__collinearorder.lemma__collinearorder R C P H40).
------------------------------- destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H44.
------------------------------ apply (@euclidean__tactics.Col__nCol__False A B P H8).
-------------------------------apply (@euclidean__tactics.not__nCol__Col A B P).
--------------------------------intro H42.
apply (@euclidean__tactics.Col__nCol__False C P R H1 H41).

------------- assert (* Cut *) (euclidean__axioms.BetS Q F C) as H25.
-------------- apply (@euclidean__axioms.axiom__betweennesssymmetry C F Q H12).
-------------- assert (* Cut *) (euclidean__axioms.TS Q A B C) as H26.
--------------- exists F.
split.
---------------- exact H25.
---------------- split.
----------------- exact H23.
----------------- apply (@euclidean__tactics.nCol__notCol A B Q H24).
--------------- exact H26.
Qed.


From SyDPaCC.Tree Require Import
     Skeletons Closure BTree.
From SyDPaCC.Bsml Require Import Model.Core Model.Pid Skeletons.StdLib.
From SyDPaCC.Core Require Import Bmf Parallelization.
Require Import Lia NArith.

Open Scope N_scope.

Module Make (Import Bsml : SyDPaCC.Bsml.Model.Core.BSML).

  Module Pid := Pid.Make Bsml.Bsp.
  Module StdLib := StdLib.Make Bsml Pid.
  Module Import Skel := Tree.Skeletons.Make Bsml.

  (* Set functions for the application of map *)
  Definition kL_h {A} (x:A) := 1.
  Definition kN_h {B} (x:B) := exist _ 1 (eq_refl 1) .

  (* Set functions for the application of reduce *)
  Definition k_h : (N * {x : N | 1 = x} * N) -> N := fun t => match t with (l,b,r) => 1 + (N.max l r) end.
  Definition phi_h : {x : N | 1 = x} -> (N * N) := fun x => (0, (proj1_sig x)).
  Definition psiN_h : (N * (N * N) * N) -> N := fun t =>
                                                 match t with
                                                 | (l,(b1,b2),r) => N.max b1 (N.max (b2 + l) (b2 + r))
                                                 end.
  Definition psiL_h : (N * N) * (N * N) * N -> (N * N) :=
    fun t =>
      match t with
      | ((l1, l2),(b1,b2), r) => ((N.max b1 (N.max (b2 + l1) (b2 + r))), b2 + l2)
      end.
  Definition psiR_h : N * (N * N) * (N * N) -> (N * N) :=
    fun t =>
      match t with
      | (l, (b1, b2), (r1,r2)) => ((N.max b1 (N.max (b2 + l) (b2 + r1))), b2 + r2)
      end.

  #[local] Instance h_closure : ClosureU k_h phi_h psiN_h psiL_h psiR_h.
  Proof.
    constructor.
    split.
    - intros l b r. unfold psiN_h, phi_h, k_h.
      rewrite N.add_max_distr_l, N.max_0_l.
      destruct b as [b Hb]. subst. trivial.
    - unfold psiN_h, psiL_h, psiR_h, phi_h, k_h. split.
      + intros x l y b r;
          destruct b as [b1 b2]; destruct l as [l1 l2].
        lia.
      + intros x l y b r;
          destruct b as [b1 b2]; destruct r as [r1 r2].
        lia.
  Qed.

  Open Scope sydpacc_scope.

  Definition spec_height {A B} : BTree.t A B -> option N :=
    (Some ∘ (BTree.reduce k_h)) ∘ (BTree.map kL_h kN_h).

  Typeclasses eauto := (bfs).

  Definition height {A B} : PLTree A B -> option N :=
    Eval sydpacc in
    parallel(spec_height).

  Close Scope sydpacc_scope.

End Make.

Close Scope N_scope.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B T P : Universe, ((wd_ A B /\ (col_ A B P /\ (col_ A B T /\ col_ T P A))) -> col_ T P B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e489m21_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.