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 lc_ott.

Local Set Warnings "-non-recursive".

(** 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 tm_ind' := Induction for tm Sort Prop.

Combined Scheme tm_mutind from tm_ind'.

Scheme tm_rec' := Induction for tm Sort Set.

Combined Scheme tm_mutrec from tm_rec'.

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

Fixpoint close_tm_wrt_tm_rec (n1 : nat) (x1 : tmvar) (t1 : tm) {struct t1} : tm :=
  match t1 with
    | var_f x2 => if (x1 == x2) then (var_b n1) else (var_f x2)
    | var_b n2 => if (lt_ge_dec n2 n1) then (var_b n2) else (var_b (S n2))
    | abs t2 => abs (close_tm_wrt_tm_rec (S n1) x1 t2)
    | app t2 u1 => app (close_tm_wrt_tm_rec n1 x1 t2) (close_tm_wrt_tm_rec n1 x1 u1)
  end.

Definition close_tm_wrt_tm x1 t1 := close_tm_wrt_tm_rec 0 x1 t1.

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

Fixpoint size_tm (t1 : tm) {struct t1} : nat :=
  match t1 with
    | var_f x1 => 1
    | var_b n1 => 1
    | abs t2 => 1 + (size_tm t2)
    | app t2 u1 => 1 + (size_tm t2) + (size_tm u1)
  end.

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

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

Inductive degree_tm_wrt_tm : nat -> tm -> Prop :=
  | degree_wrt_tm_var_f : forall n1 x1,
    degree_tm_wrt_tm n1 (var_f x1)
  | degree_wrt_tm_var_b : forall n1 n2,
    lt n2 n1 ->
    degree_tm_wrt_tm n1 (var_b n2)
  | degree_wrt_tm_abs : forall n1 t1,
    degree_tm_wrt_tm (S n1) t1 ->
    degree_tm_wrt_tm n1 (abs t1)
  | degree_wrt_tm_app : forall n1 t1 u1,
    degree_tm_wrt_tm n1 t1 ->
    degree_tm_wrt_tm n1 u1 ->
    degree_tm_wrt_tm n1 (app t1 u1).

Scheme degree_tm_wrt_tm_ind' := Induction for degree_tm_wrt_tm Sort Prop.

Combined Scheme degree_tm_wrt_tm_mutind from degree_tm_wrt_tm_ind'.

#[export] Hint Constructors degree_tm_wrt_tm : core lngen.

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

Inductive lc_set_tm : tm -> Set :=
  | lc_set_var_f : forall x1,
    lc_set_tm (var_f x1)
  | lc_set_abs : forall t1,
    (forall x1 : tmvar, lc_set_tm (open_tm_wrt_tm t1 (var_f x1))) ->
    lc_set_tm (abs t1)
  | lc_set_app : forall t1 u1,
    lc_set_tm t1 ->
    lc_set_tm u1 ->
    lc_set_tm (app t1 u1).

Scheme lc_tm_ind' := Induction for lc_tm Sort Prop.

Combined Scheme lc_tm_mutind from lc_tm_ind'.

Scheme lc_set_tm_ind' := Induction for lc_set_tm Sort Prop.

Combined Scheme lc_set_tm_mutind from lc_set_tm_ind'.

Scheme lc_set_tm_rec' := Induction for lc_set_tm Sort Set.

Combined Scheme lc_set_tm_mutrec from lc_set_tm_rec'.

#[export] Hint Constructors lc_tm : core lngen.

#[export] Hint Constructors lc_set_tm : core lngen.

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

Definition body_tm_wrt_tm t1 := forall x1, lc_tm (open_tm_wrt_tm t1 (var_f x1)).

#[export] Hint Unfold body_tm_wrt_tm : core.

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

(** Additional hint declarations. *)

#[export] 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_tm_min_mutual :
(forall t1, 1 <= size_tm t1).
Proof. Admitted.

(* end hide *)

Lemma size_tm_min :
forall t1, 1 <= size_tm t1.
Proof. Admitted.

#[export] Hint Resolve size_tm_min : lngen.

(* begin hide *)

Lemma size_tm_close_tm_wrt_tm_rec_mutual :
(forall t1 x1 n1,
  size_tm (close_tm_wrt_tm_rec n1 x1 t1) = size_tm t1).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma size_tm_close_tm_wrt_tm_rec :
forall t1 x1 n1,
  size_tm (close_tm_wrt_tm_rec n1 x1 t1) = size_tm t1.
Proof. Admitted.

#[export] Hint Resolve size_tm_close_tm_wrt_tm_rec : lngen.
#[export] Hint Rewrite size_tm_close_tm_wrt_tm_rec using solve [auto] : lngen.

(* end hide *)

Lemma size_tm_close_tm_wrt_tm :
forall t1 x1,
  size_tm (close_tm_wrt_tm x1 t1) = size_tm t1.
Proof. Admitted.

#[export] Hint Resolve size_tm_close_tm_wrt_tm : lngen.
#[export] Hint Rewrite size_tm_close_tm_wrt_tm using solve [auto] : lngen.

(* begin hide *)

Lemma size_tm_open_tm_wrt_tm_rec_mutual :
(forall t1 t2 n1,
  size_tm t1 <= size_tm (open_tm_wrt_tm_rec n1 t2 t1)).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma size_tm_open_tm_wrt_tm_rec :
forall t1 t2 n1,
  size_tm t1 <= size_tm (open_tm_wrt_tm_rec n1 t2 t1).
Proof. Admitted.

#[export] Hint Resolve size_tm_open_tm_wrt_tm_rec : lngen.

(* end hide *)

Lemma size_tm_open_tm_wrt_tm :
forall t1 t2,
  size_tm t1 <= size_tm (open_tm_wrt_tm t1 t2).
Proof. Admitted.

#[export] Hint Resolve size_tm_open_tm_wrt_tm : lngen.

(* begin hide *)

Lemma size_tm_open_tm_wrt_tm_rec_var_mutual :
(forall t1 x1 n1,
  size_tm (open_tm_wrt_tm_rec n1 (var_f x1) t1) = size_tm t1).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma size_tm_open_tm_wrt_tm_rec_var :
forall t1 x1 n1,
  size_tm (open_tm_wrt_tm_rec n1 (var_f x1) t1) = size_tm t1.
Proof. Admitted.

#[export] Hint Resolve size_tm_open_tm_wrt_tm_rec_var : lngen.
#[export] Hint Rewrite size_tm_open_tm_wrt_tm_rec_var using solve [auto] : lngen.

(* end hide *)

Lemma size_tm_open_tm_wrt_tm_var :
forall t1 x1,
  size_tm (open_tm_wrt_tm t1 (var_f x1)) = size_tm t1.
Proof. Admitted.

#[export] Hint Resolve size_tm_open_tm_wrt_tm_var : lngen.
#[export] Hint Rewrite size_tm_open_tm_wrt_tm_var using solve [auto] : lngen.

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

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

(* begin hide *)

Lemma degree_tm_wrt_tm_S_mutual :
(forall n1 t1,
  degree_tm_wrt_tm n1 t1 ->
  degree_tm_wrt_tm (S n1) t1).
Proof. Admitted.

(* end hide *)

Lemma degree_tm_wrt_tm_S :
forall n1 t1,
  degree_tm_wrt_tm n1 t1 ->
  degree_tm_wrt_tm (S n1) t1.
Proof. Admitted.

#[export] Hint Resolve degree_tm_wrt_tm_S : lngen.

Lemma degree_tm_wrt_tm_O :
forall n1 t1,
  degree_tm_wrt_tm O t1 ->
  degree_tm_wrt_tm n1 t1.
Proof. Admitted.

#[export] Hint Resolve degree_tm_wrt_tm_O : lngen.

(* begin hide *)

Lemma degree_tm_wrt_tm_close_tm_wrt_tm_rec_mutual :
(forall t1 x1 n1,
  degree_tm_wrt_tm n1 t1 ->
  degree_tm_wrt_tm (S n1) (close_tm_wrt_tm_rec n1 x1 t1)).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma degree_tm_wrt_tm_close_tm_wrt_tm_rec :
forall t1 x1 n1,
  degree_tm_wrt_tm n1 t1 ->
  degree_tm_wrt_tm (S n1) (close_tm_wrt_tm_rec n1 x1 t1).
Proof. Admitted.

#[export] Hint Resolve degree_tm_wrt_tm_close_tm_wrt_tm_rec : lngen.

(* end hide *)

Lemma degree_tm_wrt_tm_close_tm_wrt_tm :
forall t1 x1,
  degree_tm_wrt_tm 0 t1 ->
  degree_tm_wrt_tm 1 (close_tm_wrt_tm x1 t1).
Proof. Admitted.

#[export] Hint Resolve degree_tm_wrt_tm_close_tm_wrt_tm : lngen.

(* begin hide *)

Lemma degree_tm_wrt_tm_close_tm_wrt_tm_rec_inv_mutual :
(forall t1 x1 n1,
  degree_tm_wrt_tm (S n1) (close_tm_wrt_tm_rec n1 x1 t1) ->
  degree_tm_wrt_tm n1 t1).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma degree_tm_wrt_tm_close_tm_wrt_tm_rec_inv :
forall t1 x1 n1,
  degree_tm_wrt_tm (S n1) (close_tm_wrt_tm_rec n1 x1 t1) ->
  degree_tm_wrt_tm n1 t1.
Proof. Admitted.

#[export] Hint Immediate degree_tm_wrt_tm_close_tm_wrt_tm_rec_inv : lngen.

(* end hide *)

Lemma degree_tm_wrt_tm_close_tm_wrt_tm_inv :
forall t1 x1,
  degree_tm_wrt_tm 1 (close_tm_wrt_tm x1 t1) ->
  degree_tm_wrt_tm 0 t1.
Proof. Admitted.

#[export] Hint Immediate degree_tm_wrt_tm_close_tm_wrt_tm_inv : lngen.

(* begin hide *)

Lemma degree_tm_wrt_tm_open_tm_wrt_tm_rec_mutual :
(forall t1 t2 n1,
  degree_tm_wrt_tm (S n1) t1 ->
  degree_tm_wrt_tm n1 t2 ->
  degree_tm_wrt_tm n1 (open_tm_wrt_tm_rec n1 t2 t1)).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma degree_tm_wrt_tm_open_tm_wrt_tm_rec :
forall t1 t2 n1,
  degree_tm_wrt_tm (S n1) t1 ->
  degree_tm_wrt_tm n1 t2 ->
  degree_tm_wrt_tm n1 (open_tm_wrt_tm_rec n1 t2 t1).
Proof. Admitted.

#[export] Hint Resolve degree_tm_wrt_tm_open_tm_wrt_tm_rec : lngen.

(* end hide *)

Lemma degree_tm_wrt_tm_open_tm_wrt_tm :
forall t1 t2,
  degree_tm_wrt_tm 1 t1 ->
  degree_tm_wrt_tm 0 t2 ->
  degree_tm_wrt_tm 0 (open_tm_wrt_tm t1 t2).
Proof. Admitted.

#[export] Hint Resolve degree_tm_wrt_tm_open_tm_wrt_tm : lngen.

(* begin hide *)

Lemma degree_tm_wrt_tm_open_tm_wrt_tm_rec_inv_mutual :
(forall t1 t2 n1,
  degree_tm_wrt_tm n1 (open_tm_wrt_tm_rec n1 t2 t1) ->
  degree_tm_wrt_tm (S n1) t1).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma degree_tm_wrt_tm_open_tm_wrt_tm_rec_inv :
forall t1 t2 n1,
  degree_tm_wrt_tm n1 (open_tm_wrt_tm_rec n1 t2 t1) ->
  degree_tm_wrt_tm (S n1) t1.
Proof. Admitted.

#[export] Hint Immediate degree_tm_wrt_tm_open_tm_wrt_tm_rec_inv : lngen.

(* end hide *)

Lemma degree_tm_wrt_tm_open_tm_wrt_tm_inv :
forall t1 t2,
  degree_tm_wrt_tm 0 (open_tm_wrt_tm t1 t2) ->
  degree_tm_wrt_tm 1 t1.
Proof. Admitted.

#[export] Hint Immediate degree_tm_wrt_tm_open_tm_wrt_tm_inv : lngen.

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

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

(* begin hide *)

Lemma close_tm_wrt_tm_rec_inj_mutual :
(forall t1 t2 x1 n1,
  close_tm_wrt_tm_rec n1 x1 t1 = close_tm_wrt_tm_rec n1 x1 t2 ->
  t1 = t2).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma close_tm_wrt_tm_rec_inj :
forall t1 t2 x1 n1,
  close_tm_wrt_tm_rec n1 x1 t1 = close_tm_wrt_tm_rec n1 x1 t2 ->
  t1 = t2.
Proof. Admitted.

#[export] Hint Immediate close_tm_wrt_tm_rec_inj : lngen.

(* end hide *)

Lemma close_tm_wrt_tm_inj :
forall t1 t2 x1,
  close_tm_wrt_tm x1 t1 = close_tm_wrt_tm x1 t2 ->
  t1 = t2.
Proof. Admitted.

#[export] Hint Immediate close_tm_wrt_tm_inj : lngen.

(* begin hide *)

Lemma close_tm_wrt_tm_rec_open_tm_wrt_tm_rec_mutual :
(forall t1 x1 n1,
  x1 `notin` fv_tm t1 ->
  close_tm_wrt_tm_rec n1 x1 (open_tm_wrt_tm_rec n1 (var_f x1) t1) = t1).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma close_tm_wrt_tm_rec_open_tm_wrt_tm_rec :
forall t1 x1 n1,
  x1 `notin` fv_tm t1 ->
  close_tm_wrt_tm_rec n1 x1 (open_tm_wrt_tm_rec n1 (var_f x1) t1) = t1.
Proof. Admitted.

#[export] Hint Resolve close_tm_wrt_tm_rec_open_tm_wrt_tm_rec : lngen.
#[export] Hint Rewrite close_tm_wrt_tm_rec_open_tm_wrt_tm_rec using solve [auto] : lngen.

(* end hide *)

Lemma close_tm_wrt_tm_open_tm_wrt_tm :
forall t1 x1,
  x1 `notin` fv_tm t1 ->
  close_tm_wrt_tm x1 (open_tm_wrt_tm t1 (var_f x1)) = t1.
Proof. Admitted.

#[export] Hint Resolve close_tm_wrt_tm_open_tm_wrt_tm : lngen.
#[export] Hint Rewrite close_tm_wrt_tm_open_tm_wrt_tm using solve [auto] : lngen.

(* begin hide *)

Lemma open_tm_wrt_tm_rec_close_tm_wrt_tm_rec_mutual :
(forall t1 x1 n1,
  open_tm_wrt_tm_rec n1 (var_f x1) (close_tm_wrt_tm_rec n1 x1 t1) = t1).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma open_tm_wrt_tm_rec_close_tm_wrt_tm_rec :
forall t1 x1 n1,
  open_tm_wrt_tm_rec n1 (var_f x1) (close_tm_wrt_tm_rec n1 x1 t1) = t1.
Proof. Admitted.

#[export] Hint Resolve open_tm_wrt_tm_rec_close_tm_wrt_tm_rec : lngen.
#[export] Hint Rewrite open_tm_wrt_tm_rec_close_tm_wrt_tm_rec using solve [auto] : lngen.

(* end hide *)

Lemma open_tm_wrt_tm_close_tm_wrt_tm :
forall t1 x1,
  open_tm_wrt_tm (close_tm_wrt_tm x1 t1) (var_f x1) = t1.
Proof. Admitted.

#[export] Hint Resolve open_tm_wrt_tm_close_tm_wrt_tm : lngen.
#[export] Hint Rewrite open_tm_wrt_tm_close_tm_wrt_tm using solve [auto] : lngen.

(* begin hide *)

Lemma open_tm_wrt_tm_rec_inj_mutual :
(forall t2 t1 x1 n1,
  x1 `notin` fv_tm t2 ->
  x1 `notin` fv_tm t1 ->
  open_tm_wrt_tm_rec n1 (var_f x1) t2 = open_tm_wrt_tm_rec n1 (var_f x1) t1 ->
  t2 = t1).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma open_tm_wrt_tm_rec_inj :
forall t2 t1 x1 n1,
  x1 `notin` fv_tm t2 ->
  x1 `notin` fv_tm t1 ->
  open_tm_wrt_tm_rec n1 (var_f x1) t2 = open_tm_wrt_tm_rec n1 (var_f x1) t1 ->
  t2 = t1.
Proof. Admitted.

#[export] Hint Immediate open_tm_wrt_tm_rec_inj : lngen.

(* end hide *)

Lemma open_tm_wrt_tm_inj :
forall t2 t1 x1,
  x1 `notin` fv_tm t2 ->
  x1 `notin` fv_tm t1 ->
  open_tm_wrt_tm t2 (var_f x1) = open_tm_wrt_tm t1 (var_f x1) ->
  t2 = t1.
Proof. Admitted.

#[export] Hint Immediate open_tm_wrt_tm_inj : lngen.

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

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

(* begin hide *)

Lemma degree_tm_wrt_tm_of_lc_tm_mutual :
(forall t1,
  lc_tm t1 ->
  degree_tm_wrt_tm 0 t1).
Proof. Admitted.

(* end hide *)

Lemma degree_tm_wrt_tm_of_lc_tm :
forall t1,
  lc_tm t1 ->
  degree_tm_wrt_tm 0 t1.
Proof. Admitted.

#[export] Hint Resolve degree_tm_wrt_tm_of_lc_tm : lngen.

(* begin hide *)

Lemma lc_tm_of_degree_size_mutual :
forall i1,
(forall t1,
  size_tm t1 = i1 ->
  degree_tm_wrt_tm 0 t1 ->
  lc_tm t1).
Proof. Admitted.

(* end hide *)

Lemma lc_tm_of_degree :
forall t1,
  degree_tm_wrt_tm 0 t1 ->
  lc_tm t1.
Proof. Admitted.

#[export] Hint Resolve lc_tm_of_degree : lngen.

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

Lemma lc_abs_exists :
forall x1 t1,
  lc_tm (open_tm_wrt_tm t1 (var_f x1)) ->
  lc_tm (abs t1).
Proof. Admitted.

#[export] Hint Extern 1 (lc_tm (abs _)) =>
  let x1 := fresh in
  pick_fresh x1;
  apply (lc_abs_exists x1) : core.

Lemma lc_body_tm_wrt_tm :
forall t1 t2,
  body_tm_wrt_tm t1 ->
  lc_tm t2 ->
  lc_tm (open_tm_wrt_tm t1 t2).
Proof. Admitted.

#[export] Hint Resolve lc_body_tm_wrt_tm : lngen.

Lemma lc_body_abs_1 :
forall t1,
  lc_tm (abs t1) ->
  body_tm_wrt_tm t1.
Proof. Admitted.

#[export] Hint Resolve lc_body_abs_1 : lngen.

(* begin hide *)

Lemma lc_tm_unique_mutual :
(forall t1 (proof2 proof3 : lc_tm t1), proof2 = proof3).
Proof. Admitted.

(* end hide *)

Lemma lc_tm_unique :
forall t1 (proof2 proof3 : lc_tm t1), proof2 = proof3.
Proof. Admitted.

#[export] Hint Resolve lc_tm_unique : lngen.

(* begin hide *)

Lemma lc_tm_of_lc_set_tm_mutual :
(forall t1, lc_set_tm t1 -> lc_tm t1).
Proof. Admitted.

(* end hide *)

Lemma lc_tm_of_lc_set_tm :
forall t1, lc_set_tm t1 -> lc_tm t1.
Proof. Admitted.

#[export] Hint Resolve lc_tm_of_lc_set_tm : lngen.

(* begin hide *)

Lemma lc_set_tm_of_lc_tm_size_mutual :
forall i1,
(forall t1,
  size_tm t1 = i1 ->
  lc_tm t1 ->
  lc_set_tm t1).
Proof. Admitted.

(* end hide *)

Lemma lc_set_tm_of_lc_tm :
forall t1,
  lc_tm t1 ->
  lc_set_tm t1.
Proof. Admitted.

#[export] Hint Resolve lc_set_tm_of_lc_tm : lngen.

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

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

(* begin hide *)

Lemma close_tm_wrt_tm_rec_degree_tm_wrt_tm_mutual :
(forall t1 x1 n1,
  degree_tm_wrt_tm n1 t1 ->
  x1 `notin` fv_tm t1 ->
  close_tm_wrt_tm_rec n1 x1 t1 = t1).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma close_tm_wrt_tm_rec_degree_tm_wrt_tm :
forall t1 x1 n1,
  degree_tm_wrt_tm n1 t1 ->
  x1 `notin` fv_tm t1 ->
  close_tm_wrt_tm_rec n1 x1 t1 = t1.
Proof. Admitted.

#[export] Hint Resolve close_tm_wrt_tm_rec_degree_tm_wrt_tm : lngen.
#[export] Hint Rewrite close_tm_wrt_tm_rec_degree_tm_wrt_tm using solve [auto] : lngen.

(* end hide *)

Lemma close_tm_wrt_tm_lc_tm :
forall t1 x1,
  lc_tm t1 ->
  x1 `notin` fv_tm t1 ->
  close_tm_wrt_tm x1 t1 = t1.
Proof. Admitted.

#[export] Hint Resolve close_tm_wrt_tm_lc_tm : lngen.
#[export] Hint Rewrite close_tm_wrt_tm_lc_tm using solve [auto] : lngen.

(* begin hide *)

Lemma open_tm_wrt_tm_rec_degree_tm_wrt_tm_mutual :
(forall t2 t1 n1,
  degree_tm_wrt_tm n1 t2 ->
  open_tm_wrt_tm_rec n1 t1 t2 = t2).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma open_tm_wrt_tm_rec_degree_tm_wrt_tm :
forall t2 t1 n1,
  degree_tm_wrt_tm n1 t2 ->
  open_tm_wrt_tm_rec n1 t1 t2 = t2.
Proof. Admitted.

#[export] Hint Resolve open_tm_wrt_tm_rec_degree_tm_wrt_tm : lngen.
#[export] Hint Rewrite open_tm_wrt_tm_rec_degree_tm_wrt_tm using solve [auto] : lngen.

(* end hide *)

Lemma open_tm_wrt_tm_lc_tm :
forall t2 t1,
  lc_tm t2 ->
  open_tm_wrt_tm t2 t1 = t2.
Proof. Admitted.

#[export] Hint Resolve open_tm_wrt_tm_lc_tm : lngen.
#[export] Hint Rewrite open_tm_wrt_tm_lc_tm 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_tm_close_tm_wrt_tm_rec_mutual :
(forall t1 x1 n1,
  fv_tm (close_tm_wrt_tm_rec n1 x1 t1) [=] remove x1 (fv_tm t1)).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma fv_tm_close_tm_wrt_tm_rec :
forall t1 x1 n1,
  fv_tm (close_tm_wrt_tm_rec n1 x1 t1) [=] remove x1 (fv_tm t1).
Proof. Admitted.

#[export] Hint Resolve fv_tm_close_tm_wrt_tm_rec : lngen.
#[export] Hint Rewrite fv_tm_close_tm_wrt_tm_rec using solve [auto] : lngen.

(* end hide *)

Lemma fv_tm_close_tm_wrt_tm :
forall t1 x1,
  fv_tm (close_tm_wrt_tm x1 t1) [=] remove x1 (fv_tm t1).
Proof. Admitted.

#[export] Hint Resolve fv_tm_close_tm_wrt_tm : lngen.
#[export] Hint Rewrite fv_tm_close_tm_wrt_tm using solve [auto] : lngen.

(* begin hide *)

Lemma fv_tm_open_tm_wrt_tm_rec_lower_mutual :
(forall t1 t2 n1,
  fv_tm t1 [<=] fv_tm (open_tm_wrt_tm_rec n1 t2 t1)).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma fv_tm_open_tm_wrt_tm_rec_lower :
forall t1 t2 n1,
  fv_tm t1 [<=] fv_tm (open_tm_wrt_tm_rec n1 t2 t1).
Proof. Admitted.

#[export] Hint Resolve fv_tm_open_tm_wrt_tm_rec_lower : lngen.

(* end hide *)

Lemma fv_tm_open_tm_wrt_tm_lower :
forall t1 t2,
  fv_tm t1 [<=] fv_tm (open_tm_wrt_tm t1 t2).
Proof. Admitted.

#[export] Hint Resolve fv_tm_open_tm_wrt_tm_lower : lngen.

(* begin hide *)

Lemma fv_tm_open_tm_wrt_tm_rec_upper_mutual :
(forall t1 t2 n1,
  fv_tm (open_tm_wrt_tm_rec n1 t2 t1) [<=] fv_tm t2 `union` fv_tm t1).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma fv_tm_open_tm_wrt_tm_rec_upper :
forall t1 t2 n1,
  fv_tm (open_tm_wrt_tm_rec n1 t2 t1) [<=] fv_tm t2 `union` fv_tm t1.
Proof. Admitted.

#[export] Hint Resolve fv_tm_open_tm_wrt_tm_rec_upper : lngen.

(* end hide *)

Lemma fv_tm_open_tm_wrt_tm_upper :
forall t1 t2,
  fv_tm (open_tm_wrt_tm t1 t2) [<=] fv_tm t2 `union` fv_tm t1.
Proof. Admitted.

#[export] Hint Resolve fv_tm_open_tm_wrt_tm_upper : lngen.

(* begin hide *)

Lemma fv_tm_subst_tm_fresh_mutual :
(forall t1 t2 x1,
  x1 `notin` fv_tm t1 ->
  fv_tm (subst_tm t2 x1 t1) [=] fv_tm t1).
Proof. Admitted.

(* end hide *)

Lemma fv_tm_subst_tm_fresh :
forall t1 t2 x1,
  x1 `notin` fv_tm t1 ->
  fv_tm (subst_tm t2 x1 t1) [=] fv_tm t1.
Proof. Admitted.

#[export] Hint Resolve fv_tm_subst_tm_fresh : lngen.
#[export] Hint Rewrite fv_tm_subst_tm_fresh using solve [auto] : lngen.

(* begin hide *)

Lemma fv_tm_subst_tm_lower_mutual :
(forall t1 t2 x1,
  remove x1 (fv_tm t1) [<=] fv_tm (subst_tm t2 x1 t1)).
Proof. Admitted.

(* end hide *)

Lemma fv_tm_subst_tm_lower :
forall t1 t2 x1,
  remove x1 (fv_tm t1) [<=] fv_tm (subst_tm t2 x1 t1).
Proof. Admitted.

#[export] Hint Resolve fv_tm_subst_tm_lower : lngen.

(* begin hide *)

Lemma fv_tm_subst_tm_notin_mutual :
(forall t1 t2 x1 x2,
  x2 `notin` fv_tm t1 ->
  x2 `notin` fv_tm t2 ->
  x2 `notin` fv_tm (subst_tm t2 x1 t1)).
Proof. Admitted.

(* end hide *)

Lemma fv_tm_subst_tm_notin :
forall t1 t2 x1 x2,
  x2 `notin` fv_tm t1 ->
  x2 `notin` fv_tm t2 ->
  x2 `notin` fv_tm (subst_tm t2 x1 t1).
Proof. Admitted.

#[export] Hint Resolve fv_tm_subst_tm_notin : lngen.

(* begin hide *)

Lemma fv_tm_subst_tm_upper_mutual :
(forall t1 t2 x1,
  fv_tm (subst_tm t2 x1 t1) [<=] fv_tm t2 `union` remove x1 (fv_tm t1)).
Proof. Admitted.

(* end hide *)

Lemma fv_tm_subst_tm_upper :
forall t1 t2 x1,
  fv_tm (subst_tm t2 x1 t1) [<=] fv_tm t2 `union` remove x1 (fv_tm t1).
Proof. Admitted.

#[export] Hint Resolve fv_tm_subst_tm_upper : lngen.

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

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

(* begin hide *)

Lemma subst_tm_close_tm_wrt_tm_rec_mutual :
(forall t2 t1 x1 x2 n1,
  degree_tm_wrt_tm n1 t1 ->
  x1 <> x2 ->
  x2 `notin` fv_tm t1 ->
  subst_tm t1 x1 (close_tm_wrt_tm_rec n1 x2 t2) = close_tm_wrt_tm_rec n1 x2 (subst_tm t1 x1 t2)).
Proof. Admitted.

(* end hide *)

Lemma subst_tm_close_tm_wrt_tm_rec :
forall t2 t1 x1 x2 n1,
  degree_tm_wrt_tm n1 t1 ->
  x1 <> x2 ->
  x2 `notin` fv_tm t1 ->
  subst_tm t1 x1 (close_tm_wrt_tm_rec n1 x2 t2) = close_tm_wrt_tm_rec n1 x2 (subst_tm t1 x1 t2).
Proof. Admitted.

#[export] Hint Resolve subst_tm_close_tm_wrt_tm_rec : lngen.

Lemma subst_tm_close_tm_wrt_tm :
forall t2 t1 x1 x2,
  lc_tm t1 ->  x1 <> x2 ->
  x2 `notin` fv_tm t1 ->
  subst_tm t1 x1 (close_tm_wrt_tm x2 t2) = close_tm_wrt_tm x2 (subst_tm t1 x1 t2).
Proof. Admitted.

#[export] Hint Resolve subst_tm_close_tm_wrt_tm : lngen.

(* begin hide *)

Lemma subst_tm_degree_tm_wrt_tm_mutual :
(forall t1 t2 x1 n1,
  degree_tm_wrt_tm n1 t1 ->
  degree_tm_wrt_tm n1 t2 ->
  degree_tm_wrt_tm n1 (subst_tm t2 x1 t1)).
Proof. Admitted.

(* end hide *)

Lemma subst_tm_degree_tm_wrt_tm :
forall t1 t2 x1 n1,
  degree_tm_wrt_tm n1 t1 ->
  degree_tm_wrt_tm n1 t2 ->
  degree_tm_wrt_tm n1 (subst_tm t2 x1 t1).
Proof. Admitted.

#[export] Hint Resolve subst_tm_degree_tm_wrt_tm : lngen.

(* begin hide *)

Lemma subst_tm_fresh_eq_mutual :
(forall t2 t1 x1,
  x1 `notin` fv_tm t2 ->
  subst_tm t1 x1 t2 = t2).
Proof. Admitted.

(* end hide *)

Lemma subst_tm_fresh_eq :
forall t2 t1 x1,
  x1 `notin` fv_tm t2 ->
  subst_tm t1 x1 t2 = t2.
Proof. Admitted.

#[export] Hint Resolve subst_tm_fresh_eq : lngen.
#[export] Hint Rewrite subst_tm_fresh_eq using solve [auto] : lngen.

(* begin hide *)

Lemma subst_tm_fresh_same_mutual :
(forall t2 t1 x1,
  x1 `notin` fv_tm t1 ->
  x1 `notin` fv_tm (subst_tm t1 x1 t2)).
Proof. Admitted.

(* end hide *)

Lemma subst_tm_fresh_same :
forall t2 t1 x1,
  x1 `notin` fv_tm t1 ->
  x1 `notin` fv_tm (subst_tm t1 x1 t2).
Proof. Admitted.

#[export] Hint Resolve subst_tm_fresh_same : lngen.

(* begin hide *)

Lemma subst_tm_fresh_mutual :
(forall t2 t1 x1 x2,
  x1 `notin` fv_tm t2 ->
  x1 `notin` fv_tm t1 ->
  x1 `notin` fv_tm (subst_tm t1 x2 t2)).
Proof. Admitted.

(* end hide *)

Lemma subst_tm_fresh :
forall t2 t1 x1 x2,
  x1 `notin` fv_tm t2 ->
  x1 `notin` fv_tm t1 ->
  x1 `notin` fv_tm (subst_tm t1 x2 t2).
Proof. Admitted.

#[export] Hint Resolve subst_tm_fresh : lngen.

Lemma subst_tm_lc_tm :
forall t1 t2 x1,
  lc_tm t1 ->
  lc_tm t2 ->
  lc_tm (subst_tm t2 x1 t1).
Proof. Admitted.

#[export] Hint Resolve subst_tm_lc_tm : lngen.

(* begin hide *)

Lemma subst_tm_open_tm_wrt_tm_rec_mutual :
(forall t3 t1 t2 x1 n1,
  lc_tm t1 ->
  subst_tm t1 x1 (open_tm_wrt_tm_rec n1 t2 t3) = open_tm_wrt_tm_rec n1 (subst_tm t1 x1 t2) (subst_tm t1 x1 t3)).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma subst_tm_open_tm_wrt_tm_rec :
forall t3 t1 t2 x1 n1,
  lc_tm t1 ->
  subst_tm t1 x1 (open_tm_wrt_tm_rec n1 t2 t3) = open_tm_wrt_tm_rec n1 (subst_tm t1 x1 t2) (subst_tm t1 x1 t3).
Proof. Admitted.

#[export] Hint Resolve subst_tm_open_tm_wrt_tm_rec : lngen.

(* end hide *)

Lemma subst_tm_open_tm_wrt_tm :
forall t3 t1 t2 x1,
  lc_tm t1 ->
  subst_tm t1 x1 (open_tm_wrt_tm t3 t2) = open_tm_wrt_tm (subst_tm t1 x1 t3) (subst_tm t1 x1 t2).
Proof. Admitted.

#[export] Hint Resolve subst_tm_open_tm_wrt_tm : lngen.

Lemma subst_tm_open_tm_wrt_tm_var :
forall t2 t1 x1 x2,
  x1 <> x2 ->
  lc_tm t1 ->
  open_tm_wrt_tm (subst_tm t1 x1 t2) (var_f x2) = subst_tm t1 x1 (open_tm_wrt_tm t2 (var_f x2)).
Proof. Admitted.

#[export] Hint Resolve subst_tm_open_tm_wrt_tm_var : lngen.

(* begin hide *)

Lemma subst_tm_spec_rec_mutual :
(forall t1 t2 x1 n1,
  subst_tm t2 x1 t1 = open_tm_wrt_tm_rec n1 t2 (close_tm_wrt_tm_rec n1 x1 t1)).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma subst_tm_spec_rec :
forall t1 t2 x1 n1,
  subst_tm t2 x1 t1 = open_tm_wrt_tm_rec n1 t2 (close_tm_wrt_tm_rec n1 x1 t1).
Proof. Admitted.

#[export] Hint Resolve subst_tm_spec_rec : lngen.

(* end hide *)

Lemma subst_tm_spec :
forall t1 t2 x1,
  subst_tm t2 x1 t1 = open_tm_wrt_tm (close_tm_wrt_tm x1 t1) t2.
Proof. Admitted.

#[export] Hint Resolve subst_tm_spec : lngen.

(* begin hide *)

Lemma subst_tm_subst_tm_mutual :
(forall t1 t2 t3 x2 x1,
  x2 `notin` fv_tm t2 ->
  x2 <> x1 ->
  subst_tm t2 x1 (subst_tm t3 x2 t1) = subst_tm (subst_tm t2 x1 t3) x2 (subst_tm t2 x1 t1)).
Proof. Admitted.

(* end hide *)

Lemma subst_tm_subst_tm :
forall t1 t2 t3 x2 x1,
  x2 `notin` fv_tm t2 ->
  x2 <> x1 ->
  subst_tm t2 x1 (subst_tm t3 x2 t1) = subst_tm (subst_tm t2 x1 t3) x2 (subst_tm t2 x1 t1).
Proof. Admitted.

#[export] Hint Resolve subst_tm_subst_tm : lngen.

(* begin hide *)

Lemma subst_tm_close_tm_wrt_tm_rec_open_tm_wrt_tm_rec_mutual :
(forall t2 t1 x1 x2 n1,
  x2 `notin` fv_tm t2 ->
  x2 `notin` fv_tm t1 ->
  x2 <> x1 ->
  degree_tm_wrt_tm n1 t1 ->
  subst_tm t1 x1 t2 = close_tm_wrt_tm_rec n1 x2 (subst_tm t1 x1 (open_tm_wrt_tm_rec n1 (var_f x2) t2))).
Proof. Admitted.

(* end hide *)

(* begin hide *)

Lemma subst_tm_close_tm_wrt_tm_rec_open_tm_wrt_tm_rec :
forall t2 t1 x1 x2 n1,
  x2 `notin` fv_tm t2 ->
  x2 `notin` fv_tm t1 ->
  x2 <> x1 ->
  degree_tm_wrt_tm n1 t1 ->
  subst_tm t1 x1 t2 = close_tm_wrt_tm_rec n1 x2 (subst_tm t1 x1 (open_tm_wrt_tm_rec n1 (var_f x2) t2)).
Proof. Admitted.

#[export] Hint Resolve subst_tm_close_tm_wrt_tm_rec_open_tm_wrt_tm_rec : lngen.

(* end hide *)

Lemma subst_tm_close_tm_wrt_tm_open_tm_wrt_tm :
forall t2 t1 x1 x2,
  x2 `notin` fv_tm t2 ->
  x2 `notin` fv_tm t1 ->
  x2 <> x1 ->
  lc_tm t1 ->
  subst_tm t1 x1 t2 = close_tm_wrt_tm x2 (subst_tm t1 x1 (open_tm_wrt_tm t2 (var_f x2))).
Proof. Admitted.

#[export] Hint Resolve subst_tm_close_tm_wrt_tm_open_tm_wrt_tm : lngen.

Lemma subst_tm_abs :
forall x2 t2 t1 x1,
  lc_tm t1 ->
  x2 `notin` fv_tm t1 `union` fv_tm t2 `union` singleton x1 ->
  subst_tm t1 x1 (abs t2) = abs (close_tm_wrt_tm x2 (subst_tm t1 x1 (open_tm_wrt_tm t2 (var_f x2)))).
Proof. Admitted.

#[export] Hint Resolve subst_tm_abs : lngen.

(* begin hide *)

Lemma subst_tm_intro_rec_mutual :
(forall t1 x1 t2 n1,
  x1 `notin` fv_tm t1 ->
  open_tm_wrt_tm_rec n1 t2 t1 = subst_tm t2 x1 (open_tm_wrt_tm_rec n1 (var_f x1) t1)).
Proof. Admitted.

(* end hide *)

Lemma subst_tm_intro_rec :
forall t1 x1 t2 n1,
  x1 `notin` fv_tm t1 ->
  open_tm_wrt_tm_rec n1 t2 t1 = subst_tm t2 x1 (open_tm_wrt_tm_rec n1 (var_f x1) t1).
Proof. Admitted.

#[export] Hint Resolve subst_tm_intro_rec : lngen.
#[export] Hint Rewrite subst_tm_intro_rec using solve [auto] : lngen.

Lemma subst_tm_intro :
forall x1 t1 t2,
  x1 `notin` fv_tm t1 ->
  open_tm_wrt_tm t1 t2 = subst_tm t2 x1 (open_tm_wrt_tm t1 (var_f x1)).
Proof. Admitted.

#[export] Hint Resolve subst_tm_intro : lngen.

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

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


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Section Relations_1.
   Variable U : Type.

   Definition Relation := U -> U -> Prop.
   Variable R : Relation.

   Definition Reflexive : Prop := forall x:U, R x x.

   Definition Transitive : Prop := forall x y z:U, R x y -> R y z -> R x z.

   Definition Symmetric : Prop := forall x y:U, R x y -> R y x.

   Definition Antisymmetric : Prop := forall x y:U, R x y -> R y x -> x = y.

   Definition contains (R R':Relation) : Prop :=
     forall x y:U, R' x y -> R x y.

   Definition same_relation (R R':Relation) : Prop :=
     contains R R' /\ contains R' R.

   Inductive Preorder : Prop :=
       Definition_of_preorder : Reflexive -> Transitive -> Preorder.

   Inductive Order : Prop :=
       Definition_of_order :
         Reflexive -> Transitive -> Antisymmetric -> Order.

   Inductive Equivalence : Prop :=
       Definition_of_equivalence :
         Reflexive -> Transitive -> Symmetric -> Equivalence.

   Inductive PER : Prop :=
       Definition_of_PER : Symmetric -> Transitive -> PER.

End Relations_1.
Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains
  same_relation: sets v62.
Hint Resolve Definition_of_preorder Definition_of_order
  Definition_of_equivalence Definition_of_PER: sets v62.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Properties of logical connectives and functions                         *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics.
From TLC Require Export LibAxioms LibEqual.
Generalizable Variables A B P.

(* ********************************************************************** *)
(** * Strong existentials *)

(** Type [sig] is defined in LibLogicCore *)

(** Projections *)

Definition sig_val (A : Type) (P : A->Prop) (e : sig P) : A :=
  match e with exist _ a _ => a end.

Definition sig_proof (A : Type) (P : A->Prop) (e : sig P) : P (sig_val e) :=
  match e with exist _ _ b => b end.

(* ********************************************************************** *)
(** * Inhabited types *)

(* ---------------------------------------------------------------------- *)
(** ** Typeclass for describing inhabited types *)

(** The proposition [Inhab A] captures the fact that the type [A] is
    inhabited (i.e., there exists at least one value of type [A]). *)

Class Inhab (A:Type) : Prop :=
  { Inhab_intro : (exists (x:A), True) }.

#[global]
Hint Mode Inhab + : typeclass_instances.

(* ---------------------------------------------------------------------- *)
(** ** Tactics taking into account *)

(** Extension to LibTactics' fast introduction tactic [=>>]
    to handle specifically the case of the Inhabited typeclass. *)

Ltac intro_nondeps_aux_special_intro G ::=
  match G with
  | (Inhab _) => idtac
  end.

(* ---------------------------------------------------------------------- *)
(** ** Arbitrary values for inhabited types *)

(** The value [arbitrary] can be used as a dummy value at any place
    where a value of an inhabited type is expected. *)

Definition arbitrary `{Inhab A} : A :=
  sig_val (@indefinite_description A _ Inhab_intro).

(** Extraction of [arbitrary] constants as a runtime error. *)

(* Extract Constant arbitrary => "(raise Not_found)". *)

(* ---------------------------------------------------------------------- *)
(** ** Lemmas about inhabited types *)

(** Proving a type to be inhabited *)

Lemma Inhab_of_val : forall (A:Type),
  A ->
  Inhab A.
Proof using. intros A x. constructor. exists x. auto. Qed.

(** Arrows are inhabited if their codomain is inhabited. *)

#[global]
Instance Inhab_impl : forall A B {I:Inhab B},
  Inhab (A -> B).
Proof using. intros. apply (Inhab_of_val (fun _ => arbitrary)). Qed.

(* ********************************************************************** *)
(** * Non-constructive conditionals *)

(* ---------------------------------------------------------------------- *)
(** ** Excluded middle *)

(** Every proposition is either [True] or [False]. *)

Lemma classic : forall (P : Prop),
  P \/ ~ P.
Proof using.
  intros.
  set (B1 := fun b => b = true \/ P).
  set (B2 := fun b => b = false \/ P).
  asserts H1: (ex B1). exists true. left~.
  asserts H2: (ex B2). exists false. left~.
  sets i1: (indefinite_description H1).
  sets i2: (indefinite_description H2).
  destruct (sig_proof i1) as [HA|]; [|auto].
  destruct (sig_proof i2) as [HB|]; [|auto].
  right. intros HP. asserts EB: (B1 = B2).
    apply pred_ext_1. intros b. split; intros _; right; auto.
  subst i1 i2. destruct EB.
  rewrite (proof_irrelevance H2 H1) in HB. congruence.
Qed.

Definition prop_inv := classic.

(* ---------------------------------------------------------------------- *)
(** ** Strong excluded middle *)

(** From classical logic and indefinite description, we can prove
    the strong (or informative) excluded middle, which allows Coq
    definitions to make a case analysis on the truth value of any
    proposition. *)

Lemma classicT : forall (P : Prop),
  {P} + {~ P}.
Proof using.
  intros. pose (select := fun (b:bool) => if b then P else ~P).
  cuts (M,HP): { b:bool | select b }.
    destruct M. left~. right~.
  apply indefinite_description.
  destruct (prop_inv P). exists~ true. exists~ false.
Qed.

(** Simplification lemmas *)

Lemma classicT_l : forall (P : Prop) (H:P),
   classicT P = left _ H.
Proof using. intros. destruct (classicT P). fequals. false~. Qed.

Lemma classicT_r : forall (P : Prop) (H:~P),
   classicT P = right _ H.
Proof using. intros. destruct (classicT P). false~. fequals. Qed.

(* ---------------------------------------------------------------------- *)
(** ** If-then-else on propositions *)

(** The expression [If P then v1 else v2] can be used to build
    a conditional that depends on a proposition [P]. *)

Notation "'If' P 'then' v1 'else' v2" :=
  (if (classicT P) then v1 else v2)
  (at level 200, right associativity) : type_scope.

Section Ifthenelse.
Variables A : Type.
Implicit Types P : Prop.
Implicit Types x y : A.

(** Lemmas to simplify If-then-else statement *)

Lemma If_l : forall P x y,
  P ->
  (If P then x else y) = x.
Proof using. intros. case_if*. Qed.

Lemma If_r : forall P x y,
  ~ P ->
  (If P then x else y) = y.
Proof using. intros. case_if*. Qed.

(** A lemma to prove an equality between two If-then-else *)

Lemma If_eq : forall P P' x x' y y',
  (P <-> P') ->
  (P -> x = x') ->
  (~P -> y = y') ->
  (If P then x else y) = (If P' then x' else y').
Proof using. intros. do 2 case_if; autos*. Qed.

(** A simpler version of the above lemma *)

Lemma If_eq_simple : forall P P' x x' y y',
  (P <-> P') ->
  (x = x') ->
  (y = y') ->
  (If P then x else y) = (If P' then x' else y').
Proof using. intros. subst. asserts_rewrite (P = P'). apply~ prop_ext. auto. Qed.

End Ifthenelse.

(* ---------------------------------------------------------------------- *)
(** ** Consequences *)

(** Propositional extensionality stated using itself *)

Lemma eq_prop_eq_iff : forall P Q,
  (P = Q) = (P <-> Q).
Proof using. intros. extens. iff. subst*. apply~ prop_ext. Qed.

(** Propositional completeness (degeneracy) *)

Lemma prop_degeneracy : forall (P : Prop),
   P = True \/ P = False.
Proof using.
  intros. destruct (prop_inv P).
    left. apply* prop_ext.
    right. apply* prop_ext.
Qed.

(** Independence of general premises *)

Lemma indep_general_premises :
  forall A `{Inhab A} (P : A -> Prop) (Q : Prop),
  (Q -> exists x, P x) ->
  (exists x, Q -> P x).
Proof using.
  introv I M. destruct (prop_inv Q).
  destruct* (M H).
  exists (arbitrary (A:=A)). auto_false.
Qed.

(** Small drinker's paradox *)

Lemma small_drinker_paradox : forall `{Inhab A} (P : A -> Prop),
  exists x, (exists x, P x) -> P x.
Proof using.
  intros A I P. destruct (prop_inv (exists x, P x)).
  destruct H. exists x. auto.
  exists (arbitrary (A:=A)). auto_false.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Tactic for proving tautologies by bruteforce case-analysis *)

(** The tactic [tautop P1 .. PN] helps performing case analysis on
    the propositions/booleans that are given to it as parameters. *)

Ltac tautop_case P :=
  match type of P with
  | Prop => destruct (prop_degeneracy P)
  | bool => destruct P
  end.

Ltac tautop_pre tt :=
  intros;
  repeat rewrite eq_prop_eq_iff in *.

Ltac tautop_post tt :=
  subst;
  try solve [ intuition auto_false ].

Ltac tautop_core args :=
  tautop_pre tt;
  let rec aux Ps :=
    match Ps with
    | nil => idtac
    | cons (boxer ?P) ?Ps' => tautop_case P; aux Ps'
    end in
  aux args;
  tautop_post tt.

Ltac tautop_noargs tt :=
  let rec aux Ps :=
     match goal with
     | |- forall (_:Prop), _ =>
       let P := fresh "P" in intro P; aux (cons (boxer P) Ps)
     | _ => tautop_core Ps
     end
     in
  aux constr:(@nil Boxer).

Tactic Notation "tautop" :=
  tautop_noargs tt.
Tactic Notation "tautop" constr(P1) :=
  tautop_core (>> P1).
Tactic Notation "tautop" constr(P1) constr(P2) :=
  tautop_core (>> P1 P2).
Tactic Notation "tautop" constr(P1) constr(P2) constr(P3) :=
  tautop_core (>> P1 P2 P3).

(* ********************************************************************** *)
(** * Properties of logical combinators *)

(* ---------------------------------------------------------------------- *)
(** ** Simplification of conjunction and disjunction *)

Section SimplConjDisj.
Implicit Types P Q : Prop.

Lemma and_True_l_eq : forall P,
  (True /\ P) = P.
Proof using. tautop. Qed.

Lemma and_True_r_eq : forall P,
  (P /\ True) = P.
Proof using. tautop. Qed.

Lemma and_False_l_eq : forall P,
  (False /\ P) = False.
Proof using. tautop. Qed.

Lemma and_False_r_eq : forall P,
  (P /\ False) = False.
Proof using. tautop. Qed.

Lemma or_True_l_eq : forall P,
  (True \/ P) = True.
Proof using. tautop. Qed.

Lemma or_True_r_eq : forall P,
  (P \/ True) = True.
Proof using. tautop. Qed.

Lemma or_False_l_eq : forall P,
  (False \/ P) = P.
Proof using. tautop. Qed.

Lemma or_False_r_eq : forall P,
  (P \/ False) = P.
Proof using. tautop. Qed.

End SimplConjDisj.

(* ---------------------------------------------------------------------- *)
(** ** Distribution of negation on basic operators *)

Section SimplNot.
Implicit Types P Q : Prop.

Lemma not_True_eq :
  (~ True) = False.
Proof using. tautop. Qed.

Lemma not_False_eq :
  (~ False) = True.
Proof using. tautop. Qed.

Lemma not_not_eq : forall P,
  (~ (~ P)) = P.
Proof using. tautop. Qed.

Lemma not_and_eq : forall P Q,
  (~ (P /\ Q)) = (~ P \/ ~ Q).
Proof using. tautop. Qed.

Lemma not_or_eq : forall P Q,
  (~ (P \/ Q)) = (~ P /\ ~ Q).
Proof using. tautop. Qed.

Lemma not_impl_eq : forall P Q,
  (~ (P -> Q)) = (P /\ ~ Q).
Proof using. tautop. Qed.

(* Derived versions *)

Lemma not_or_nots_eq : forall P Q,
  (~ (~ P \/ ~ Q)) = (P /\ Q).
Proof using. tautop. Qed.

Lemma not_and_nots_eq : forall P Q,
  (~ (~ P /\ ~ Q)) = (P \/ Q).
Proof using. tautop. Qed.

End SimplNot.

(* ---------------------------------------------------------------------- *)
(** ** Double negation and contrapose *)

Section DoubleNeg.
Implicit Types P Q : Prop.

(** Double negation *)

Lemma not_not_inv : forall P,
  ~ ~ P ->
  P.
Proof using. tautop. Qed.

Lemma not_not : forall P,
  P ->
  ~ ~ P.
Proof using. tautop. Qed.

(** Contrapose *)

Lemma contrapose_eq : forall P Q,
  (~ P -> ~ Q) = (Q -> P).
Proof using. tautop. Qed.

Lemma contrapose_inv : forall P Q,
  (~ Q -> ~ P) ->
  (P -> Q).
Proof using. tautop. Qed.

Lemma contrapose : forall P Q,
  (Q -> P) ->
  (~ P -> ~ Q).
Proof using. tautop. Qed.

(** Negation is injective *)

Lemma injective_not : forall P Q,
  (~P) = (~Q) ->
  (P = Q).
Proof using. tautop. Qed.

End DoubleNeg.

(* ---------------------------------------------------------------------- *)
(** ** Distribution of negation on quantifiers *)

Section SimplNotQuantifiers.
Variables (A : Type).
Implicit Types P : A -> Prop.

(** Three auxiliary facts (private lemmas) *)

Lemma exists_of_not_forall : forall P,
  ~ (forall x, ~ P x) ->
  (exists x, P x).
Proof using. intros. apply* not_not_inv. Qed.

Lemma forall_of_not_exists : forall P,
  ~ (exists x, ~ P x) ->
  (forall x, P x).
Proof using. intros. apply* not_not_inv. Qed.

Lemma not_not_pred_eq : forall A (P:A->Prop),
  P = (fun x => ~ ~ (P x)).
Proof using. intros. extens. intros. rewrite* not_not_eq. Qed.

(** Rewriting rules for quantifiers *)

Lemma not_forall_eq : forall P,
  (~ (forall x, P x)) = (exists x, ~ P x).
Proof using.
  extens. iff.
  { apply exists_of_not_forall. rewrite~ (not_not_pred_eq P) in H. }
  { intros M. destruct~ H as [x Cx]. }
Qed.

Lemma not_exists_eq : forall P,
  (~ (exists x, P x)) = (forall x, ~ P x).
Proof using.
  intros. apply injective_not. rewrite not_forall_eq.
  rewrite not_not_eq. set (P':=P) at 1.
  rewrite~ (not_not_pred_eq P').
Qed.

(* Derived versions, useful when rewriting does not work
   under binders. *)

Lemma not_forall_not_eq : forall P,
  (~ (forall x, ~ P x)) = (exists x, P x).
Proof using.
  intros. rewrite not_forall_eq.
   set (P':=P) at 2. rewrite~ (not_not_pred_eq P').
Qed.

Lemma not_exists_not_eq : forall P,
  (~ (exists x, ~ P x)) = (forall x, P x).
Proof using.
  intros. rewrite not_exists_eq.
  set (P':=P) at 2. rewrite~ (not_not_pred_eq P').
Qed.

End SimplNotQuantifiers.

(* ---------------------------------------------------------------------- *)
(** ** Propositions equal to [True] or [False] *)

Section EqTrueFalse.
Implicit Types P Q : Prop.

(** Propositions equal to [True] *)

Lemma prop_eq_True_eq : forall P,
  (P = True) = P.
Proof using. tautop. Qed.

Lemma prop_eq_True : forall P,
  P ->
  P = True.
Proof using. tautop. Qed.

Lemma prop_eq_True_inv : forall P,
  P = True ->
  P.
Proof using. tautop. Qed.

(** Propositions equal to [False] *)

Lemma prop_eq_False_eq : forall P,
  (P = False) = ~ P.
Proof using. tautop. Qed.

Lemma prop_eq_False : forall P,
  ~ P ->
  P = False.
Proof using. tautop. Qed.

Lemma prop_eq_False_inv : forall P,
  P = False ->
  ~ P.
Proof using. tautop. Qed.

End EqTrueFalse.

#[global]
Hint Resolve prop_eq_True prop_eq_False.

(* ---------------------------------------------------------------------- *)
(** ** Disequal propositions *)

Section NeqProp.
Implicit Types P Q : Prop.

(** Propositions not [True] or not [False] *)

Lemma prop_neq_True_eq : forall P,
  (P <> True) = ~ P.
Proof using. tautop. Qed.

Lemma prop_neq_False_eq : forall P,
  (P <> False) = P.
Proof using. tautop. Qed.

(** Proving two propositions not equal *)

Lemma prop_neq_of_iff_l : forall P Q,
  (P <-> ~ Q) ->
  P <> Q.
Proof using. tautop. Qed.

Lemma prop_neq_of_iff_r : forall P Q,
  (~ P <-> Q) ->
  P <> Q.
Proof using. tautop. Qed.

Lemma prop_neq_inv_iff_l : forall P Q,
  P <> Q ->
  (P <-> ~ Q).
Proof using. tautop. Qed.

Lemma prop_neq_inv_iff_r : forall P Q,
  P <> Q ->
  (~ P <-> Q).
Proof using. tautop. Qed.

(** True is not False *)

Lemma True_neq_False : True <> False.
Proof using. tautop. Qed.

End NeqProp.

#[global]
Hint Resolve True_neq_False.

(* ---------------------------------------------------------------------- *)
(** ** Peirce rule and similar *)

Section ClassicOr.
Implicit Types P Q : Prop.

(** Peirce's result: proving a fact by assuming its negation *)

Lemma assume_not : forall P,
  (~ P -> P) ->
  P.
Proof using. tautop. Qed.

(** Proving a disjunction, assuming the negation of the other branch *)

Lemma or_classic_l : forall P Q,
  (~ Q -> P) ->
  P \/ Q.
Proof using. tautop. Qed.

Lemma or_classic_r : forall P Q,
  (~ P -> Q) ->
  P \/ Q.
Proof using. tautop. Qed.

(** Same, but in forward style *)

Lemma or_inv_classic_l : forall P Q,
  P \/ Q ->
  (P \/ (~ P /\ Q)).
Proof using. tautop. Qed.

Lemma or_inv_classic_r : forall P Q,
  P \/ Q ->
  (Q \/ (P /\ ~ Q)).
Proof using. tautop. Qed.

End ClassicOr.

(* ---------------------------------------------------------------------- *)
(** ** Properties of logical equivalence *)

Section IffProp.
Implicit Types P Q R : Prop.

(** Introduction *)

Lemma iff_eq_and : forall P Q : Prop,
  (P <-> Q) = ((P -> Q) /\ (Q -> P)).
Proof using. tautop. Qed.

Lemma iff_intro : forall P Q : Prop,
  (P -> Q) ->
  (Q -> P) ->
  (P <-> Q).
Proof using. intros. rewrite* iff_eq_and. Qed.

(** Reflexivity: [refl iff] *)

Lemma iff_refl : forall P,
  P <-> P.
Proof using. tautop. Qed.

(** Symmetry: [sym iff] *)

Lemma iff_sym : forall P Q,
  (P <-> Q) ->
  (Q <-> P).
Proof using. tautop. Qed.

(** Transitivity: [trans iff] *)

Lemma iff_trans : forall P Q R,
  (P <-> Q) ->
  (Q <-> R) ->
  (P <-> R).
Proof using. tautop. Qed.

(** First projection *)

Lemma iff_l : forall P Q,
  (P <-> Q) ->
  P ->
  Q.
Proof using. tautop. Qed.

(** Second projection *)

Lemma iff_r : forall P Q,
  (P <-> Q) ->
  Q ->
  P.
Proof using. tautop. Qed.

(** Contrapose of the first projection *)

Lemma iff_not_l : forall P Q,
  (P <-> Q) ->
  ~ P ->
  ~ Q.
Proof using. tautop. Qed.

(** Contrapose of the second projection *)

Lemma iff_not_r : forall P Q,
  (P <-> Q) ->
  ~ Q ->
  ~ P.
Proof using. tautop. Qed.

(** Negation can change side of an equivalence *)

Lemma iff_not_swap_eq : forall P Q,
  ((~ P) <-> Q) = (P <-> (~ Q)).
Proof using. tautop. Qed.

(** Negation can be cancelled on both sides *)

Lemma iff_not_not_eq : forall P Q,
  ((~ P) <-> (~Q)) = (P <-> Q).
Proof using. tautop. Qed.

End IffProp.

(* ********************************************************************** *)
(** * Tactics *)

(* ---------------------------------------------------------------------- *)
(** ** Tactic for simplifying expressions *)

(** The tactic [rew_logic] can be used to automatically
    simplify logical expressions. Syntax [rew_logic in H]
    and [rew_logic in *] are also available. *)

(* Remark: [not_impl] needs to have higher priority than [not_forall],
   and samewise for [not_forall_not_eq] and [not_exists_not_eq]. *)
#[global]
Hint Rewrite
  not_not_eq not_and_eq not_or_eq not_impl_eq not_True_eq not_False_eq
  not_forall_eq not_forall_not_eq
  not_exists_eq not_exists_not_eq not_impl_eq
  prop_eq_True_eq prop_eq_False_eq eq_prop_eq_iff
  and_True_l_eq and_True_r_eq and_False_l_eq and_False_r_eq
  or_True_l_eq or_True_r_eq or_False_l_eq or_False_r_eq
  not_False_eq not_True_eq
  : rew_logic.

Tactic Notation "rew_logic" :=
  autorewrite with rew_logic.
Tactic Notation "rew_logic" "in" hyp(H) :=
  autorewrite with rew_logic in H.
Tactic Notation "rew_logic" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_logic).
  (* autorewrite with rew_logic in *. *)

Tactic Notation "rew_logic" "~" :=
  rew_logic; auto_tilde.
Tactic Notation "rew_logic" "~" "in" hyp(H) :=
  rew_logic in H; auto_tilde.
Tactic Notation "rew_logic" "~" "in" "*" :=
  rew_logic in *; auto_tilde.

Tactic Notation "rew_logic" "*" :=
  rew_logic; auto_star.
Tactic Notation "rew_logic" "*" "in" hyp(H) :=
  rew_logic in H; auto_star.
Tactic Notation "rew_logic" "*" "in" "*" :=
  rew_logic in *; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Tactic [tests: P] for classical disjunction on [P]. *)

(** The tactic [tests: P] can be used to tests whether the proposition [P]
    is true or not. If [P] is an equality, it is substituted. Use the
    tactic [tests_nosubst: P] to disable the automated substitution.
    Use the tactic [tests_basic: P] to moreover disable simplification
    of logical expressions.
    To name the resulting hypotheses use [tests I: P], or [tests I1 I2: P]
    to assign different names to both sides.
    (In LibReflect, the tactic is extended so that [P] can be a boolean.) *)

Ltac tests_ssum_base E H1 H2 :=
  destruct E as [H1|H2].

Ltac tests_prop_base E H1 H2 :=
  tests_ssum_base (classicT E) H1 H2.

Ltac tests_dispatch E H1 H2 :=
  match type of E with
  | Prop => tests_prop_base E H1 H2
  | {_}+{_} => tests_ssum_base E H1 H2
  end.

Ltac tests_post H introstac :=
  tryfalse; rew_logic in H; revert H;
  introstac tt; tryfalse.

Ltac tests_post_subst H I :=
  tests_post H ltac:(fun _ => first [ intro_subst_hyp | intros I ]).

Ltac tests_post_nosubst H I :=
  tests_post H ltac:(fun _ => intros I).

Ltac tests_base E I1 I2 tests_post :=
  let H1 := fresh "TEMP" in
  let H2 := fresh "TEMP" in
  tests_dispatch E H1 H2;
    [ tests_post H1 I1
    | tests_post H2 I2 ].

Tactic Notation "tests" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E) :=
  tests_base E I1 I2 ltac:(tests_post_subst).
Tactic Notation "tests" simple_intropattern(I) ":" constr(E) :=
  tests I I: E.
Tactic Notation "tests" ":" constr(E) :=
  let I := fresh "C" in tests I: E.
Tactic Notation "tests" "~" ":" constr(E) :=
  tests: E; auto_tilde.
Tactic Notation "tests" "*" ":" constr(E) :=
  tests: E; auto_star.

Tactic Notation "tests_nosubst" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E) :=
  tests_base E I1 I2 ltac:(tests_post_nosubst).
Tactic Notation "tests_nosubst" simple_intropattern(I) ":" constr(E) :=
  tests_nosubst I I: E.
Tactic Notation "tests_nosubst" ":" constr(E) :=
  let I := fresh "C" in tests I: E.
Tactic Notation "tests_nosubst" "~" ":" constr(E) :=
  tests: E; auto_tilde.
Tactic Notation "tests_nosubst" "*" ":" constr(E) :=
  tests: E; auto_star.

Tactic Notation "tests_basic" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E) :=
  tests_dispatch E I1 I2.
Tactic Notation "tests_basic" simple_intropattern(I1) ":" constr(E) :=
  tests_basic I1 I1: E.
Tactic Notation "tests_basic" ":" constr(E) :=
  let C := fresh "C" in tests_basic C: E.

(* ---------------------------------------------------------------------- *)
(** ** Tactic [case_classic] *)

(** [case_classic] performs a case analysis on the first expression of the
    form [classicT ?E] that appears in the goal. *)

Tactic Notation "case_classic" "as" simple_intropattern(C) :=
  match goal with
  | |- context [ classicT ?E ] => destruct (classicT E) as [C|C]
  | H: context [ classicT ?E ] |- _ => destruct (classicT E) as [C|C]
  end; tryfalse.

Tactic Notation "case_classic" :=
  let C := fresh "C" in case_classic as C.

(* ---------------------------------------------------------------------- *)
(** ** Tactic [absurds] *)

(** [absurds] applies to a goal [G] and replaces it with [(~ G) -> False].
    The expression [~ G] is simplified using [rew_logic].

    [absurds ;=> H] introduces [H] as the negation of the goal, and
    leaves [False] is the goal.

    [absurds_nosimpl] is similar, but it does not perform simplifications. *)

Lemma absurds_lemma : forall (G:Prop),
  ((~ G) -> False) ->
  G.
Proof using. intros. applys~ not_not_inv. Qed.

Ltac absurds_nosimpl_core tt :=
  applys absurds_lemma.

Tactic Notation "absurds_nosimpl" :=
  absurds_nosimpl_core tt.

Ltac absurds_post tt :=
  rew_logic.

Ltac absurds_core tt :=
  applys absurds_lemma;
  absurds_post tt.

Tactic Notation "absurds" :=
   absurds_core tt.

(* ********************************************************************** *)
(** * Predicate combinators, comparison and compatibility *)

(* ---------------------------------------------------------------------- *)
(** ** Definition of predicate combinators *)

Definition pred_true {A : Type} :=
  fun (_:A) => True.

Definition pred_false {A : Type} :=
  fun (_:A) => False.

Definition pred_not (A : Type) (P : A -> Prop) :=
  fun x => ~ (P x).

Definition pred_and (A : Type) (P Q : A -> Prop) :=
  fun x => P x /\ Q x.

Definition pred_or (A : Type) (P Q : A -> Prop) :=
  fun x => P x \/ Q x.

Definition pred_impl (A : Type) (P Q : A -> Prop) :=
  fun x => P x -> Q x.

#[global]
Hint Unfold pred_true pred_false.

(* ---------------------------------------------------------------------- *)
(** ** Properties of combinators *)

(* --LATER: reformulate using [pred_all] and [pred_and] (?) *)

Lemma pred_conj_forall_distrib : forall A (P Q: A->Prop),
  ((forall x, P x) /\ (forall x, Q x)) = (forall x, P x /\ Q x).
Proof using. intros. apply prop_ext. iff H. autos*. split; intros x; apply* (H x). Qed.

(* ---------------------------------------------------------------------- *)
(** ** Order on predicates *)

Definition pred_incl (A : Type) (P Q : A -> Prop) :=
  forall x, P x -> Q x.

(* --LATER: create a section here *)

Lemma pred_eq_forall_impl : forall A (P Q : A -> Prop),
  pred_incl P Q = (forall x, P x -> Q x).
Proof using. auto. Qed.

Lemma pred_incl_refl : forall A (P : A -> Prop),
  pred_incl P P.
Proof using. unfolds~ pred_incl. Qed.

Lemma pred_incl_trans : forall A (Q P R : A -> Prop),
  pred_incl P Q ->
  pred_incl Q R ->
  pred_incl P R.
Proof using. unfolds~ pred_incl. Qed.

Lemma pred_incl_antisym : forall A (P Q : A -> Prop),
  pred_incl P Q ->
  pred_incl Q P ->
  P = Q.
Proof using. extens*. Qed.

(** See also [LibRelation] and [LibOrder] for higher-level statements
    of these results *)

(* ********************************************************************** *)
(** * Existentials *)

(* ---------------------------------------------------------------------- *)
(** * Properties of unique existentials *)

(** [unique_st P x] asserts that [x] is the unique element for which
    [P x] holds. *)

Definition unique_st (A : Type) (P : A -> Prop) (x : A) :=
  P x /\ forall y, P y -> y = x.

#[global]
Hint Unfold unique_st.

(** [ex_unique P] asserts that there exists a unique element for which
    [P x] holds. *)

Definition ex_unique (A : Type) (P : A -> Prop) :=
  ex (unique_st P).

(** [exists! x, P] is the notation for [ex_unique P]. *)

Notation "'exists' ! x , P" := (ex_unique (fun x => P))
  (at level 200, x ident, right associativity,
    format "'[' 'exists' !  '/  ' x ,  '/  ' P ']'") : type_scope.

Notation "'exists' ! x : A , P" :=
  (ex_unique (fun x:A => P))
  (at level 200, x ident, right associativity,
    format "'[' 'exists' !  '/  ' x  :  A ,  '/  ' P ']'") : type_scope.

(** [at_most_one P] asserts that there exists at most one element for
    which [P x] holds. In other words, [P] has 0 or 1 inhabitant. *)

Definition at_most_one (A : Type) (P : A -> Prop) :=
  forall x y, P x -> P y -> x = y.

Section UniqueProp.
Variables (A : Type).
Implicit Types  (P : A -> Prop).

(** [exists! x, P] entails [exists x, P] *)

Lemma ex_of_ex_unique : forall P,
  ex_unique P ->
  ex P.
Proof using. introv (x&H&U). eauto. Qed.

(** [exists! x, P] entails [at_most_one P] *)

Lemma at_most_one_of_ex_unique : forall P,
  ex_unique P ->
  at_most_one P.
Proof using.
  introv (a&H&U) Px Py. applys~ eq_trans a. rewrite~ <- (U y).
Qed.

(** [exists x, P] and [at_most_one P] entail [exists! x, P] *)

Lemma ex_unique_of_ex_at_most_one : forall P,
  ex P ->
  at_most_one P ->
  ex_unique P.
Proof using. introv [x Px] H. exists x. split~. Qed.

End UniqueProp.

(* ********************************************************************** *)
(** * Conjunctions *)

(* ---------------------------------------------------------------------- *)
(** ** Changing the order of branches *)

Lemma conj_swap: forall (P Q: Prop),
  P ->
  Q ->
  Q /\ P.
Proof using. autos*. Qed.

Lemma conj_dup_r : forall P Q : Prop,
  Q ->
  (Q -> P) ->
  P /\ Q.
Proof using. autos*. Qed.

Lemma conj_dup_l : forall P Q : Prop,
  P ->
  (P -> Q) ->
  P /\ Q.
Proof using. autos*. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Parallel strengthening of a conjunction *)

Lemma conj_strengthen_2 : forall (Q1 Q2 P1 P2 : Prop),
  (Q1 /\ Q2) ->
  (Q1 -> P1) ->
  (Q2 -> P2) ->
  (P1 /\ P2).
Proof using. autos*. Qed.

Lemma conj_strengthen_3 : forall (Q1 Q2 Q3 P1 P2 P3 : Prop),
  (Q1 /\ Q2 /\ Q3) ->
  (Q1 -> P1) ->
  (Q2 -> P2) ->
  (Q3 -> P3) ->
  (P1 /\ P2 /\ P3).
Proof using. autos*. Qed.

Lemma conj_strengthen_4 : forall (Q1 Q2 Q3 Q4 P1 P2 P3 P4 : Prop),
  (Q1 /\ Q2 /\ Q3 /\ Q4) ->
  (Q1 -> P1) ->
  (Q2 -> P2) ->
  (Q3 -> P3) ->
  (Q4 -> P4) ->
  (P1 /\ P2 /\ P3 /\ P4).
Proof using. autos*. Qed.

Lemma conj_strengthen_5 : forall (Q1 Q2 Q3 Q4 Q5 P1 P2 P3 P4 P5 : Prop),
  (Q1 /\ Q2 /\ Q3 /\ Q4 /\ Q5) ->
  (Q1 -> P1) ->
  (Q2 -> P2) ->
  (Q3 -> P3) ->
  (Q4 -> P4) ->
  (Q5 -> P5) ->
  (P1 /\ P2 /\ P3 /\ P4 /\ P5).
Proof using. autos*. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Projections of lemmas concluding on a conjunction *)

Section ProjLemma.
Variables (A1 : Type).
Variables (A2 : forall (x1 : A1), Type).
Variables (A3 : forall (x1 : A1) (x2 : A2 x1), Type).
Variables (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type).
Variables (A5 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3), Type).
Variables (A6 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4), Type).
Variables (A7 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5), Type).
Variables (A8 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5) (x7 : A7 x6), Type).
Variables (A9 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5) (x7 : A7 x6) (x8 : A8 x7), Type).
Variables (A10 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5) (x7 : A7 x6) (x8 : A8 x7) (x9 : A9 x8), Type).
Variables (A11 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5) (x7 : A7 x6) (x8 : A8 x7) (x9 : A9 x8) (x10 : A10 x9), Type).

Ltac prove_forall_conj_inv :=
  intros;
  match goal with H: context [_ /\ _] |- _ =>
    split; intros; apply H end.

Lemma forall_conj_inv_1 : forall (P Q : forall (x1:A1), Prop),
  (forall x1, P x1 /\ Q x1) ->
  (forall x1, P x1) /\
  (forall x1, Q x1).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_2 : forall (P Q : forall (x1:A1) (x2:A2 x1), Prop),
  (forall x1 x2, P x1 x2 /\ Q x1 x2) ->
  (forall x1 x2, P x1 x2) /\
  (forall x1 x2, Q x1 x2).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_3 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2), Prop),
  (forall x1 x2 x3, P x1 x2 x3 /\ Q x1 x2 x3) ->
  (forall x1 x2 x3, P x1 x2 x3) /\
  (forall x1 x2 x3, Q x1 x2 x3).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_4 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3), Prop),
  (forall x1 x2 x3 x4, P x1 x2 x3 x4 /\ Q x1 x2 x3 x4) ->
  (forall x1 x2 x3 x4, P x1 x2 x3 x4) /\
  (forall x1 x2 x3 x4, Q x1 x2 x3 x4).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_5 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4), Prop),
  (forall x1 x2 x3 x4 x5, P x1 x2 x3 x4 x5 /\ Q x1 x2 x3 x4 x5) ->
  (forall x1 x2 x3 x4 x5, P x1 x2 x3 x4 x5) /\
  (forall x1 x2 x3 x4 x5, Q x1 x2 x3 x4 x5).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_6 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5), Prop),
  (forall x1 x2 x3 x4 x5 x6, P x1 x2 x3 x4 x5 x6 /\ Q x1 x2 x3 x4 x5 x6) ->
  (forall x1 x2 x3 x4 x5 x6, P x1 x2 x3 x4 x5 x6) /\
  (forall x1 x2 x3 x4 x5 x6, Q x1 x2 x3 x4 x5 x6).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_7 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7, P x1 x2 x3 x4 x5 x6 x7 /\ Q x1 x2 x3 x4 x5 x6 x7) ->
  (forall x1 x2 x3 x4 x5 x6 x7, P x1 x2 x3 x4 x5 x6 x7) /\
  (forall x1 x2 x3 x4 x5 x6 x7, Q x1 x2 x3 x4 x5 x6 x7).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_8 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6) (x8:A8 x7), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7 x8, P x1 x2 x3 x4 x5 x6 x7 x8 /\ Q x1 x2 x3 x4 x5 x6 x7 x8) ->
  (forall x1 x2 x3 x4 x5 x6 x7 x8, P x1 x2 x3 x4 x5 x6 x7 x8) /\
  (forall x1 x2 x3 x4 x5 x6 x7 x8, Q x1 x2 x3 x4 x5 x6 x7 x8).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_9 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6) (x8:A8 x7) (x9:A9 x8), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9, P x1 x2 x3 x4 x5 x6 x7 x8 x9 /\ Q x1 x2 x3 x4 x5 x6 x7 x8 x9) ->
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9, P x1 x2 x3 x4 x5 x6 x7 x8 x9) /\
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9, Q x1 x2 x3 x4 x5 x6 x7 x8 x9).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_10 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6) (x8:A8 x7) (x9:A9 x8) (x10:A10 x9), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10, P x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 /\ Q x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) ->
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10, P x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) /\
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10, Q x1 x2 x3 x4 x5 x6 x7 x8 x9 x10).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_11 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6) (x8:A8 x7) (x9:A9 x8) (x10:A10 x9) (x11:A11 x10), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11, P x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 /\ Q x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) ->
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11, P x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) /\
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11, Q x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11).
Proof using. prove_forall_conj_inv. Qed.

End ProjLemma.

Arguments forall_conj_inv_1 [A1] [P] [Q].
Arguments forall_conj_inv_2 [A1] [A2] [P] [Q].
Arguments forall_conj_inv_3 [A1] [A2] [A3] [P] [Q].
Arguments forall_conj_inv_4 [A1] [A2] [A3] [A4] [P] [Q].
Arguments forall_conj_inv_5 [A1] [A2] [A3] [A4] [A5] [P] [Q].
Arguments forall_conj_inv_6 [A1] [A2] [A3] [A4] [A5] [A6] [P] [Q].
Arguments forall_conj_inv_7 [A1] [A2] [A3] [A4] [A5] [A6] [A7] [P] [Q].
Arguments forall_conj_inv_8 [A1] [A2] [A3] [A4] [A5] [A6] [A7] [A8] [P] [Q].
Arguments forall_conj_inv_9 [A1] [A2] [A3] [A4] [A5] [A6] [A7] [A8] [A9] [P] [Q].
Arguments forall_conj_inv_10 [A1] [A2] [A3] [A4] [A5] [A6] [A7] [A8] [A9] [A10] [P] [Q].
Arguments forall_conj_inv_11 [A1] [A2] [A3] [A4] [A5] [A6] [A7] [A8] [A9] [A10] [A11] [P] [Q].


From Hammer Require Import Hammer.

From hahn Require Import HahnBase HahnSets HahnList HahnRelationsBasic HahnEquational.
Require Export Sorted.

Set Implicit Arguments.

Lemma StronglySorted_cons_iff A (r : relation A) (a : A) (l : list A) :
StronglySorted r (a :: l) <-> StronglySorted r l /\ Forall (r a) l.
Proof. hammer_hook "HahnSorted" "HahnSorted.StronglySorted_cons_iff".
split; ins; desf; auto using SSorted_cons, StronglySorted_inv.
Qed.

Lemma StronglySorted_app_iff A (r: relation A) l1 l2 :
StronglySorted r (l1 ++ l2) <->
StronglySorted r l1 /\ StronglySorted r l2 /\
(forall x1 (IN1: In x1 l1) x2 (IN2: In x2 l2), r x1 x2).
Proof. hammer_hook "HahnSorted" "HahnSorted.StronglySorted_app_iff".
induction l1; ins; [by intuition; vauto|].
rewrite !StronglySorted_cons_iff, IHl1, Forall_app.
clear; intuition; desf; eauto.
all: rewrite Forall_forall in *; eauto.
Qed.

Lemma StronglySorted_app A (r: relation A) l1 l2
(S1: StronglySorted r l1) (S2: StronglySorted r l2)
(L: forall x1 (IN1: In x1 l1) x2 (IN2: In x2 l2), r x1 x2):
StronglySorted r (l1 ++ l2).
Proof. hammer_hook "HahnSorted" "HahnSorted.StronglySorted_app".
by apply StronglySorted_app_iff.
Qed.

Lemma StronglySorted_app_l A r (l l': list A):
StronglySorted r (l ++ l') -> StronglySorted r l.
Proof. hammer_hook "HahnSorted" "HahnSorted.StronglySorted_app_l".
rewrite StronglySorted_app_iff; tauto.
Qed.

Lemma StronglySorted_app_r A r (l l': list A):
StronglySorted r (l ++ l') -> StronglySorted r l'.
Proof. hammer_hook "HahnSorted" "HahnSorted.StronglySorted_app_r".
rewrite StronglySorted_app_iff; tauto.
Qed.

Lemma StronglySorted_filter A r f (l : list A):
StronglySorted r l -> StronglySorted r (filter f l).
Proof. hammer_hook "HahnSorted" "HahnSorted.StronglySorted_filter".
induction l; ins; eauto; desf; rewrite StronglySorted_cons_iff in *; desf.
all: splits; desf; eauto using Forall_filter.
Qed.

Lemma StronglySorted_filterP A r f (l : list A):
StronglySorted r l -> StronglySorted r (filterP f l).
Proof. hammer_hook "HahnSorted" "HahnSorted.StronglySorted_filterP".
induction l; ins; eauto; desf; rewrite StronglySorted_cons_iff in *; desf.
all: splits; desf; eauto using Forall_filterP.
Qed.

Lemma NoDup_StronglySorted A (r: relation A) (IRR: irreflexive r)
l (SS: StronglySorted r l):
NoDup l.
Proof. hammer_hook "HahnSorted" "HahnSorted.NoDup_StronglySorted".
induction l; ins.
apply StronglySorted_inv in SS; desc.
rewrite Forall_forall in *.
constructor; eauto.
Qed.

Hint Resolve NoDup_StronglySorted : hahn.

Lemma sorted_perm_eq : forall A (cmp: A -> A -> Prop)
(TRANS: transitive cmp)
(ANTIS: antisymmetric cmp)
l l' (P: Permutation l l')
(S : StronglySorted cmp l) (S' : StronglySorted cmp l'), l = l'.
Proof. hammer_hook "HahnSorted" "HahnSorted.sorted_perm_eq".
induction l; ins.
by apply Permutation_nil in P; desf.
assert (X: In a l') by eauto using Permutation_in, Permutation_sym, in_eq.
apply In_split2 in X; desf; apply Permutation_cons_app_inv in P.
destruct l1; ins; [by inv S; inv S'; eauto using f_equal|].
assert (X: In a0 l) by eauto using Permutation_in, Permutation_sym, in_eq.
inv S; inv S'; rewrite Forall_forall in *; ins.
destruct X0; left; apply ANTIS; eauto with hahn.
Qed.

Lemma StronglySorted_eq A (r: relation A) (ORD: strict_partial_order r) l l'
(SS: StronglySorted r l) (SS': StronglySorted r l')
(EQ: forall x, In x l <-> In x l'): l = l'.
Proof. hammer_hook "HahnSorted" "HahnSorted.StronglySorted_eq".
red in ORD; desc.
eapply sorted_perm_eq; eauto using NoDup_Permutation with hahn.
Qed.

Lemma StronglySorted_restr A cond (r: relation A) l:
StronglySorted (restr_rel cond r) l -> StronglySorted r l.
Proof. hammer_hook "HahnSorted" "HahnSorted.StronglySorted_restr".
induction l; ins; vauto.
rewrite StronglySorted_cons_iff, ForallE in *.
firstorder.
Qed.


Require Export Axioms.

(* 空集合 *)
Theorem ex_empty :
  exists !e, forall x, ~ x ∈ e.
Proof.
  induction Existance as [X _].
  specialize (Comprehension (fun x => x <> x) X ) as H.
  induction H as [E H].
  exists E.
  split.
  + intros x notEx.
    specialize (H x).
    apply H in notEx.
    induction notEx as [_ notxx].
    apply notxx.
    reflexivity.
  + intros E' H'.
    apply Extensionality.
    intro z.
    specialize (H z).
    specialize (H' z).
    rewrite H.
    split => [H1 | H1].
    - induction H1 as [_ F].
      case (F (eq_refl z)).
    - case (H' H1).
Qed.

Parameter Empty : set.
Axiom empty :
  forall x, ~ x ∈ Empty.
Notation "∅" := Empty.

(* 包含関係  *)
Definition Subset (X Y : set) := forall x, x ∈ X -> x ∈ Y.
Notation "A ⊂ B" := (Subset A B)(at level 10).

(* 順序対  *)
Theorem uniex_couple :
  forall X Y, exists !U, forall Z, Z ∈ U <-> Z = X \/ Z = Y.
  intros X Y.
  induction (Pair X Y) as [XY HXY].
  induction HXY as [XXY YXY].
  induction (Comprehension (fun x => x = X \/ x = Y) XY) as [U HU].
  exists U.
  split.
  + intro Z.
    specialize (HU Z).
    rewrite HU.
    split => [H | H].
    - apply H.
    - inversion H as [xX | xY].
      * subst X.
        apply (conj XXY H).
      * subst Y.
        apply (conj YXY H).
  + intros U' H'.
    apply Extensionality.
    intro Z.
    specialize (HU Z).
    specialize (H' Z).
    rewrite HU.
    rewrite H'.
    split => [H | H].
    - apply H.
    - inversion H as [xX | xY].
      * subst X.
        apply (conj XXY H).
      * subst Y.
        apply (conj YXY H).
Qed.

Axiom Couple : set -> set -> set.
Axiom couple :
  forall X Y z, z ∈ ( Couple X Y) <-> z = X \/ z = Y.

Definition Single (X : set) := Couple X X.

Definition OrderPair (X Y : set) := Couple (Single X) (Couple X Y).
Notation "<| X , Y |>" := (OrderPair X Y) (at level 10).

(* 差集合  *)
Definition Diff (X Y : set) := {X ; fun x => ~ x ∈ Y}.
Notation "X // Y" := (Diff X Y)(at level 10).
Theorem diff (X Y : set) :
  forall x, x ∈ (X  //     Y ) <-> x ∈ X /\ ~ x ∈ Y.
Proof.
  intro x.
  by rewrite class.
Qed.

(* 和集合  *)
Definition isCups (X : set) := (fun x => exists Y, x ∈ Y /\ Y∈ X).

Theorem exists_cups (X : set):
  exists_class (isCups X).
Proof.
  specialize (Union X) as H.
  induction H as [U H].
  specialize (Comprehension (isCups X) U ) as H1.
  induction H1 as [U' H1].
  exists U'.
  intro x.
  specialize (H1 x).
  rewrite H1.
  split => [H' | H'].
  + apply H'.
  + inversion H' as [Y H''].
    specialize (H Y x H'').
    apply (conj H H').
Qed.

Definition Cups (X : set) :=  (Class (isCups X) (exists_cups X)).
Notation "⊔ X" := (Cups X)(at level 10).
Theorem cups (X : set) :
  forall x, x ∈ (⊔ X) <-> exists Y, x ∈ Y /\ Y ∈ X.
Proof.
  intro x.
  by rewrite class.
Qed.

Definition Cup X Y := Cups (Couple X Y).
Notation "X ∪ Y" := (Cup X Y)(at level 10).
Theorem cup (X Y : set) :
  forall x, x ∈ (X ∪ Y)  <-> x ∈ X \/ x ∈ Y.
Proof.
  intros x.
  split => [H | H].
  + apply class in H.
    induction H as [U H].
    induction H as [xX UXY].
    apply couple in UXY.
    induction UXY as [UX | UY].
    - by subst; apply or_introl.
    - by subst; apply or_intror.
  + apply class.
    unfold isCups.
    induction H as [xX | xY].
    - exists X.
      apply (conj xX).
      apply couple.
      by apply or_introl.
    - exists Y.
      apply (conj xY).
      apply couple.
      by apply or_intror.
Qed.

(* 共通部分  *)
Definition Cap X Y := {X ; (fun x => x ∈ Y)}.
Notation "X ∩ Y" := (Cap X Y) (at level 10).
Theorem cap (X Y : set) :
  forall x, x ∈ (X ∩ Y) <-> x ∈ X /\ x ∈ Y.
Proof.
  intro x.
    by rewrite class.
Qed.

Definition isCaps (X : set) := fun x => forall Y, Y ∈ X -> x ∈ Y.

Theorem not_empty (X : set) :
  X <> ∅ -> exists x, x ∈ X.
Proof.
  apply contrapositive.
  intro H.
  apply DoubleNegative.
  apply Extensionality.
  intro x.
  move: empty => emp.
  rewrite <- allnot_notexists in H.
  specialize (H x).
  specialize (emp x).
  split => [xX | xE].
  + case (H xX).
  + case (emp xE).
Qed.

Theorem exists_caps (X : set) :
  X <> Empty -> exists_class (isCaps X).
Proof.
  intro H.
  specialize (not_empty X H) as H1.
  induction H1 as [E EX].
  specialize (Comprehension (isCaps X) E) as H'.
  induction H' as [Y H'].
  exists Y.
  intro x.
  specialize (H' x) as H''.
  rewrite H''; clear H''.
  unfold isCaps.
  split => [H1 | H1].
  + apply H1.
  + specialize (H1 E EX) as H2.
    apply (conj H2).
    intros Y' H3.
    apply (H1 Y' H3).
Qed.

Definition Caps (X : set) {H : X <> Empty} := Class (isCaps X) (exists_caps X H).
Notation "⊓ X" := (Caps X) (at level 10).
Theorem caps (X : set) {H : X <> Empty}:
  forall x, x ∈ (@Caps X H) <-> forall Y, Y ∈ X -> x ∈ Y.
Proof.
  intro x.
  by rewrite class.
Qed.

(* 後続者函数  *)
Definition Suc (X : set) := X ∪( Single X).

(* 冪集合  *)

Definition isPowerset (X : set) := fun Y => Y ⊂ X.

Theorem exists_powerset (X : set) :
  exists_class (fun Y => Y ⊂ X).
Proof.
  specialize (Power X) as H0.
  induction H0 as [U0 H0].
  specialize (Comprehension (isPowerset X) U0) as H.
  induction H as [U H].
  exists U.
  intro Y.
  specialize (H Y).
  rewrite H.
  split => [H1 | H1].
  + apply H1.
  + specialize (H0 Y H1).
    done.
Qed.

Definition Powerset (X : set) :=
  Class (isPowerset X) (exists_powerset X).
Notation "P[ X ]" := (Powerset X) (at level 10).

Theorem powerset (X : set) :
  forall x, x ∈( P[X]) <-> x ⊂ X.
Proof.
  intro x.
  by rewrite class.
Qed.


Require Export Iron.SimplePCFa.Base.

(* Type Constructors *)
Inductive tycon : Type :=
 | TyConBool  : tycon
 | TyConNat   : tycon.
Hint Constructors tycon.

(* Type Expressions *)
Inductive ty  : Type :=
 | TCon       : tycon -> ty
 | TFun       : ty    -> ty -> ty.
Hint Constructors ty.

(* Baked-in Types *)
Definition tBool := TCon TyConBool.
Definition tNat  := TCon TyConNat.

(* Type Environments *)
Definition tyenv := list ty.


Require Import Omega.
Require Import RelationClasses.
Require Import Coq.Lists.ListDec Decidable.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

Require Import Time.

Set Implicit Arguments.

Lemma time_decidable: decidable_eq Time.t.
Proof.
  ii. destruct (Time.eq_dec x y); [left|right]; eauto.
Qed.

Definition loc_ts_eq_dec (lhs rhs:Loc.t * Time.t):
  {(fst lhs) = (fst rhs) /\ (snd lhs) = (snd rhs)} +
  {(fst lhs) <> (fst rhs) \/ (snd lhs) <> (snd rhs)}.
Proof.
  destruct lhs, rhs.
  destruct (Loc.eq_dec t t1), (Time.eq_dec t0 t2); subst; auto.
Defined.
Global Opaque loc_ts_eq_dec.

Lemma loc_time_decidable: decidable_eq (Loc.t * Time.t).
Proof.
  ii. destruct x, y.
  destruct (loc_ts_eq_dec (t, t0) (t1, t2)); ss.
  - left. des. subst. ss.
  - right. ii. inv H. des; ss.
Qed.

Module TimeMap <: JoinableType.
  Definition t := Loc.t -> Time.t.

  Definition eq := @eq t.

  Definition le (lhs rhs:t): Prop :=
    forall loc, Time.le (lhs loc) (rhs loc).

  Global Program Instance le_PreOrder: PreOrder le.
  Next Obligation. ii. refl. Qed.
  Next Obligation. ii. etrans; eauto. Qed.
  Hint Resolve le_PreOrder_obligation_2.

  Definition bot: t := fun _ => Time.bot.

  Lemma bot_spec (tm:t): le bot tm.
  Proof. ii. apply Time.bot_spec. Qed.

  Definition get (loc:Loc.t) (c:t) := c loc.

  Definition add (l:Loc.t) (ts:Time.t) (tm:t): t :=
    fun l' =>
      if Loc.eq_dec l' l
      then ts
      else get l' tm.

  Definition add_spec l' l ts tm:
    get l' (add l ts tm) =
    if Loc.eq_dec l' l
    then ts
    else get l' tm.
  Proof. auto. Qed.

  Lemma add_spec_eq l ts tm:
    get l (add l ts tm) = ts.
  Proof.
    rewrite add_spec.
    destruct (Loc.eq_dec l l); auto.
    congruence.
  Qed.

  Lemma add_spec_neq l' l ts tm (NEQ: l' <> l):
    get l' (add l ts tm) = get l' tm.
  Proof.
    rewrite add_spec.
    destruct (Loc.eq_dec l' l); auto.
    congruence.
  Qed.

  Definition join (lhs rhs:t): t :=
    fun loc => Time.join (lhs loc) (rhs loc).

  Lemma join_comm lhs rhs: join lhs rhs = join rhs lhs.
  Proof. apply LocFun.ext. i. apply Time.join_comm. Qed.

  Lemma join_assoc a b c: join (join a b) c = join a (join b c).
  Proof.
    apply LocFun.ext. i. apply Time.join_assoc.
  Qed.

  Lemma join_l lhs rhs: le lhs (join lhs rhs).
  Proof. ii. apply Time.join_l. Qed.

  Lemma join_r lhs rhs: le rhs (join lhs rhs).
  Proof. ii. apply Time.join_r. Qed.

  Lemma join_spec lhs rhs o
        (LHS: le lhs o)
        (RHS: le rhs o):
    le (join lhs rhs) o.
  Proof. unfold join. ii. apply Time.join_spec; auto. Qed.

  Definition singleton loc ts :=
    LocFun.add loc ts (LocFun.init Time.bot).

  Lemma singleton_spec loc ts c
        (LOC: Time.le ts (c loc)):
    le (singleton loc ts) c.
  Proof.
    ii. unfold singleton, LocFun.add, LocFun.find.
    condtac; subst; ss. apply Time.bot_spec.
  Qed.

  Lemma singleton_inv loc ts c
        (LE: le (singleton loc ts) c):
    Time.le ts (c loc).
  Proof.
    generalize (LE loc). unfold singleton, LocFun.add, LocFun.find.
    condtac; [|congr]. auto.
  Qed.

  Lemma le_join_l l r
        (LE: le r l):
    join l r = l.
  Proof.
    apply LocFun.ext. i.
    unfold join, Time.join, LocFun.find. condtac; auto.
    apply TimeFacts.antisym; auto.
  Qed.

  Lemma le_join_r l r
        (LE: le l r):
    join l r = r.
  Proof.
    apply LocFun.ext. i.
    unfold join, Time.join, LocFun.find. condtac; auto.
    exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt; eauto.
  Qed.

  Lemma antisym l r
        (LR: le l r)
        (RL: le r l):
    l = r.
  Proof.
    extensionality loc. apply TimeFacts.antisym; auto.
  Qed.
End TimeMap.

Module View <: JoinableType.
  Structure t_ := mk {
    pln: TimeMap.t;
    rlx: TimeMap.t;
  }.
  Definition t := t_.

  Inductive wf (view:t): Prop :=
  | wf_intro
      (PLN_RLX: TimeMap.le (pln view) (rlx view))
  .
  Hint Constructors wf.

  Inductive opt_wf: forall (view:option View.t), Prop :=
  | opt_wf_some
      view
      (WF: wf view):
      opt_wf (Some view)
  | opt_wf_none:
      opt_wf None
  .
  Hint Constructors opt_wf.

  Definition eq := @eq t.

  Inductive le_ (lhs rhs:t): Prop :=
  | le_intro
      (PLN: TimeMap.le (pln lhs) (pln rhs))
      (RLX: TimeMap.le (rlx lhs) (rlx rhs))
  .
  Definition le := le_.

  Global Program Instance le_PreOrder: PreOrder le.
  Next Obligation.
    ii. econs; refl.
  Qed.
  Next Obligation.
    ii. inv H. inv H0. econs; etrans; eauto.
  Qed.
  Hint Resolve le_PreOrder_obligation_2.

  Inductive opt_le: forall (lhs rhs:option t), Prop :=
  | opt_le_none
      rhs:
      opt_le None rhs
  | opt_le_some
      lhs rhs
      (LE: le lhs rhs):
      opt_le (Some lhs) (Some rhs)
  .
  Hint Constructors opt_le.

  Global Program Instance opt_le_PreOrder: PreOrder opt_le.
  Next Obligation.
    ii. destruct x; econs. refl.
  Qed.
  Next Obligation.
    ii. inv H; inv H0; econs. etrans; eauto.
  Qed.
  Hint Resolve opt_le_PreOrder_obligation_2.

  Lemma ext l r
        (PLN: (pln l) = (pln r))
        (RLX: (rlx l) = (rlx r))
    : l = r.
  Proof.
    destruct l, r. f_equal; auto.
  Qed.

  Definition bot: t := mk TimeMap.bot TimeMap.bot.

  Lemma bot_wf: wf bot.
  Proof. econs; refl. Qed.

  Lemma bot_spec (c:t): le bot c.
  Proof. econs; apply TimeMap.bot_spec. Qed.

  Definition join (lhs rhs:t): t :=
    mk (TimeMap.join (pln lhs) (pln rhs))
       (TimeMap.join (rlx lhs) (rlx rhs)).

  Lemma join_comm lhs rhs: join lhs rhs = join rhs lhs.
  Proof. unfold join. f_equal; apply TimeMap.join_comm. Qed.

  Lemma join_assoc a b c: join (join a b) c = join a (join b c).
  Proof.
    unfold join. ss. f_equal.
    - apply TimeMap.join_assoc.
    - apply TimeMap.join_assoc.
  Qed.

  Lemma join_l lhs rhs: le lhs (join lhs rhs).
  Proof. econs; apply TimeMap.join_l. Qed.

  Lemma join_r lhs rhs: le rhs (join lhs rhs).
  Proof. econs; apply TimeMap.join_r. Qed.

  Lemma join_spec lhs rhs o
        (LHS: le lhs o)
        (RHS: le rhs o):
    le (join lhs rhs) o.
  Proof.
    inv LHS. inv RHS.
    econs; apply TimeMap.join_spec; eauto.
  Qed.

  Lemma join_wf
        lhs rhs
        (LHS: wf lhs)
        (RHS: wf rhs):
    wf (join lhs rhs).
  Proof.
    econs.
    - apply TimeMap.join_spec.
      + etrans; [apply LHS|]. apply TimeMap.join_l.
      + etrans; [apply RHS|]. apply TimeMap.join_r.
  Qed.

  Definition bot_unless (cond:bool) (c:t): t :=
    if cond then c else bot.

  Lemma bot_unless_wf
        cond c
        (WF: wf c):
    wf (bot_unless cond c).
  Proof.
    destruct cond; ss. apply bot_wf.
  Qed.

  Definition singleton_ur loc ts :=
    mk (TimeMap.singleton loc ts)
       (TimeMap.singleton loc ts).

  Lemma singleton_ur_wf
        loc ts:
    wf (singleton_ur loc ts).
  Proof.
    econs; ss; refl.
  Qed.

  Lemma singleton_ur_spec loc ts c
        (WF: wf c)
        (TS: Time.le ts ((pln c) loc)):
    le (singleton_ur loc ts) c.
  Proof.
    econs; s;
      try apply TimeMap.bot_spec;
      try apply TimeMap.singleton_spec; auto.
    - etrans; eauto. apply WF.
  Qed.

  Lemma singleton_ur_inv loc ts c
        (LE: le (singleton_ur loc ts) c):
    Time.le ts ((pln c) loc).
  Proof.
    apply TimeMap.singleton_inv. apply LE.
  Qed.

  Definition singleton_rw loc ts :=
    mk TimeMap.bot
       (TimeMap.singleton loc ts).

  Lemma singleton_rw_wf
        loc ts:
    wf (singleton_rw loc ts).
  Proof.
    econs; ss; try refl. apply TimeMap.bot_spec.
  Qed.

  Lemma singleton_rw_spec loc ts c
        (WF: wf c)
        (TS: Time.le ts ((rlx c) loc)):
    le (singleton_rw loc ts) c.
  Proof.
    econs; s;
      try apply TimeMap.bot_spec;
      try apply TimeMap.singleton_spec; auto.
  Qed.

  Lemma singleton_rw_inv loc ts c
        (LE: le (singleton_rw loc ts) c):
    Time.le ts ((rlx c) loc).
  Proof.
    apply TimeMap.singleton_inv. apply LE.
  Qed.

  Definition singleton_ur_if (cond:bool) loc ts :=
    (if cond then singleton_ur else singleton_rw) loc ts.

  Lemma singleton_ur_if_wf
        cond loc ts:
    wf (singleton_ur_if cond loc ts).
  Proof.
    destruct cond; ss.
    - apply singleton_ur_wf.
    - apply singleton_rw_wf.
  Qed.

  Lemma singleton_ur_if_spec (cond:bool) loc ts c
        (WF: wf c)
        (TS: Time.le ts ((if cond then (pln c) else (rlx c)) loc)):
    le (singleton_ur_if cond loc ts) c.
  Proof.
    destruct cond; ss.
    - apply singleton_ur_spec; ss.
    - apply singleton_rw_spec; ss.
  Qed.

  Lemma singleton_ur_if_inv cond loc ts c
        (LE: le (singleton_ur_if cond loc ts) c):
    Time.le ts ((if cond then (pln c) else (rlx c)) loc).
  Proof.
    destruct cond; ss.
    - apply singleton_ur_inv. ss.
    - apply singleton_rw_inv. ss.
  Qed.

  Lemma le_join_l l r
        (LE: le r l):
    join l r = l.
  Proof.
    unfold join. destruct l. ss.
    f_equal; apply TimeMap.le_join_l; apply LE.
  Qed.

  Lemma le_join_r l r
        (LE: le l r):
    join l r = r.
  Proof.
    unfold join. destruct r. ss.
    f_equal; apply TimeMap.le_join_r; apply LE.
  Qed.

  Lemma antisym l r
        (LR: le l r)
        (RL: le r l):
    l = r.
  Proof.
    destruct l, r. inv LR. inv RL. ss. f_equal.
    - apply TimeMap.antisym; auto.
    - apply TimeMap.antisym; auto.
  Qed.

  Lemma opt_antisym l r
        (LR: opt_le l r)
        (RL: opt_le r l):
    l = r.
  Proof.
    inv LR; inv RL; ss. f_equal.
    apply antisym; ss.
  Qed.

  Lemma timemap_le_le tm1 tm2
        (LE: TimeMap.le tm1 tm2):
    le (mk tm1 tm1) (mk tm2 tm2).
  Proof. econs; eauto. Qed.

  Definition unwrap (view:option t): t :=
    match view with
    | Some view => view
    | None => bot
    end.

  Lemma unwrap_opt_wf
        view
        (WF: opt_wf view):
    wf (unwrap view).
  Proof.
    inv WF; ss. apply bot_wf.
  Qed.

  Lemma unwrap_opt_le
        view1 view2
        (WF: opt_le view1 view2):
    le (unwrap view1) (unwrap view2).
  Proof.
    inv WF; ss. apply bot_spec.
  Qed.

  Lemma opt_None_spec rhs:
    opt_le None rhs.
  Proof. econs. Qed.

  Lemma join_bot_l rhs:
    join bot rhs = rhs.
  Proof.
    apply antisym.
    - apply join_spec.
      + apply bot_spec.
      + refl.
    - apply join_r.
  Qed.

  Lemma join_bot_r lhs:
    join lhs bot = lhs.
  Proof.
    rewrite join_comm.
    apply join_bot_l.
  Qed.

  Lemma join_le
        v1 v2 w1 w2
        (LE1: le v1 w1)
        (LE2: le v2 w2):
    le (join v1 v2) (join w1 w2).
  Proof. eauto using join_spec, join_l, join_r. Qed.

  Lemma opt_le_ts
        v1 v2 loc
        (LE: opt_le v1 v2):
    Time.le ((rlx (unwrap v1)) loc) ((rlx (unwrap v2)) loc).
  Proof.
    inv LE; ss.
    - unfold TimeMap.bot. apply Time.bot_spec.
    - inv LE0. ss.
  Qed.
End View.