(** 5. Proof of the compiler, with correct states *)
Require Import Arith beta_reduction compiler closed_lterm krivine.
Require Import List lterm substitute_list substitute_varlist.

(** Correct environment/stack/state (that's the same object) *)
Inductive correct_env: krivine_env -> Prop :=
  | Correct_env_nil: correct_env KEnv_nil
  | Correct_env:
    forall (c0: krivine_code) (e0 e: krivine_env),
    closed_code (klength e0) c0 -> correct_env e0 -> correct_env e ->
    correct_env (KEnv c0 e0 e)
.

(** A correct state is a correct non-empty environment *)
Definition correct_state (st: krivine_env) : Prop :=
  st <> KEnv_nil /\ correct_env st
.

(** A non-empty correct environment is a correct state *)
Lemma correct_env_is_state:
  forall (c0: krivine_code) (e0 e: krivine_env),
  correct_env (KEnv c0 e0 e) -> correct_state (KEnv c0 e0 e).
Proof.
  intros c0 e0 e H.
  unfold correct_state.
  split; trivial.
  intro H0. inversion H0.
Save.

(** Link the lengths of the lists in tau_env *)
Lemma length_tau_env:
  forall e: krivine_env, correct_env e -> length (tau_env e) = klength e.
Proof.
  induction e; simpl; trivial.
  intro H; inversion H. clear H0 H1 H2 c0 e0 e.
  inversion H3. destruct H0. rewrite H0; simpl.
  rewrite IHe2; trivial.
Save.

(** An environment with Nop as code is always incorrect *)
Lemma incorrect_Nop:
  forall (e0 e: krivine_env), ~ correct_env (KEnv Nop e0 e).
Proof.
  intros e0 e H.
  inversion H.
  contradict H3.
  apply not_closed_Nop.
Save.

(** A state with Access is invalid with an empty environment *)
Lemma incorrect_Access:
  forall (n: nat) (c: krivine_code) (s: krivine_env),
  ~ correct_env (KEnv (Access n c) KEnv_nil s).
Proof.
  intros n c s H.
  (* Use (closed_Access O n c) *)
  cut (n < O).
    intro Hfalse; contradict Hfalse; auto with arith.
  apply (closed_Access O n c).
  inversion H. trivial.
Save.

(** 5.3. *)
Theorem step_correctness:
  forall st: krivine_env, correct_state st -> correct_state (krivine_step st).
Proof.
  (* Use correct_env instead of correct_state in hypothesis *)
  induction st; trivial. clear IHst1 IHst2.
  intro H. inversion H. clear H H0.
  induction k; inversion H1; clear H H0 H2 c0 e0 e.

  (* correct_state (krivine_step (KEnv Nop st1 st2)) *)
  contradict H1.
  apply incorrect_Nop.

  (* correct_state (krivine_step (KEnv (Access n k) st1 st2)) *)
  induction st1. contradict H1. apply incorrect_Access.
  clear IHst1_1 IHst1_2.
  (* Now st1 = KEnv k0 st1_1 st1_2 *)
  inversion H4. clear H H0 H2 c0 e0 e.
  simpl.
  induction n; apply correct_env_is_state; apply Correct_env; trivial.
  apply closed_Access_iff.
  apply lt_S_n.
  generalize H3; simpl.
  apply closed_Access.

  (* correct_state (krivine_step (KEnv (Grab k) st1 st2)) *)
  induction st2; simpl; apply correct_env_is_state; trivial.
  clear IHst2_1 IHst2_2.
  inversion H5. clear H H0 H2 c0 e0 e.
  apply Correct_env; simpl; trivial.
    apply closed_Grab_S; trivial.
    apply Correct_env; trivial.

  (* correct_state (krivine_step (KEnv (Push k1 k2) st1 st2)) *)
  simpl; apply correct_env_is_state.
  apply Correct_env; simpl; trivial.
    apply (closed_Push2 (klength st1) k1 k2); trivial.
    apply Correct_env; trivial.
    apply (closed_Push1 (klength st1) k1 k2); trivial.
Save.

(** 5.4. *)
(** tau_state is never None for correct state *)
Lemma tau_state_correct_is_some:
  forall st: krivine_env, correct_state st -> exists t: lterm, tau_state st = Some t.
Proof.
  (* st is not nil *)
  induction st; intro H; inversion H. contradict H0; trivial.
  unfold tau_state; simpl.
  inversion H1. clear H2 H3 H4 c0 e0 e.
  inversion H5. destruct H2. rewrite H2; simpl.
  apply list_lterm_to_apply_is_some.
Save.

(** Lemma for Beta-reduction and tau_state, which uses list_lterm_to_apply *)
Lemma beta_reduct_list_lterm_to_apply:
  forall (l: list lterm) (t u t' u': lterm), beta_reduct t u ->
    Some t' = list_lterm_to_apply (Some t) l ->
    Some u' = list_lterm_to_apply (Some u) l ->
    beta_reduct t' u'.
Proof.
  induction l; intros t u t' u' H; simpl; intros Ht Hu.
    inversion Ht; inversion Hu; trivial.
  apply (IHl (Apply t a) (Apply u a)); trivial.
  apply Beta_reduct_close_apply1; trivial.
Save.

(** A correct environment is closed *)
Lemma closed_correct_env:
  forall e: krivine_env, correct_env e -> closed_n_list O (tau_env e).
Proof.
  induction e; simpl; trivial; intro H.
  inversion H. clear H0 H1 H2 c0 e0 e.
  inversion H3. destruct H0. rewrite H0; simpl.
  split.
    apply substitute_list_closed.
      apply IHe1; trivial.
      rewrite length_tau_env; trivial.
    apply IHe2; trivial.
Save.

(** Here are some lemmas with krivine_step *)
Lemma tau_env_kstep_Access:
  forall (n: nat) (c: krivine_code) (e s: krivine_env),
  correct_env (KEnv (Access n c) e s) ->
  tau_env (krivine_step (KEnv (Access n c) e s)) =
    tau_env (KEnv (Access n c) e s).
Proof.
  intros n c e s H; simpl.
  inversion H. clear H0 H1 H2 c0 e0 e1.

  (* Prove n < klength e *)
  inversion H3. destruct H0. simpl in H0. inversion H0; clear H0.
  rewrite <- H6 in H1 ; clear H6 x; simpl in H1.

  (* Prove e <> Kenv_nil *)
  induction e; simpl.
    contradict H1; simpl. auto with arith.
  clear IHe1 IHe2.

  (* Prove tau_code k <> None *)
  inversion H4. clear H0 H2 H6 c0 e0 e.
  inversion H7. destruct H0.
  rewrite H0; simpl.

  (* case n = 0 is immediate *)
  induction n; simpl. rewrite H0; trivial. clear IHn.

  (* Need to prove that n < length (tau_env e2) *)
  rewrite (substitute_vl_nth_from_O n (tau_env e2) (Var n)).
  rewrite (substitute_vl_nth_from_O n (tau_env e2) (Var (S n))).
  rewrite (nth_indep (tau_env e2) (Var n) (Var (S n))); trivial.
  rewrite (length_tau_env e2); trivial.
  simpl in H1.
  auto with arith.
Save.

Lemma tau_state_kstep_Access:
  forall (n: nat) (c: krivine_code) (e s: krivine_env),
  correct_env (KEnv (Access n c) e s) ->
  tau_state (krivine_step (KEnv (Access n c) e s)) =
    tau_state (KEnv (Access n c) e s).
Proof.
  intros n c e s H; unfold tau_state.
  rewrite tau_env_kstep_Access; trivial.
Save.

Lemma tau_state_kstep_Push:
  forall (c0 c: krivine_code) (e s: krivine_env),
  correct_env (KEnv (Push c0 c) e s) ->
  tau_state (krivine_step (KEnv (Push c0 c) e s)) =
    tau_state (KEnv (Push c0 c) e s).
Proof.
  intros c0 c e s H; unfold tau_state; simpl.
  inversion H. clear H0 H1 H2 c1 e0 e1.

  (* Prove tau_code c <> None *)
  inversion H3. destruct H0. simpl in H0.
  cut (exists ot: option lterm, tau_code c = ot).
    Focus 2. exists (tau_code c); trivial.
  intro Hot; destruct Hot as [ot Hot].
  rewrite Hot in H0.
  induction ot. Focus 2. inversion H0.
  rewrite Hot.

  (* Prove tau_code c0 <> None *)
  cut (exists ot0: option lterm, tau_code c0 = ot0).
    Focus 2. exists (tau_code c0); trivial.
  intro Hot0; destruct Hot0 as [ot0 Hot0].
  rewrite Hot0 in H0.
  induction ot0. Focus 2. inversion H0.
  rewrite Hot0; trivial.
Save.

Lemma tau_state_kstep_Grab:
  forall (c: krivine_code) (e: krivine_env) (s: krivine_env) (t u: lterm),
  correct_env (KEnv (Grab c) e s) ->
  tau_state (KEnv (Grab c) e s) = Some t ->
  tau_state (krivine_step (KEnv (Grab c) e s)) = Some u ->
  (t = u \/ beta_reduct t u).
Proof.
  intros c e s t u H. unfold tau_state; simpl.
  inversion H. clear H0 H1 H2 c0 e0 e1.

  (* Prove tau_code c <> None *)
  inversion H3. destruct H0. simpl in H0.
  cut (exists ot: option lterm, tau_code c = ot).
    Focus 2. exists (tau_code c); trivial.
  intro Hc; destruct Hc as [ot Hc].
  rewrite Hc; rewrite Hc in H0.
  induction ot; simpl. Focus 2. inversion H0.

  (* Remove variable x *)
  simpl in H0; inversion H0 as [Hx]; clear H0.
  rewrite <- Hx in H1; simpl in H1; clear Hx x.

  (* If the stack is empty, krivine_step is identity, this is almost trivial *)
  induction s; simpl; rewrite Hc; simpl.
    intros Ht Hu. inversion Ht as [Ht']. rewrite Ht'; rewrite Ht' in Hu.
    inversion Hu. auto.
  clear IHs1 IHs2.
  (* Now s = KEnv k s1 s2 *)

  (* Prove tau_code k <> None *)
  inversion H5. clear H0 H2 H6 c0 e0 e1.
  inversion H7. destruct H0.
  rewrite H0; simpl.

  (* Use beta_reduct_list_lterm_to_apply *)
  intros Ht Hu. apply or_intror.
  apply (beta_reduct_list_lterm_to_apply (tau_env s2)
      (Apply (Lambda (subst_list a 1 (tau_env e))) (subst_list x 0 (tau_env s1)))
      (subst_list a 0 (subst_list x 0 (tau_env s1) :: tau_env e))).
  Focus 2. rewrite Ht; trivial.
  Focus 2. rewrite Hu; trivial.

  (* Prove beta_reduct *)
  rewrite substitute_list_cons_closed_eq.
  rewrite substitute_list_singleton.
  apply Beta_reduct_step.

  (* Prove closed_list (tau_env e) *)
  apply closed_correct_env; trivial.
Save.

Lemma tau_state_kstep_all:
  forall (st: krivine_env) (t u: lterm), correct_state st ->
  tau_state st = Some t ->
  tau_state (krivine_step st) = Some u ->
    (t = u \/ beta_reduct t u).
Proof.
  intros st t u Hst Ht Hu.

  (* st = KEnv k st1 st2 *)
  inversion Hst as [HstNeq HstEnv].
  induction st. contradict HstNeq; trivial.
  clear IHst1 IHst2.

  (* Induction on code *)
  induction k.

  (* Nop is incorrect *)
  contradict HstEnv.
  apply incorrect_Nop.

  (* Access *)
  rewrite (tau_state_kstep_Access n k st1 st2) in Hu; trivial.
  rewrite Hu in Ht. inversion Ht. auto.

  (* Grab *)
  apply (tau_state_kstep_Grab k st1 st2); trivial.

  (* Push *)
  rewrite (tau_state_kstep_Push k1 k2 st1 st2) in Hu; trivial.
  rewrite Hu in Ht. inversion Ht. auto.
Save.

(** 5.4. Theorem *)
Theorem krivine_step_is_beta_reduct:
  forall st: krivine_env, correct_state st ->
  exists t: lterm, Some t = tau_state st ->
  exists u: lterm, Some u = tau_state (krivine_step st) ->
    (t = u \/ beta_reduct t u).
Proof.
  intros st Hst.

  (* Use tau_state_correct_is_some *)
  elim (tau_state_correct_is_some st); trivial.
  intros t Ht. exists t; intro Hcleared; clear Hcleared.
  elim (tau_state_correct_is_some (krivine_step st)).
    Focus 2. apply step_correctness; trivial.
  intros u Hu. exists u; intro Hcleared; clear Hcleared.

  apply (tau_state_kstep_all st); trivial.
Save.

(** 5.5. *)
(** Extend 5.3 to krivine_step_star *)
Theorem krivine_step_star_correctness:
  forall st st': krivine_env, krivine_step_star st st' ->
  correct_state st -> correct_state st'.
Proof.
  intros st st' H.
  induction H; trivial.
  intro H0.
  apply IHkrivine_step_star.
  apply step_correctness; trivial.
Save.

(** Extend 5.4 to krivine_step_star *)
Lemma tau_state_kstep_star_all:
  forall (st st': krivine_env),
  krivine_step_star st st' -> correct_state st ->
    forall (t u: lterm),
    tau_state st = Some t -> tau_state st' = Some u ->
    beta_reduct_star t u.
Proof.
  intros st st' H.
  induction H; intros Hst t v Ht Hv.
    rewrite Hv in Ht. inversion Ht. apply Beta_reduct_star_eq.
  (* Introduce Some u = tau_state (krivine_step st) *)
  elim (tau_state_correct_is_some (krivine_step st)).
    Focus 2. apply step_correctness; trivial.
  intros u Hu.

  (* t and u may be equals *)
  elim (tau_state_kstep_all st t u); trivial; intro H0.
    (* t = u *)
    rewrite H0.
    apply IHkrivine_step_star; trivial.
    apply step_correctness; trivial.

    (* beta_reduct t u *)
    apply (Beta_reduct_star_step t u v); trivial.
    apply IHkrivine_step_star; trivial.
    apply step_correctness; trivial.
Save.

Theorem krivine_step_is_beta_reduct_star:
  forall st st': krivine_env, krivine_step_star st st' -> correct_state st ->
  exists t: lterm, Some t = tau_state st ->
  exists u: lterm, Some u = tau_state st' ->
    beta_reduct_star t u.
Proof.
  intros st st' H Hst.
  elim (tau_state_correct_is_some st); trivial.
  intros t Ht. exists t; intro Hcleared; clear Hcleared.
  elim (tau_state_correct_is_some st').
    Focus 2. apply (krivine_step_star_correctness st st'); trivial.
  intros u Hu. exists u; intro Hcleared; clear Hcleared.
  apply (tau_state_kstep_star_all st st'); trivial.
Save.

(** A compilation state is correct *)
Lemma comp_state_is_correct:
  forall t: lterm, closed t -> correct_state (comp_state t).
Proof.
  intros t H.
  unfold comp_state. apply correct_env_is_state.
  apply Correct_env; simpl.
    unfold closed_code.
    rewrite compile_term_tau_ident.
    exists t; split; trivial.

    apply Correct_env_nil.
    apply Correct_env_nil.
Save.

(** Compilation proof *)
Theorem correct_compilation:
  forall t: lterm, closed t ->
  forall st': krivine_env, krivine_step_star (comp_state t) st' ->
  exists u: lterm, Some u = tau_state st' -> beta_reduct_star t u.
Proof.
  intros t Ht st' H.
  elim (tau_state_correct_is_some st').
  intros u Hu. exists u; intro Hcleared; clear Hcleared.
  apply (tau_state_kstep_star_all (comp_state t) st'); trivial.
    apply comp_state_is_correct; trivial.
    apply compile_term_tau_state_ident.

  (* Prove correct_state st' *)
  apply (krivine_step_star_correctness (comp_state t) st'); trivial.
  apply comp_state_is_correct; trivial.
Save.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export complements_cercle.
Set Implicit Arguments.
Unset Strict Implicit.

Lemma existence_intersection_droite_cercle_centre :
 forall (r : R) (A B : PO),
 A <> B -> r >= 0 -> exists C : PO, alignes A B C /\ distance A C = r.
intros.
assert (distance A B <> 0); auto with geo.
elim
 existence_representant_mult_vecteur
  with (A := A) (B := A) (C := B) (k := / distance A B * r);
 intros C H2.
exists C.
split; [ try assumption | idtac ].
apply (colineaire_alignes H2); auto.
assert (Rsqr (distance A C) = Rsqr r).
unfold Rsqr in |- *; repeat rewrite <- carre_scalaire_distance.
rewrite H2.
Simplscal.
rewrite carre_scalaire_distance.
field.
auto with real.
auto with real.
apply Rsqr_inj; auto with geo real.
Qed.

Theorem intersection_cercle_droite :
 forall A B O D H : PO,
 A <> B ->
 H = projete_orthogonal A B O ->
 distance O H <= distance O D ->
 exists C : PO, alignes A B C /\ cercle_rayon O D C.
icercle.
assert (Rsqr (distance O D) + - Rsqr (distance O H) >= 0).
unfold Rsqr in |- *.
RReplace (distance O D * distance O D + - (distance O H * distance O H))
 ((distance O D + - distance O H) * (distance O D + distance O H)).
assert (distance O D >= 0); auto with geo.
assert (distance O H >= 0); auto with geo.
assert (distance O D + distance O H >= 0).
lra.
assert (distance O D + - distance O H >= 0).
lra.
RReplace 0 (0 * (distance O D + distance O H)).
apply Rmult_ge_compat_r; auto.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := O) (H := H);
 [ intros; auto | auto | auto ].
discrimine H A.
assert (H <> B).
contrapose H0.
rewrite <- H7; auto.
elim
 existence_intersection_droite_cercle_centre
  with
    (r := sqrt (Rsqr (distance O D) + - Rsqr (distance O H)))
    (A := H)
    (B := B);
 [ intros C H8; elim H8; [ intros H9 H10; try clear H8; try exact H10 ]
 | auto
 | auto ].
exists C; split; auto.
assert (Rsqr (distance O D) = Rsqr (distance O C)).
elim (Pythagore H O C); intros.
rewrite H8; auto.
replace (Rsqr (distance H C)) with (distance H C * distance H C);
 auto with real.
rewrite H10.
rewrite sqrt_sqrt; auto with real.
rewrite (distance_sym H O); ring.
halignes H9 k.
apply ortho_sym.
rewrite H12; pattern H at 1 in |- *; rewrite H6; auto with geo.
auto with real.
apply Rsqr_inj; auto with geo real.
auto with real.
elim
 existence_intersection_droite_cercle_centre
  with
    (r := sqrt (Rsqr (distance O D) + - Rsqr (distance O H)))
    (A := H)
    (B := A);
 [ intros C H8; elim H8; [ intros H9 H10; try clear H8; try exact H10 ]
 | auto
 | auto ].
exists C; split; auto.
halignes H9 k.
halignes H4 k'.
apply colineaire_alignes with (k' + - (k * k')).
VReplace (vec A C) (add_PP (vec A H) (vec H C)).
rewrite H7.
VReplace (vec H A) (mult_PP (-1) (vec A H)).
rewrite H8; Ringvec.
assert (Rsqr (distance O D) = Rsqr (distance O C)).
elim (Pythagore H O C); intros.
rewrite H7; auto.
replace (Rsqr (distance H C)) with (distance H C * distance H C);
 auto with real.
rewrite H10.
rewrite sqrt_sqrt; auto with real.
rewrite (distance_sym H O); ring.
halignes H9 k.
halignes H4 k'.
apply ortho_sym.
rewrite H11.
VReplace (vec H A) (mult_PP (-1) (vec A H)).
rewrite H12.
VReplace (mult_PP k (mult_PP (-1) (mult_PP k' (vec A B))))
 (mult_PP (- (k * k')) (vec A B)).
auto with geo.
apply Rsqr_inj; auto with geo real.
auto with real.
Qed.

Lemma unicite_contact_cercle_droite_tangente :
 forall A B O D H C : PO,
 A <> B ->
 H = projete_orthogonal A B O ->
 cercle_rayon O D H -> alignes A B C -> cercle_rayon O D C -> H = C.
icercle.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := O) (H := H);
 [ intros; auto | auto | auto ].
elim (Pythagore H O C); intros.
assert (distance H C = 0); auto with geo.
apply Rsqr_inj; auto with geo real.
assert (Rsqr (distance O C) + - Rsqr (distance H O) = 0).
rewrite (distance_sym H O).
rewrite <- H4; rewrite <- H2; (unfold Rsqr in |- *; ring).
replace (Rsqr 0) with 0; [ idtac | unfold Rsqr in |- *; ring ].
rewrite <- H9; rewrite H7; auto.
unfold Rsqr in |- *; ring.
halignes H3 x.
halignes H5 y.
apply ortho_sym.
replace (vec H C) with (mult_PP (x + - y) (vec A B)); auto with geo.
VReplace (vec H C) (add_PP (vec A C) (mult_PP (-1) (vec A H))).
rewrite H11; rewrite H10; Ringvec.
Qed.

Theorem tangente_cercle_contact_unique :
 forall A B O M C : PO,
 B <> M ->
 tangente_cercle O A B M -> alignes B M C -> cercle_rayon O A C -> B = C.
intros.
hcercle H0.
assert (B = projete_orthogonal B M O).
apply def_projete_orthogonal; auto with geo.
apply
 (unicite_contact_cercle_droite_tangente (A:=B) (B:=M) (O:=O) (D:=A) (H:=B)
    (C:=C)); auto.
Qed.

Theorem intersection2_cercle_droite :
 forall A B O H : PO,
 A <> B ->
 O <> A ->
 H = projete_orthogonal A B O ->
 distance O H < distance O A ->
 exists C : PO, A <> C /\ alignes A B C /\ cercle_rayon O A C.
icercle.
assert (Rsqr (distance O A) + - Rsqr (distance O H) > 0).
unfold Rsqr in |- *.
assert (distance O A <> 0); auto with geo.
cut (distance O A >= 0); auto with geo.
unfold Rge in |- *; intros.
elim H5;
 [ intros H6; try clear H5 | intros H6; absurd (distance O A = 0); auto ].
RReplace (distance O A * distance O A + - (distance O H * distance O H))
 ((distance O A + - distance O H) * (distance O A + distance O H)).
assert (0 < distance O A + - distance O H).
lra.
assert (0 < distance O A + distance O H).
apply Rplus_lt_le_0_compat; auto with real geo.
assert (0 < (distance O A + - distance O H) * (distance O A + distance O H)).
apply Rmult_lt_0_compat; auto with real.
lra.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := O) (H := H);
 [ intros; auto | auto | auto ].
assert (H <> A).
assert (distance O H <> distance O A); auto with real.
contrapose H7.
rewrite <- H8; auto.
halignes H5 k.
elim existence_symetrique with (A := H) (B := A); (intros C; intros).
assert (H = milieu A C); auto with geo.
assert (vec A C = mult_PP 2 (vec A H)); auto with geo.
exists C; split; auto.
generalize (distinct_produit_vecteur (A:=A) (B:=H) (C:=C) (a:=2)); intros H18;
 apply H18; auto with real geo.
split; [ idtac | try assumption ].
apply colineaire_alignes with (2 * k).
rewrite H11; rewrite H8; Ringvec.
assert (Rsqr (distance O A) = Rsqr (distance O C)).
elim (Pythagore H O C); intros.
rewrite H12; auto.
replace (Rsqr (distance H C)) with (Rsqr (distance H A)).
elim (Pythagore H O A); intros.
rewrite H14; auto.
apply ortho_sym.
replace (vec H A) with (mult_PP (- k) (vec A B)).
auto with geo.
VReplace (vec H A) (mult_PP (-1) (vec A H)).
rewrite H8; Ringvec.
rewrite (milieu_distance H10); auto.
replace (vec H C) with (vec A H).
apply ortho_sym.
rewrite H8; auto with geo.
auto with geo.
auto with geo.
Qed.

Definition cercles_tangents (O A O' A' : PO) :=
  O <> A ->
  O' <> A' ->
  exists B : PO, alignes O B O' /\ cercle_rayon O A B /\ cercle_rayon O' A' B.

Lemma auto_cercles_tangents :
 forall O A : PO, O <> A -> cercles_tangents O A O A.
unfold cercles_tangents in |- *; intros.
exists A.
icercle.
Qed.

Lemma cercles_concentriques_tangents_egaux :
 forall O A A' : PO,
 O <> A -> O <> A' -> cercles_tangents O A O A' -> cercle_rayon O A A'.
unfold cercles_tangents in |- *; icercle.
elim H1;
 [ intros B H2; elim H2;
    [ intros H3 H4; elim H4;
       [ intros H5 H6; try clear H4 H2 H1; try exact H5 ] ]
 | auto
 | auto ].
rewrite H6; auto.
Qed.

Lemma cercles_tangents_tangente_commune :
 forall O A O' A' : PO,
 O <> A ->
 O' <> A' ->
 cercles_tangents O A O' A' ->
 exists B : PO,
   (exists M : PO,
      B <> M /\ tangente_cercle O A B M /\ tangente_cercle O' A' B M).
unfold cercles_tangents, tangente_cercle in |- *; intros.
elim H1;
 [ intros B H2; elim H2;
    [ intros H3 H4; elim H4;
       [ intros H5 H6; try clear H4 H2 H1; try exact H5 ] ]
 | auto
 | auto ].
assert (O <> B).
hcercle H5.
apply (isometrie_distinct (A:=O) (B:=A) (A':=O) (B':=B)); auto with geo.
soit_orthogonal B O M.
exists B; exists M.
split;
 [ auto
 | split; [ split; [ try assumption | auto with geo ] | try assumption ] ].
split; [ try assumption | idtac ].
halignes H3 k.
apply ortho_sym.
VReplace (vec B O') (add_PP (vec B O) (vec O O')).
rewrite H7.
VReplace (add_PP (vec B O) (mult_PP k (vec O B)))
 (mult_PP (- k + 1) (vec B O)).
auto with geo.
Qed.

Lemma tangente_commune_cercles_tangents :
 forall O A O' A' B M : PO,
 O <> A ->
 O' <> A' ->
 B <> M ->
 tangente_cercle O A B M ->
 tangente_cercle O' A' B M -> cercles_tangents O A O' A'.
unfold cercles_tangents, tangente_cercle in |- *; intros.
repeat applatit_and.
exists B.
split; [ idtac | split; try assumption ].
assert (O <> B).
hcercle H3.
apply (isometrie_distinct (A:=O) (B:=A) (A':=O) (B':=B)); auto with geo.
elim
 orthogonal_colineaires
  with (A := B) (B := M) (C := B) (D := O) (E := B) (F := O');
 [ intros | auto | auto | auto | auto ].
apply colineaire_alignes with (- x + 1).
VReplace (vec O O') (add_PP (vec O B) (vec B O')).
rewrite H9.
VReplace (add_PP (vec O B) (mult_PP x (vec B O)))
 (mult_PP (- x + 1) (vec O B)); auto.
Qed.

Lemma point_contact_k_positif :
 forall (O A O' A' B : PO) (k : R),
 k >= 0 ->
 O <> A ->
 O' <> A' ->
 vec O' B = mult_PP k (vec O B) ->
 cercle_rayon O A B ->
 cercle_rayon O' A' B ->
 mult_PP (distance O A) (vec O' B) = mult_PP (distance O' A') (vec O B).
icercle.
assert (distance O A <> 0); auto with geo.
assert (Rsqr k = Rsqr (distance O' A' * / distance O A)).
unfold Rsqr in |- *.
assert (O <> B).
apply (isometrie_distinct (A:=O) (B:=A) (A':=O) (B':=B)); auto with geo.
assert (distance O B <> 0); auto with geo.
apply Rmult_eq_reg_l with (scalaire (vec O B) (vec O B)); auto with geo real.
replace (scalaire (vec O B) (vec O B) * (k * k)) with
 (scalaire (mult_PP k (vec O B)) (mult_PP k (vec O B))).
rewrite <- H2.
repeat rewrite carre_scalaire_distance.
rewrite H3; rewrite H4.
RReplace
 (distance O B * distance O B *
  (distance O' B * / distance O B * (distance O' B * / distance O B)))
 (distance O' B * distance O' B *
  (distance O B * / distance O B * (distance O B * / distance O B))).
RReplace (distance O B * / distance O B) 1.
ring.
Simplscal.
rewrite H2.
assert (k = distance O' A' * / distance O A).
apply Rsqr_inj; auto with real geo.
rewrite H7.
VReplace
 (mult_PP (distance O A)
    (mult_PP (distance O' A' * / distance O A) (vec O B)))
 (mult_PP (distance O' A' * (distance O A * / distance O A)) (vec O B)).
RReplace (distance O A * / distance O A) 1.
Ringvec.
Qed.

Lemma point_contact_k_negatif :
 forall (O A O' A' B : PO) (k : R),
 k <= 0 ->
 O <> A ->
 O' <> A' ->
 vec O' B = mult_PP k (vec O B) ->
 cercle_rayon O A B ->
 cercle_rayon O' A' B ->
 mult_PP (distance O A) (vec O' B) = mult_PP (- distance O' A') (vec O B).
icercle.
assert (distance O A <> 0); auto with geo.
assert (Rsqr k = Rsqr (distance O' A' * / distance O A)).
unfold Rsqr in |- *.
assert (O <> B).
apply (isometrie_distinct (A:=O) (B:=A) (A':=O) (B':=B)); auto with geo.
assert (distance O B <> 0); auto with geo.
apply Rmult_eq_reg_l with (scalaire (vec O B) (vec O B)); auto with geo real.
replace (scalaire (vec O B) (vec O B) * (k * k)) with
 (scalaire (mult_PP k (vec O B)) (mult_PP k (vec O B))).
rewrite <- H2.
repeat rewrite carre_scalaire_distance.
rewrite H3; rewrite H4.
RReplace
 (distance O B * distance O B *
  (distance O' B * / distance O B * (distance O' B * / distance O B)))
 (distance O' B * distance O' B *
  (distance O B * / distance O B * (distance O B * / distance O B))).
RReplace (distance O B * / distance O B) 1.
ring.
Simplscal.
rewrite H2.
assert (- k = distance O' A' * / distance O A).
apply Rsqr_inj; auto with real geo.
rewrite <- H6; unfold Rsqr in |- *; ring.
RReplace k (- - k).
rewrite H7.
VReplace
 (mult_PP (distance O A)
    (mult_PP (- (distance O' A' * / distance O A)) (vec O B)))
 (mult_PP (- (distance O' A' * (distance O A * / distance O A))) (vec O B)).
RReplace (distance O A * / distance O A) 1.
Ringvec.
Qed.

Lemma point_contact_cercles_tangents :
 forall O A O' A' B : PO,
 O <> A ->
 O' <> A' ->
 alignes O B O' ->
 cercle_rayon O A B ->
 cercle_rayon O' A' B ->
 mult_PP (distance O A) (vec O' B) = mult_PP (distance O' A') (vec O B) \/
 mult_PP (distance O A) (vec O' B) = mult_PP (- distance O' A') (vec O B).
icercle.
assert (O <> B).
apply (isometrie_distinct (A:=O) (B:=A) (A':=O) (B':=B)); auto with geo.
cut (alignes B O O'); [ intros H20 | auto with geo ].
halignes H20 k.
absurd (B = O); auto.
assert (vec O' B = mult_PP k (vec O B)).
VReplace (vec O' B) (mult_PP (-1) (vec B O')).
rewrite H5; Ringvec.
elim (Rlt_le_dec k 0); intros.
right; try assumption.
apply point_contact_k_negatif with k; auto with real.
left; try assumption.
apply point_contact_k_positif with k; auto with real.
Qed.

Lemma k_negatif_barycentre :
 forall (O A O' A' B : PO) (k : R),
 k <= 0 ->
 O <> A ->
 O' <> A' ->
 vec O' B = mult_PP k (vec O B) ->
 cercle_rayon O A B ->
 cercle_rayon O' A' B ->
 B = barycentre (cons (distance O A) O') (cons (distance O' A') O).
intros.
assert
 (mult_PP (distance O A) (vec O' B) = mult_PP (- distance O' A') (vec O B)).
apply point_contact_k_negatif with k; auto.
assert (distance O A <> 0); auto with geo.
assert (distance O' A' <> 0); auto with geo.
assert (distance O A >= 0); auto with geo.
assert (distance O' A' >= 0); auto with geo.
assert (distance O A + distance O' A' <> 0).
apply tech_Rplus; auto with geo real.
elim H9; intros; auto.
absurd (distance O' A' = 0); auto.
apply def_vecteur_bary_rec; auto.
VReplace (mult_PP (distance O' A') (vec B O))
 (mult_PP (- distance O' A') (vec O B)).
rewrite <- H5.
Ringvec.
Qed.

Lemma k_negatif_distance_centres :
 forall (O A O' A' B : PO) (k : R),
 k <= 0 ->
 O <> A ->
 O' <> A' ->
 vec O' B = mult_PP k (vec O B) ->
 cercle_rayon O A B ->
 cercle_rayon O' A' B -> distance O O' = distance O A + distance O' A'.
intros.
assert (distance O A <> 0); auto with geo.
assert (distance O' A' <> 0); auto with geo.
assert (distance O A >= 0); auto with geo.
assert (distance O' A' >= 0); auto with geo.
assert (distance O A + distance O' A' <> 0).
apply tech_Rplus; auto with geo real.
elim H8; intros; auto.
absurd (distance O' A' = 0); auto.
assert (B = barycentre (cons (distance O A) O') (cons (distance O' A') O)).
apply k_negatif_barycentre with k; auto.
assert
 (mult_PP (distance O A + distance O' A') (vec O B) =
  mult_PP (distance O A) (vec O O')).
rewrite <-
 (prop_vecteur_bary (a:=distance O A) (b:=distance O' A') (A:=O') (B:=O)
    (G:=B) O); auto.
Ringvec.
assert
 (vec O O' =
  mult_PP (/ distance O A * (distance O A + distance O' A')) (vec O B)).
VReplace
 (mult_PP (/ distance O A * (distance O A + distance O' A')) (vec O B))
 (mult_PP (/ distance O A)
    (mult_PP (distance O A + distance O' A') (vec O B))).
rewrite H11.
VReplace (mult_PP (/ distance O A) (mult_PP (distance O A) (vec O O')))
 (mult_PP (distance O A * / distance O A) (vec O O')).
RReplace (distance O A * / distance O A) 1.
Ringvec.
rewrite (colinearite_distance H12).
rewrite Rabs_right; auto with real.
hcercle H3.
rewrite <- H13.
RReplace (/ distance O A * (distance O A + distance O' A') * distance O A)
 (/ distance O A * distance O A * (distance O A + distance O' A')).
RReplace (/ distance O A * distance O A) 1.
ring.
apply Rmult_pos; auto with real geo.
lra.
Qed.

Lemma k_positif_vecteur_centres :
 forall (O A O' A' B : PO) (k : R),
 k >= 0 ->
 O <> A ->
 O' <> A' ->
 vec O' B = mult_PP k (vec O B) ->
 cercle_rayon O A B ->
 cercle_rayon O' A' B ->
 vec O O' =
 mult_PP (/ distance O A * (distance O A + - distance O' A')) (vec O B).
intros.
assert
 (mult_PP (distance O A) (vec O' B) = mult_PP (distance O' A') (vec O B)).
apply point_contact_k_positif with k; auto.
assert (distance O A <> 0); auto with geo.
assert (distance O' A' <> 0); auto with geo.
assert (distance O A >= 0); auto with geo.
assert (distance O' A' >= 0); auto with geo.
assert
 (mult_PP (distance O A + - distance O' A') (vec O B) =
  mult_PP (distance O A) (vec O O')).
VReplace (mult_PP (distance O A) (vec O O'))
 (add_PP (mult_PP (distance O A) (vec O B))
    (mult_PP (-1) (mult_PP (distance O A) (vec O' B)))).
rewrite H5.
Ringvec.
VReplace
 (mult_PP (/ distance O A * (distance O A + - distance O' A')) (vec O B))
 (mult_PP (/ distance O A)
    (mult_PP (distance O A + - distance O' A') (vec O B))).
rewrite H10.
VReplace (mult_PP (/ distance O A) (mult_PP (distance O A) (vec O O')))
 (mult_PP (distance O A * / distance O A) (vec O O')).
RReplace (distance O A * / distance O A) 1.
Ringvec.
Qed.

Lemma k_positif_distance_centres :
 forall (O A O' A' B : PO) (k : R),
 k >= 0 ->
 O <> A ->
 O' <> A' ->
 vec O' B = mult_PP k (vec O B) ->
 cercle_rayon O A B ->
 cercle_rayon O' A' B ->
 distance O O' = Rabs (distance O A + - distance O' A').
intros.
assert (distance O A <> 0); auto with geo.
assert
 (vec O O' =
  mult_PP (/ distance O A * (distance O A + - distance O' A')) (vec O B)).
apply k_positif_vecteur_centres with k; auto.
rewrite (colinearite_distance H6).
rewrite Rabs_mult.
rewrite Rabs_right; auto with real geo.
hcercle H3.
rewrite <- H7.
RReplace
 (/ distance O A * Rabs (distance O A + - distance O' A') * distance O A)
 (/ distance O A * distance O A * Rabs (distance O A + - distance O' A')).
RReplace (/ distance O A * distance O A) 1.
ring.
Qed.

Lemma aux_Rpos :
 forall a b : R, a >= 0 -> b >= 0 -> a + b = Rabs (a + - b) -> a = 0 \/ b = 0.
intros.
assert (Rsqr (a + b) = Rsqr (a + - b)).
rewrite H1.
rewrite <- Rsqr_abs; auto.
apply Rmult_integral.
assert (4 * (a * b) = 0).
RReplace (4 * (a * b)) (2 * a * (2 * b)).
RReplace (2 * a) (a + b + (a + - b)).
RReplace (2 * b) (a + b - (a + - b)).
rewrite Rsqr_plus_minus.
rewrite H2; auto with real.
assert (4 <> 0); auto with real.
elim Rmult_integral with (r1 := 4) (r2 := a * b);
 [ intros H5; try clear without_div_Od
 | intros H5; try clear without_div_Od; try exact H5
 | auto ].
absurd (4 = 0); auto.
Qed.

Theorem cercles_tangents_contact_unique :
 forall O A O' A' B C : PO,
 O <> A ->
 O' <> A' ->
 ~ cercle_rayon O A A' ->
 alignes O B O' ->
 cercle_rayon O A B ->
 cercle_rayon O' A' B ->
 alignes O C O' -> cercle_rayon O A C -> cercle_rayon O' A' C -> B = C.
intros O A O' A' B C H H0 H100 H1 H2 H3 H4 H5 H6; try assumption.
assert (O <> B).
apply (isometrie_distinct (A:=O) (B:=A) (A':=O) (B':=B)); auto with geo.
assert (O <> C).
apply (isometrie_distinct (A:=O) (B:=A) (A':=O) (B':=C)); auto with geo.
assert (alignes B O O'); auto with geo.
halignes H9 x.
absurd (B = O); auto.
assert (vec O' B = mult_PP x (vec O B)).
VReplace (vec O' B) (mult_PP (-1) (vec B O')).
rewrite H10; Ringvec.
assert (alignes C O O'); auto with geo.
halignes H12 k.
absurd (C = O); auto.
assert (vec O' C = mult_PP k (vec O C)).
VReplace (vec O' C) (mult_PP (-1) (vec C O')).
rewrite H13; Ringvec.
assert (distance O A <> 0); auto with geo.
assert (distance O' A' <> 0); auto with geo.
assert (distance O A >= 0); auto with geo.
assert (distance O' A' >= 0); auto with geo.
assert (distance O A + distance O' A' <> 0).
apply tech_Rplus; auto with geo real.
elim H18; intros; auto.
absurd (distance O' A' = 0); auto.
elim (Rlt_le_dec x 0); intros.
assert (x <= 0); auto with real.
assert (B = barycentre (cons (distance O A) O') (cons (distance O' A') O)).
apply k_negatif_barycentre with x; auto.
elim (Rlt_le_dec k 0); intros.
assert (k <= 0); auto with real.
assert (C = barycentre (cons (distance O A) O') (cons (distance O' A') O)).
apply k_negatif_barycentre with k; auto.
rewrite H21; auto.
assert (distance O O' = distance O A + distance O' A').
apply k_negatif_distance_centres with (4 := H11); auto.
assert (distance O O' = Rabs (distance O A + - distance O' A')).
apply k_positif_distance_centres with (4 := H14); auto.
auto with real.
assert (distance O A = 0 \/ distance O' A' = 0).
apply aux_Rpos; auto.
rewrite <- H23; auto.
elim H24; intros.
absurd (distance O A = 0); auto.
absurd (distance O' A' = 0); auto.
assert (distance O O' = Rabs (distance O A + - distance O' A')).
apply k_positif_distance_centres with (4 := H11); auto.
auto with real.
elim (classic (distance O A = distance O' A')); intros.
assert (O = O').
assert (distance O O' = 0); auto with geo.
rewrite H20; rewrite H21.
RReplace (distance O' A' + - distance O' A') 0.
rewrite Rabs_right; auto with real.
absurd (cercle_rayon O A A'); auto.
icercle.
rewrite H21; rewrite H22; auto.
assert
 (mult_PP (distance O A + - distance O' A') (vec O B) =
  mult_PP (distance O A) (vec O O')).
VReplace (mult_PP (distance O A) (vec O O'))
 (add_PP (mult_PP (distance O A) (vec O B))
    (mult_PP (-1) (mult_PP (distance O A) (vec O' B)))).
assert
 (mult_PP (distance O A) (vec O' B) = mult_PP (distance O' A') (vec O B)).
apply point_contact_k_positif with x; auto.
auto with real.
rewrite H22; Ringvec.
assert (distance O A + - distance O' A' <> 0); auto with real.
elim (Rlt_le_dec k 0); intros.
assert (k <= 0); auto with real.
assert (distance O O' = distance O A + distance O' A').
apply k_negatif_distance_centres with (4 := H14); auto.
assert (distance O A = 0 \/ distance O' A' = 0).
apply aux_Rpos; auto.
rewrite <- H25; auto.
elim H26; intros.
absurd (distance O A = 0); auto.
absurd (distance O' A' = 0); auto.
assert
 (mult_PP (distance O A + - distance O' A') (vec O C) =
  mult_PP (distance O A) (vec O O')).
VReplace (mult_PP (distance O A) (vec O O'))
 (add_PP (mult_PP (distance O A) (vec O C))
    (mult_PP (-1) (mult_PP (distance O A) (vec O' C)))).
assert
 (mult_PP (distance O A) (vec O' C) = mult_PP (distance O' A') (vec O C)).
apply point_contact_k_positif with k; auto.
auto with real.
rewrite H24; Ringvec.
apply egalite_vecteur_point with O.
assert
 (vec O B =
  mult_PP (/ (distance O A + - distance O' A'))
    (mult_PP (distance O A) (vec O O'))).
rewrite <- H22.
VReplace
 (mult_PP (/ (distance O A + - distance O' A'))
    (mult_PP (distance O A + - distance O' A') (vec O B)))
 (mult_PP
    ((distance O A + - distance O' A') * / (distance O A + - distance O' A'))
    (vec O B)).
replace
 ((distance O A + - distance O' A') * / (distance O A + - distance O' A'))
 with 1; auto with real.
Ringvec.
rewrite H25.
rewrite <- H24.
VReplace
 (mult_PP (/ (distance O A + - distance O' A'))
    (mult_PP (distance O A + - distance O' A') (vec O C)))
 (mult_PP
    ((distance O A + - distance O' A') * / (distance O A + - distance O' A'))
    (vec O C)).
replace
 ((distance O A + - distance O' A') * / (distance O A + - distance O' A'))
 with 1; auto with real.
Ringvec.
Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Limits.Limit.
From Categories Require Import Archetypal.Discr.Discr.
From Categories Require Import Cat.Terminal.
From Categories Require Import
        Basic_Cons.Terminal
        Basic_Cons.Product
        Basic_Cons.Equalizer
        Basic_Cons.PullBack
.

(** In this module we show that terminal objects, products, equalizers and
    pullbacks are limits. The corresponding duals are dually colimits. *)

Section Limits.
  Context {C : Category}.

  Section Terminal.

    Definition Terminal_Producing_Func_fun (x : Empty) : C
      :=
        match x with
        end
    .

    Context (L : Limit (Discr_Func Terminal_Producing_Func_fun)).

    Program Definition Terminal_as_Limit_Cone
            (c : C)
      :
        Cone (Discr_Func Terminal_Producing_Func_fun)
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => c;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  end
            |}
        |}
    .

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
    Local Hint Extern 1 => rewrite From_Term_Cat.
    Local Hint Extern 1 => apply NatTrans_eq_simplify.
    Local Hint Extern 1 => progress cbn.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition Terminal_as_Limit_Cone_morph
            {c : C}
            (f : (c –≻ L)%morphism)
      :
        Cone_Morph _ (Terminal_as_Limit_Cone c) (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ –≻ L _o u)%object%morphism with
                    tt => f
                  end
            |}
        |}
    .

    Program Definition Terminal_as_Limit : (𝟙_ C)%object :=
      {|
        terminal := L;
        t_morph :=
          fun c =>
            Trans (LRKE_morph_ex L (Terminal_as_Limit_Cone c)) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      intros c f g.
      apply (
          f_equal
            (fun w : (Terminal_as_Limit_Cone c –≻ L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (Terminal_as_Limit_Cone_morph f)
                (Terminal_as_Limit_Cone_morph g)
            )
        ).
    Qed.

  End Terminal.

  Section Product.
    Context (a b : C).

    Definition Product_Producing_Func_fun (x : bool) : C
      :=
        match x with
        | true => a
        | false => b
        end
    .

    Context (L : Limit (Discr_Func Product_Producing_Func_fun)).

    Program Definition Product_as_Limit_Cone
            {p : C}
            (h : (p –≻ a)%morphism)
            (h' : (p –≻ b)%morphism)
      :
        Cone (Discr_Func Product_Producing_Func_fun)
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => p;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  | true => h
                  | false => h'
                  end
            |}
        |}
    .

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : bool |- _] => destruct x end.
    Local Hint Extern 1 => rewrite From_Term_Cat.
    Local Hint Extern 1 => apply NatTrans_eq_simplify.
    Local Hint Extern 1 => progress cbn.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition Product_as_Limit_Cone_morph
            {p : C}
            (h : (p –≻ a)%morphism)
            (h' : (p –≻ b)%morphism)
            (f : (p –≻ L)%morphism)
            (H1 : (Trans L true ∘ f)%morphism = h)
            (H2 : (Trans L false ∘ f)%morphism = h')
      :
        Cone_Morph _ (Product_as_Limit_Cone h h') (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ –≻ L _o u)%object%morphism with
                    tt => f
                  end
            |}
        |}
    .

    Program Definition Product_as_Limit : (a × b)%object :=
      {|
        product := L;
        Pi_1 := Trans (cone_edge L) true;
        Pi_2 := Trans (cone_edge L) false;
        Prod_morph_ex :=
          fun p h h' =>
            Trans (LRKE_morph_ex L (Product_as_Limit_Cone h h')) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      intros p h h'.
      cbn.
      set (H :=
             f_equal
               (fun w
                    :
                      (Product_as_Limit_Cone h h'
                 ∘ Functor_To_1_Cat (Discr_Cat Datatypes.bool)
                 –≻ Discr_Func Product_Producing_Func_fun)%nattrans
                => Trans w true)
               (cone_morph_com (LRKE_morph_ex L (Product_as_Limit_Cone h h')))
          ).
      cbn in H.
      rewrite From_Term_Cat in H.
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros p h h'.
      set (H :=
             f_equal
               (fun w
                    :
                      ((Product_as_Limit_Cone h h')
                         ∘ Functor_To_1_Cat (Discr_Cat Datatypes.bool)
                         –≻ Discr_Func Product_Producing_Func_fun)%nattrans
                => Trans w false)
               (cone_morph_com (LRKE_morph_ex L (Product_as_Limit_Cone h h')))
          ).
      cbn in H.
      rewrite From_Term_Cat in H.
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros p h h' f g H1 H2 H3 H4.
      apply (
          f_equal
            (fun w : (Product_as_Limit_Cone h h' –≻ L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (Product_as_Limit_Cone_morph _ _ _ H1 H2)
                (Product_as_Limit_Cone_morph _ _ _ H3 H4)
            )
        ).
    Qed.

  End Product.

  Section Equalizer.
    Context {a b : C} (f g : (a –≻ b)%morphism).

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : Empty |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : bool |- _] => destruct x end.
    Local Hint Extern 1 => rewrite From_Term_Cat.
    Local Hint Extern 1 => apply NatTrans_eq_simplify.
    Local Hint Extern 1 => progress cbn.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition Equalizer_Producing_Cat : Category
      :=
        {|
          Obj := bool;
          Hom :=
            fun x y =>
              match (x, y) with
              | (true, true) => unit
              | (true, false) => bool
              | (false, true) => Empty
              | (false, false) => unit
              end;
          compose :=
            fun x y z h h'=> _;
          id := fun x => _
        |}
    .

    Next Obligation.
    Proof.
      destruct x; destruct y; destruct z; auto.
    Defined.

    Next Obligation.
    Proof.
      destruct x; constructor.
    Defined.

    Program Definition Equalizer_Producing_Func :
      (Equalizer_Producing_Cat –≻ C)%functor
      :=
        {|
          FO :=
            fun x =>
              match x with
              | true => a
              | false => b
              end;
          FA := fun x y h => _
        |}
    .

    Next Obligation.
    Proof.
      destruct x; destruct y.
      exact id.
      destruct h.
      {
        exact f.
      }
      {
        exact g.
      }
      destruct h.
      exact id.
    Defined.

    Context (L : Limit Equalizer_Producing_Func).

    Program Definition Equalizer_as_Limit_Cone
            {p : C}
            {h : (p –≻ a)%morphism}
            (H : (f ∘ h)%morphism = (g ∘ h)%morphism)
      :
        Cone Equalizer_Producing_Func
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => p;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  | true => h
                  | false => (f ∘ h)%morphism
                  end
            |}
        |}
    .

    Local Obligation Tactic := idtac.

    Program Definition Equalizer_as_Limit_Cone_morph
            {p : C}
            {h : (p –≻ a)%morphism}
            (H1 : (f ∘ h)%morphism = (g ∘ h)%morphism)
            (k : (p –≻ L)%morphism)
            (H2 : (Trans L true ∘ k)%morphism = h)
      :
        Cone_Morph _ (Equalizer_as_Limit_Cone H1) (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ –≻ L _o u)%object%morphism with
                    tt => k
                  end
            |}
        |}
    .

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      intros p h H1 k H2.
      apply NatTrans_eq_simplify.
      extensionality x.
      cbn in *.
      destruct x; auto.
      rewrite assoc_sym.
      cbn_rewrite (@Trans_com _ _ _ _ L true false false).
      rewrite assoc.
      rewrite H1; rewrite <- H2.
      trivial.
    Qed.

    Program Definition Equalizer_as_Limit : Equalizer f g :=
      {|
        equalizer := L;
        equalizer_morph := Trans L true;
        equalizer_morph_ex :=
          fun e eqm H =>
            Trans (LRKE_morph_ex L (Equalizer_as_Limit_Cone H)) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      set (H := @Trans_com _ _ _ _ L true false false).
      cbn in H.
      cbn_rewrite (@Trans_com _ _ _ _ L true false true) in H.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      intros e eqm eqmc; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((Equalizer_as_Limit_Cone eqmc)
                      ∘ Functor_To_1_Cat Equalizer_Producing_Cat
                      –≻ Equalizer_Producing_Func)%nattrans
             => Trans w true)
            (cone_morph_com (LRKE_morph_ex L (Equalizer_as_Limit_Cone eqmc)))
        ).
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros e eqm H1 h h' H2 H3.
      apply (
          f_equal
            (fun w : (Equalizer_as_Limit_Cone H1 –≻ L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (Equalizer_as_Limit_Cone_morph _ _ H2)
                (Equalizer_as_Limit_Cone_morph _ _ H3)
            )
        ).
    Qed.

  End Equalizer.

  Section PullBack.
    Context
      {a b c : C}
      (f : (a –≻ c)%morphism)
      (g : (b –≻ c)%morphism)
    .

    Inductive PBType :=
    | PB_A
    | PB_B
    | PB_C
    .

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : PBType |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : Empty |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : bool |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [|- unit] => constructor end.
    Local Hint Extern 1 => rewrite From_Term_Cat.
    Local Hint Extern 1 => apply NatTrans_eq_simplify.
    Local Hint Extern 1 => progress cbn.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition PullBack_Producing_Cat : Category
      :=
        {|
          Obj := PBType;
          Hom :=
            fun x y =>
              match (x, y) with
              | (PB_A, PB_A) => unit
              | (PB_A, PB_B) => Empty
              | (PB_A, PB_C) => unit
              | (PB_B, PB_A) => Empty
              | (PB_B, PB_B) => unit
              | (PB_B, PB_C) => unit
              | (PB_C, PB_A) => Empty
              | (PB_C, PB_B) => Empty
              | (PB_C, PB_C) => unit
              end;
          compose :=
            fun x y z h h'=> _;
          id := fun x => _
        |}
    .

    Program Definition PullBack_Producing_Func :
      (PullBack_Producing_Cat –≻ C)%functor
      :=
        {|
          FO :=
            fun x =>
              match x with
              | PB_A => a
              | PB_B => b
              | PB_C => c
              end;
          FA := fun x y h => _
        |}
    .

    Next Obligation.
    Proof.
      destruct x; destruct y; auto; try exact id.
    Defined.

    Context (L : Limit PullBack_Producing_Func).

    Program Definition PullBack_as_Limit_Cone
            {p : C}
            {h : (p –≻ a)%morphism}
            {h' : (p –≻ b)%morphism}
            (H : (f ∘ h)%morphism = (g ∘ h')%morphism)
      :
        Cone PullBack_Producing_Func
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => p;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  | PB_A => h
                  | PB_B => h'
                  | PB_C => (f ∘ h)%morphism
                  end
            |}
        |}
    .

    Local Obligation Tactic := idtac.

    Program Definition PullBack_as_Limit_Cone_morph
            {p : C}
            {h : (p –≻ a)%morphism}
            {h' : (p –≻ b)%morphism}
            (H1 : (f ∘ h)%morphism = (g ∘ h')%morphism)
            (k : (p –≻ L)%morphism)
            (H2 : (Trans L PB_A ∘ k)%morphism = h)
            (H3 : (Trans L PB_B ∘ k)%morphism = h')
      :
        Cone_Morph _ (PullBack_as_Limit_Cone H1) (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ –≻ L _o u)%object%morphism with
                    tt => k
                  end
            |}
        |}
    .

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      intros p h h' H1 k H2 H3.
      apply NatTrans_eq_simplify.
      extensionality x.
      cbn in *.
      destruct x; auto.
      rewrite assoc_sym.
      cbn_rewrite (@Trans_com _ _ _ _ L PB_B PB_C tt).
      rewrite assoc.
      rewrite H1; rewrite <- H3.
      trivial.
    Qed.

    Program Definition PullBack_as_Limit : PullBack f g :=
      {|
        pullback := L;
        pullback_morph_1 := Trans L PB_A;
        pullback_morph_2 := Trans L PB_B;
        pullback_morph_ex :=
          fun e pm1 pm2 pmc =>
            Trans (LRKE_morph_ex L (PullBack_as_Limit_Cone pmc)) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      set (H := @Trans_com _ _ _ _ L PB_B PB_C tt).
      cbn in H.
      cbn_rewrite (@Trans_com _ _ _ _ L PB_A PB_C tt) in H.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      intros e pm1 pm2 pmc; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((PullBack_as_Limit_Cone pmc)
                      ∘ Functor_To_1_Cat PullBack_Producing_Cat
                      –≻ PullBack_Producing_Func)%nattrans
             => Trans w PB_A)
            (cone_morph_com (LRKE_morph_ex L (PullBack_as_Limit_Cone pmc)))
        ).
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros e pm1 pm2 pmc; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((PullBack_as_Limit_Cone pmc)
                      ∘ Functor_To_1_Cat PullBack_Producing_Cat
                      –≻ PullBack_Producing_Func)%nattrans
             => Trans w PB_B)
            (cone_morph_com (LRKE_morph_ex L (PullBack_as_Limit_Cone pmc)))
        ).
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros e pm1 pm2 H1 h h' H2 H3 H4 H5.
      apply (
          f_equal
            (fun w : (PullBack_as_Limit_Cone H1 –≻ L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (PullBack_as_Limit_Cone_morph _ _ H2 H3)
                (PullBack_as_Limit_Cone_morph _ _ H4 H5)
            )
        ).
    Qed.

  End PullBack.

End Limits.


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 Q M X : Universe, ((wd_ A B /\ (wd_ M X /\ (wd_ X Q /\ (wd_ M Q /\ (col_ A B M /\ (col_ A B X /\ col_ M X Q)))))) -> col_ A B Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


From mathcomp Require Import all_ssreflect.

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

Unset Printing Implicit. (* Unset : implicitな引数を表示しない。 D:しない。 A:する。*)
Unset Printing Coercions. (* Unset : コアーションを表示しない     D:しない。 A:する。*)
Set   Printing Notations. (*   Set : Notation を使って表示する。  D:する。  A:しない。*)
Unset Printing Universe.  (* Unset : 高階のTypeを表示しない。     D:しない。 A:- *)
Print Graph.              (* Print Coercions. *)
Print Canonical Projections.

Section Def.
  Variables (aT : finType) (rT : Type).

  Inductive finfun_type : predArgType := Finfun of #|aT|.-tuple rT.
  Definition finfun_of of phant (aT -> rT) := finfun_type.
  Identity Coercion type_of_finfun : finfun_of >-> finfun_type.
  Definition fgraph f := let: Finfun t := f in t.
  Canonical finfun_subType := Eval hnf in [newType for fgraph].
End Def.

Notation "{ 'ffun' fT }" := (finfun_of (Phant fT))
  (at level 0, format "{ 'ffun'  '[hv' fT ']' }") : type_scope.

(*****************************************************************************)

Local Notation fun_of_fin_def :=
  (fun aT rT f x => tnth (@fgraph aT rT f) (enum_rank x)).
Local Notation finfun_def := (fun aT rT f => @Finfun aT rT (codom_tuple f)).
Parameter fun_of_fin : forall aT rT, finfun_type aT rT -> aT -> rT.
Parameter finfun : forall (aT : finType) rT, (aT -> rT) -> {ffun aT -> rT}.

Notation "[ 'ffun' x : aT => F ]" := (finfun (fun x : aT => F))
  (at level 0, x ident, only parsing) : fun_scope.

Notation "[ 'ffun' : aT => F ]" := (finfun (fun _ : aT => F))
  (at level 0, only parsing) : fun_scope.

Notation "[ 'ffun' x => F ]" := [ffun x : _ => F]
  (at level 0, x ident, format "[ 'ffun'  x  =>  F ]") : fun_scope.

Notation "[ 'ffun' => F ]" := [ffun : _ => F]
  (at level 0, format "[ 'ffun' =>  F ]") : fun_scope.

Check [ffun i :'I_4 => i + 2] :{ffun 'I_4 -> nat}.

(*****************************************************************************)

Section PlainTheory.
  Variables (aT : finType) (rT : Type).
  Notation fT := {ffun aT -> rT}.
  Implicit Types (f : fT) (R : pred rT).

  Canonical finfun_of_subType := Eval hnf in [subType of fT].
End PlainTheory.

(*****************************************************************************)

Section EqTheory.
  Variables (aT : finType) (rT : eqType).
  Notation fT := {ffun aT -> rT}.
  Implicit Types (y : rT) (D : pred aT) (R : pred rT) (f : fT).

  Definition finfun_eqMixin :=
    Eval hnf in [eqMixin of finfun_type aT rT by <:].
  Canonical finfun_eqType := Eval hnf in EqType _ finfun_eqMixin.
(*
  Canonical finfun_of_eqType := Eval hnf in [eqType of fT].
*)
End EqTheory.

Definition finfun_choiceMixin aT (rT : choiceType) :=
  [choiceMixin of finfun_type aT rT by <:].
Canonical finfun_choiceType aT rT :=
  Eval hnf in ChoiceType _ (finfun_choiceMixin aT rT).
(*
Canonical finfun_of_choiceType (aT : finType) (rT : choiceType) :=
  Eval hnf in [choiceType of {ffun aT -> rT}].
*)

Definition finfun_countMixin aT (rT : countType) :=
  [countMixin of finfun_type aT rT by <:].
Canonical finfun_countType aT (rT : countType) :=
  Eval hnf in CountType _ (finfun_countMixin aT rT).
(*
Canonical finfun_of_countType (aT : finType) (rT : countType) :=
  Eval hnf in [countType of {ffun aT -> rT}].
*)
Canonical finfun_subCountType aT (rT : countType) :=
  Eval hnf in [subCountType of finfun_type aT rT].
(*
Canonical finfun_of_subCountType (aT : finType) (rT : countType) :=
  Eval hnf in [subCountType of {ffun aT -> rT}].
*)
(*****************************************************************************)

Section FinTheory.
  Variables aT rT : finType.
  Notation fT := {ffun aT -> rT}.
  Notation ffT := (finfun_type aT rT).
  Implicit Types (D : pred aT) (R : pred rT) (F : aT -> pred rT).

  Definition finfun_finMixin := [finMixin of ffT by <:]. (* finfun_subCountType が要る。 *)
  Canonical finfun_finType := Eval hnf in FinType ffT finfun_finMixin.
  Canonical finfun_subFinType := Eval hnf in [subFinType of ffT].
  Canonical finfun_of_finType := Eval hnf in [finType of fT for finfun_finType].
  Canonical finfun_of_subFinType := Eval hnf in [subFinType of fT].
End FinTheory.

(*****************************************************************************)

(* 例 *)
Check #|{ffun pred bool}| : nat.

Locate "#| _ |".                       (* "#| A |" := card (mem A)  *)
Check @card : forall (T : Finite.type) (_ : mem_pred T), nat.
Check @mem  : forall (T : Type) (pT : predType T) (_ : pT), mem_pred T.

Check {ffun pred bool} : Type.
(* finfun_type の型を predArgType にすると、以下が通るようになる。 *)
Check @finfun_of bool_finType bool  (Phant (pred bool)) : predArgType.
Check @mem _ _ (@finfun_of _ _ (Phant (pred bool))).
Check @mem _ _ {ffun pred bool}.
Check mem {ffun pred bool} : mem_pred (@finfun_of bool_finType bool (Phant (pred bool))).

Check (finfun_of_finType bool_finType bool_finType) : finType.
Check @card (finfun_of_finType bool_finType bool_finType)
      (@mem (@finfun_of bool_finType bool (Phant (pred bool)))
            (predPredType (@finfun_of bool_finType bool (Phant (pred bool))))
            (@finfun_of bool_finType bool (Phant (pred bool))))
  : nat.
Check card (mem {ffun pred bool}) : nat.

(* END *)


(************************************************************************)
(*  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.  *)
(****************************************************************************)

Require Export Finite_sets.
Require Export Constructive_sets.
Require Export Classical_Type.
Require Export Classical_sets.
Require Export Powerset.
Require Export Powerset_facts.
Require Export Powerset_Classical_facts.
Require Export Gt.
Require Export Lt.
Require Export Le.
Require Export Finite_sets_facts.

Section Image.
  Variables U V : Type.

  Inductive Im (X:Ensemble U) (f:U -> V) : Ensemble V :=
    Im_intro : forall x:U, In _ X x -> forall y:V, y = f x -> In _ (Im X f) y.

  Lemma Im_def :
    forall (X:Ensemble U) (f:U -> V) (x:U), In _ X x -> In _ (Im X f) (f x).
  Proof.
    intros X f x H'; try assumption.
    apply Im_intro with (x := x); auto with sets.
  Qed.

  Lemma Im_add :
    forall (X:Ensemble U) (x:U) (f:U -> V),
      Im (Add _ X x) f = Add _ (Im X f) (f x).
  Proof.
    intros X x f.
    apply Extensionality_Ensembles.
    split; red in |- *; intros x0 H'.
    elim H'; intros.
    rewrite H0.
    elim Add_inv with U X x x1; auto using Im_def with sets.
    destruct 1; auto using Im_def with sets.
    elim Add_inv with V (Im X f) (f x) x0.
    destruct 1 as [x0 H y H0].
    rewrite H0; auto using Im_def with sets.
    destruct 1; auto using Im_def with sets.
    trivial.
  Qed.

  Lemma image_empty : forall f:U -> V, Im (Empty_set U) f = Empty_set V.
  Proof.
    intro f; try assumption.
    apply Extensionality_Ensembles.
    split; auto with sets.
    red in |- *.
    intros x H'; elim H'.
    intros x0 H'0; elim H'0; auto with sets.
  Qed.

  Lemma finite_image :
    forall (X:Ensemble U) (f:U -> V), Finite _ X -> Finite _ (Im X f).
  Proof.
    intros X f H'; elim H'.
    rewrite (image_empty f); auto with sets.
    intros A H'0 H'1 x H'2; clear H' X.
    rewrite (Im_add A x f); auto with sets.
    apply Add_preserves_Finite; auto with sets.
  Qed.

  Lemma Im_inv :
    forall (X:Ensemble U) (f:U -> V) (y:V),
      In _ (Im X f) y ->  exists x : U, In _ X x /\ f x = y.
  Proof.
    intros X f y H'; elim H'.
    intros x H'0 y0 H'1; rewrite H'1.
    exists x; auto with sets.
  Qed.

  Definition injective (f:U -> V) := forall x y:U, f x = f y -> x = y.

  Lemma not_injective_elim :
    forall f:U -> V,
      ~ injective f ->  exists x : _, (exists y : _, f x = f y /\ x <> y).
  Proof.
    unfold injective in |- *; intros f H.
    cut (exists x : _, ~ (forall y:U, f x = f y -> x = y)).
    2: apply not_all_ex_not with (P := fun x:U => forall y:U, f x = f y -> x = y);
      trivial with sets.
    destruct 1 as [x C]; exists x.
    cut (exists y : _, ~ (f x = f y -> x = y)).
    2: apply not_all_ex_not with (P := fun y:U => f x = f y -> x = y);
      trivial with sets.
    destruct 1 as [y D]; exists y.
    apply imply_to_and; trivial with sets.
  Qed.

  Lemma cardinal_Im_intro :
    forall (A:Ensemble U) (f:U -> V) (n:nat),
      cardinal _ A n ->  exists p : nat, cardinal _ (Im A f) p.
  Proof.
    intros.
    apply finite_cardinal; apply finite_image.
    apply cardinal_finite with n; trivial with sets.
  Qed.

  Lemma In_Image_elim :
    forall (A:Ensemble U) (f:U -> V),
      injective f -> forall x:U, In _ (Im A f) (f x) -> In _ A x.
  Proof.
    intros.
    elim Im_inv with A f (f x); trivial with sets.
    intros z C; elim C; intros InAz E.
    elim (H z x E); trivial with sets.
  Qed.

  Lemma injective_preserves_cardinal :
    forall (A:Ensemble U) (f:U -> V) (n:nat),
      injective f ->
      cardinal _ A n -> forall n':nat, cardinal _ (Im A f) n' -> n' = n.
  Proof.
    induction 2 as [| A n H'0 H'1 x H'2]; auto with sets.
    rewrite (image_empty f).
    intros n' CE.
    apply cardinal_unicity with V (Empty_set V); auto with sets.
    intro n'.
    rewrite (Im_add A x f).
    intro H'3.
    elim cardinal_Im_intro with A f n; trivial with sets.
    intros i CI.
    lapply (H'1 i); trivial with sets.
    cut (~ In _ (Im A f) (f x)).
    intros H0 H1.
    apply cardinal_unicity with V (Add _ (Im A f) (f x)); trivial with sets.
    apply card_add; auto with sets.
    rewrite <- H1; trivial with sets.
    red in |- *; intro; apply H'2.
    apply In_Image_elim with f; trivial with sets.
  Qed.

  Lemma cardinal_decreases :
    forall (A:Ensemble U) (f:U -> V) (n:nat),
      cardinal U A n -> forall n':nat, cardinal V (Im A f) n' -> n' <= n.
  Proof.
    induction 1 as [| A n H'0 H'1 x H'2]; auto with sets.
    rewrite (image_empty f); intros.
    cut (n' = 0).
    intro E; rewrite E; trivial with sets.
    apply cardinal_unicity with V (Empty_set V); auto with sets.
    intro n'.
    rewrite (Im_add A x f).
    elim cardinal_Im_intro with A f n; trivial with sets.
    intros p C H'3.
    apply le_trans with (S p).
    apply card_Add_gen with V (Im A f) (f x); trivial with sets.
    apply le_n_S; auto with sets.
  Qed.

  Theorem Pigeonhole :
    forall (A:Ensemble U) (f:U -> V) (n:nat),
      cardinal U A n ->
      forall n':nat, cardinal V (Im A f) n' -> n' < n -> ~ injective f.
  Proof.
    unfold not in |- *; intros A f n CAn n' CIfn' ltn'n I.
    cut (n' = n).
    intro E; generalize ltn'n; rewrite E; exact (lt_irrefl n).
    apply injective_preserves_cardinal with (A := A) (f := f) (n := n);
      trivial with sets.
  Qed.

  Lemma Pigeonhole_principle :
    forall (A:Ensemble U) (f:U -> V) (n:nat),
      cardinal _ A n ->
      forall n':nat,
	cardinal _ (Im A f) n' ->
	n' < n ->  exists x : _, (exists y : _, f x = f y /\ x <> y).
  Proof.
    intros; apply not_injective_elim.
    apply Pigeonhole with A n n'; trivial with sets.
  Qed.

End Image.

Hint Resolve Im_def image_empty finite_image: sets v62.


(* This file is part of the Linear Logic formalization in Coq:
https://github.com/brunofx86/LL *)

(** ** Structural Rules
In this file we prove several invertibility lemmas for the focused system.
*)

(*Add LoadPath "../". *)
Require Export SequentCalculi.
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Export Coq.Sorting.PermutSetoid.
Require Export Coq.Sorting.PermutEq.
Require Import Coq.Program.Equality.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Eqset.
Require Import AuxResults.
Set Implicit Arguments.

Module SRule (DT : Eqset_dec_pol).

  Module Export Sys :=  SqSystems DT.
  Ltac EquivPosCase H IH m L Hinv :=
    match goal with
      [_ : AsynchronousF _ = false |- _] =>

      apply IH  with(m:=L_weight L) in Hinv;auto  using le_plus_r;
      simpl;eapply tri_store;auto
    end.

  Hint Rewrite Neg2pos Ng_involutive.
  Hint Constructors Asynchronous.
  Hint Constructors IsNegativeAtom.
  Hint Resolve l_nil l_sin l_cos.
  Hint Unfold Lexp_weight Dual_LExp.
  (*Hint Constructors Release. *)
  Hint Constructors NotAsynchronous.
  Hint Resolve wt_refl wt_symm wt_trans.
  (* Hint Constructors PosOrPosAtom. *)
  (*Hint Constructors NotPosOrPosAtom.
  Hint Resolve exp_weight_inv. *)
  Hint Unfold Exp_weight.

  Theorem EquivAuxBot : forall B  L L' M ,  |-F- B ; M ; UP (L ++ L') -> |-F- B ; M ;  UP (L ++ [Bot] ++ L').
  Proof.
    intros.
    remember (L_weight L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .

    induction w as [| w' IH] using strongind ; intros M B L' L H Hw  ;  destruct L as [|l].
    + simpl. simpl in H.
      eapply tri_bot;auto.
    + simpl in Hw. (* Heqw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + simpl in Hw. inversion Hw.
    + caseLexp l ;inversion Hw as [Hw'];subst;auto;simpl;simpl in H;inversion Hw';inversion H;subst;LexpContr;auto;
        try(
            match goal with
            | [H7 : |-F- _ ; _ ++ [?F]  ; UP(?L ++ ?L') |- _] => (* cases store *)
              apply IH  with(m:=L_weight L) in H7;auto  using le_plus_r;
              simpl; apply tri_store;auto
            | [H4 : |-F- _; _; UP (?L ++ ?L') |- |-F- _ ; _ ; UP(?l :: ?L ++ ⊥ :: ?L')] =>
              let solve_tac1 := (apply IH  with(m:=L_weight L) in H4; [ simpl;constructor;auto | omega | auto])
              in
              match l with
              | ⊥ => solve_tac1 (* bot *)
              | ? _ => solve_tac1 (* quest *)
              end
            end).
      ++ (* par *)
        LexpSubst.
        apply IH  with (L:= F :: G :: L) (m:= (Exp_weight  F) + (Exp_weight G) + L_weight L) in H6;auto;simpl;auto. omega.
      ++(* with *)
        LexpSubst.
        apply IH with (L:= F :: L) (m:= (Exp_weight  F) + L_weight  L) in H7;autounfold;auto.
        apply IH with (L:= G :: L) (m:= (Exp_weight  G) + L_weight  L) in H8;autounfold;auto.
        omega. omega.
      ++ (* forall *)
        LexpSubst.
        simpl; eapply tri_fx;auto; intro x. eapply IH with (L:=Subst FX x  :: L);eauto.
        simpl.
        rewrite <- subs_weight_weak with (x:=x).  omega.
  Qed.

  Theorem EquivAuxWith : forall B  L L' M F G ,
      |-F- B ; M ; UP (L ++ [F] ++ L') ->
                   |-F- B ; M ; UP (L ++ [G] ++ L') ->
                                |-F- B ; M ;  UP (L ++ [F & G] ++ L').
  Proof.
    intros.
    remember (L_weight  L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .

    induction w as [| w' IH] using strongind  ; intros  M B L' L H H' Hw  ;  destruct L as [|l].
    + simpl. simpl in H.
      eapply tri_with;auto.
    + simpl in Hw. (* Heqw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + simpl in Hw. inversion Hw.
    + caseLexp l ;inversion Hw as [Hw'];subst;auto;simpl;simpl in H;inversion Hw';inversion H;subst;LexpContr;auto.
      ++ apply tri_store;auto; apply IH with (m:= L_weight  L) ;auto.
      ++ apply tri_store;auto; apply IH with (m:= L_weight  L) ;auto.
      ++ simpl in H';inversion H';subst;LexpContr;  apply tri_store;auto. apply IH with (m:= L_weight  L) ;auto.
      ++ simpl in H';inversion H';subst;LexpContr. apply tri_bot;auto; apply IH with (m:= L_weight  L) ;auto.
         assert(Asynchronous Bot) by auto. contradiction.
      ++ assert(Asynchronous Bot) by auto. contradiction.
      ++ simpl in H';inversion H';subst;LexpContr;  apply tri_store;auto. apply IH with (m:= L_weight  L) ;auto.
      ++ simpl in H';inversion H';subst;LexpContr;  apply tri_store;auto. apply IH with (m:= L_weight  L) ;auto. omega.
      ++LexpSubst. simpl in H';inversion H';subst;LexpContr.
        LexpSubst.
        apply tri_par. apply IH with (L:= F0 :: G0 :: L) (m:= Exp_weight F0 + Exp_weight G0 + L_weight  L) ;auto.
        simpl. omega.
        assert(Asynchronous (F0 $ G0)) by auto. contradiction.
      ++  assert(Asynchronous (F0 $ G0)) by auto. contradiction.
      ++ simpl in H';inversion H';subst;LexpContr;  apply tri_store;auto. apply IH with (m:= L_weight  L) ;auto. omega.
      ++ simpl in H';inversion H';subst;LexpContr.
         LexpSubst.  LexpSubst.
         apply IH with (L:= F0 :: L) (m:= Exp_weight F0 +  L_weight  L) in H9 ;auto.
         apply IH with (L:= G0 :: L) (m:= Exp_weight G0 +  L_weight  L) in H10 ;auto.
         autounfold. omega.
         autounfold. omega.
         assert(Asynchronous (F0 & G0)) by auto. contradiction.
      ++ assert(Asynchronous (F0 & G0)) by auto. contradiction.
      ++       simpl in H';inversion H';subst;LexpContr;  apply tri_store;auto.
               apply IH with (m:= L_weight  L) ;auto. omega.
      ++ LexpSubst.
         simpl in H';inversion H';subst;LexpContr.
         LexpSubst.
         apply tri_quest. apply IH with (m:= L_weight  L) ;auto. omega.
         assert(Asynchronous (? F0 )) by auto. contradiction.
      ++ assert(Asynchronous (? F0 )) by auto. contradiction.
      ++ simpl in H';inversion H';subst;LexpContr;  apply tri_store;auto. apply IH with (m:= L_weight  L) ;auto. omega.
      ++ assert(Asynchronous (F{ FX})) by auto. contradiction.
      ++ LexpSubst.
         simpl in H';inversion H';subst;LexpContr.
         assert(Asynchronous (F{ FX})) by auto. contradiction.
         LexpSubst.
         assert(forall x, |-F- B; M; UP (((Subst FX x) ::L) ++ [F & G] ++ L')) as Hp.
         intro.
         generalize(H4 x);intros;
           generalize(H5 x);intros.
         eapply IH with (m:=  Exp_weight  (Subst FX x) + L_weight  L ) ;eauto.
         rewrite <- subs_weight_weak with (x:=x).  omega.
         apply tri_fx;auto.
  Qed.

  Theorem EquivAuxPar : forall B  L L' M F G  n,  n |-F- B ; M ; UP (L ++ [F ; G] ++ L') -> |-F- B ; M ;  UP (L ++ [F $ G] ++ L').
  Proof.
    intros.
    remember (L_weight  L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent n .
    generalize dependent w .

    induction w as [| w' IH] using strongind ; intros n M B L' L H Hw  ;  destruct L as [|l].
    + simpl. simpl in H.
      eapply tri_par;auto.
      eapply AdequacyTri1;eauto.

    + simpl in Hw. (* Heqw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + simpl in Hw. inversion Hw.
    +caseLexp l ;inversion Hw as [Hw'];subst;auto;simpl in *;inversion Hw';inversion H;subst;LexpContr;auto;
       try(apply IH  with (m:=  L_weight L) in H8;try(omega);auto);
       try(apply IH  with (m:=  L_weight L) in H7;try(omega);auto);
       try(apply IH  with (m:=  L_weight L) in H6;try(omega);auto);
       try(apply IH  with (m:=  L_weight L) in H5;auto);
       try(apply IH  with (m:=  L_weight L) in H9;try(omega);auto).
     ++ (* par *)
       LexpSubst.
       apply IH  with (L:= F0 ::G0 :: L) (m:=  Exp_weight F0 + Exp_weight G0 + L_weight L) in H7;auto.
       simpl. omega.
     ++ (* with *)
       LexpSubst.
       apply IH  with (L:= F0 :: L) (m:=  Exp_weight F0 + L_weight L) in H8;autounfold;try(omega);auto.
       apply IH  with (L:= G0 :: L) (m:=  Exp_weight G0 + L_weight L) in H9;autounfold;try(omega);auto.

     ++ (* forall *)
       LexpSubst.
       assert(forall x, |-F- B; M; UP (((Subst FX x) ::L) ++ [F $ G] ++ L')) as Hp.
       intro.
       generalize(H5 x);intros.
       eapply IH with (m:=  exp_weight(FX unit tt) + L_weight L ) ;eauto.
       simpl.
       rewrite <- subs_weight_weak with (x:=x). auto.
       simpl. eapply tri_fx;auto;intro.
  Qed.

  Hint Resolve AsyncEqNeg.
  Theorem EquivAuxSync : forall B  L L' M  F ,  ~ Asynchronous F ->  |-F- B ; M ++ [F] ; UP (L ++ L') -> |-F- B ; M ;  UP (L ++ [F] ++ L').
  Proof.
    intros.
    remember (L_weight  L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .

    induction w as [| w' IH] using strongind; intros   M   B  L'  L  H1 Hw; destruct L as [|l].
    + simpl. simpl in H1.
      eapply tri_store;auto.
    + simpl in Hw. (* Hw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + simpl in Hw. inversion Hw.
    + caseLexp l ;inversion Hw as [Hw'];subst;auto;simpl in *;inversion Hw';inversion H1;subst;LexpContr;auto;
        try(
            match goal with
              [ H : |-F- _; (_ ++ [?F]) ++ [?G]; UP (?L ++ ?L') |- |-F- _ ; _ ; UP ( ?G :: ?L  ++ ?F :: ?L')] =>
              assert (Hch:  (M ++ [F]) ++ [G] =mul=  (M ++ [G]) ++ [F]) by solve_permutation;
              rewrite Hch in H;
              apply IH  with (m:=  L_weight L) in H;auto using le_plus_r
            end).
      ++ (* bot *)
        apply tri_bot.
        apply IH    with (m:=  L_weight L);auto.
      ++ (* PAR *)
        LexpSubst.
        apply IH  with (L:= F0 :: G :: L) (m:= Exp_weight F0 + Exp_weight G +  L_weight L) in H7;try(simpl; omega);auto.
      ++ (* WITH *)
        LexpSubst.
        apply IH  with (L:= F0 :: L) (m:= Exp_weight F0 + L_weight L) in H8;try(autounfold;simpl; omega);auto.
        apply IH  with (L:= G :: L) (m:= Exp_weight G + L_weight L) in H9;try(autounfold;simpl; omega);auto.
      ++ (* quest *)
        LexpSubst.
        apply IH  with  (m:= L_weight L) in H6;try(simpl; omega);auto.
      ++
        LexpSubst.
        assert(forall x, |-F- B; M; UP (((Subst FX x) ::L) ++ [F] ++ L')) as Hp.
        intro.
        generalize(H5 x);intros.
        eapply IH with (m:=  exp_weight(FX unit tt) + L_weight L ) ;eauto.
        rewrite <- subs_weight_weak with (x:=x). auto.
        eapply tri_fx;auto.
  Qed.

  Theorem EquivAuxQuest : forall B  L L' M  n F,  n |-F- B ++ [F] ; M ; UP (L ++ L') ->  |-F- B ; M ;  UP (L ++ [? F] ++ L').
  Proof.
    intros.
    remember (L_weight L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent n .
    generalize dependent w .

    induction w as [| w' IH] using strongind ; intros n M B L' L H Hw  ;  destruct L as [|l].
    + simpl. simpl in H.
      eapply tri_quest;auto.
      eapply AdequacyTri1;eauto.
    + simpl in Hw. (* Heqw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + simpl in Hw. inversion Hw.
    + caseLexp l ;inversion Hw as [Hw'];subst;auto;simpl in *;inversion Hw';inversion H;subst;LexpContr;auto;
        try(
            match goal with
              [ Hx : _ |-F- _ ++ [?F]; _ ++ [_]; UP (?L ++ ?L') |- _] =>
              apply IH  with (m:=  L_weight L) in Hx;auto using le_plus_r
            end).
      ++ (* bot *)
        apply tri_bot.
        apply IH  with (m:=  L_weight L) in H5;auto using le_plus_r.
      ++ (* par *)
        LexpSubst.
        apply IH  with (L:=F0 :: G :: L)  (m:=  Exp_weight F0 + Exp_weight G + L_weight L) in H7;auto using le_plus_r.
        simpl. omega.
      ++ (* with *)
        LexpSubst.
        apply IH  with (L:=F0 :: L)  (m:=  Exp_weight F0 + L_weight L) in H8;auto;try(autounfold;simpl;omega).
        apply IH  with (L:=G :: L)  (m:=  Exp_weight G + L_weight L) in H9;auto;try(autounfold;simpl;omega).
      ++ (* quest *)
        LexpSubst.
        apply tri_quest.

        eapply IH  with   (m:=  L_weight L);auto;try(autounfold;simpl;omega).
        assert((B ++ [F]) ++ [F0] =mul= (B ++ [F0]) ++ [F]) by solve_permutation.
        rewrite H2 in H6.
        eassumption.
      ++ (* FORALL *)
        LexpSubst.
        assert(forall x, |-F- B ; M; UP (((Subst FX x) ::L) ++ [? F] ++ L')) as Hp.
        intro.
        generalize(H5 x);intros.
        eapply IH with (m:=  exp_weight(FX unit tt) + L_weight L ) ;simpl;eauto.
        rewrite <- subs_weight_weak with (x:=x). auto.
        eapply tri_fx;auto.
  Qed.

  Theorem EquivAuxTop : forall B  L L' M ,  |-F- B ; M ;  UP (L ++ [Top] ++ L').
  Proof.
    intros.
    remember (L_weight  L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .

    induction w as [| w' IH] using strongind;  intros M B L' L Hw  ;  destruct L as [|l];simpl;auto.
    + simpl in Hw. (* Heqw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    + caseLexp l ;inversion Hw as [Hw'];subst;auto;simpl in *;inversion Hw';
        try(apply tri_store;try(autoLexp);auto  ; apply IH  with (m:=  L_weight L);try(omega);auto).
      ++

        (* bot *)
        apply tri_bot.
        apply IH  with (m:=  L_weight L);try(omega);auto.
      ++ (*  PAR *)
        apply tri_par.
        eapply IH  with  (L:= F :: G :: L) (m:= Exp_weight F + Exp_weight G + L_weight L);
          auto; try(rewrite H2);simpl;autounfold;try(omega).
      ++ (* with *)
        apply tri_with.
        eapply IH  with  (L:= F :: L) (m:= Exp_weight F + L_weight L);
          auto; try(rewrite H2);simpl;autounfold;try(omega).
        eapply IH  with  (L:= G :: L) (m:= Exp_weight G + L_weight L);
          auto; try(rewrite H2);simpl;autounfold;try(omega).
      ++ (* quest *)
        apply tri_quest.
        apply IH  with (m:=  L_weight L);try(omega);auto.
      ++ (* forall *)
        apply tri_fx.

        intro.
        apply IH with (L:= Subst FX x :: L) (m:= exp_weight  (FX unit tt) + L_weight L);simpl; try( rewrite Hw');auto.
        rewrite H0;auto.
        rewrite <- subs_weight_weak with (x:=x). auto.

  Qed.

  Theorem EquivAuxForAll : forall B  L L' M   FX, (forall x,  |-F- B ; M ; UP (L ++ [Subst FX x]++ L')) ->  |-F- B ; M ;  UP (L ++ [F{FX}] ++ L').
    intros.
    remember (L_weight  L) as w.
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .

    induction w as [| w' IH] using strongind ; intros M B L' L H Hw ;  destruct L as [|l].
    + simpl in*.
      eapply tri_fx;auto.
    + simpl in Hw. (* Heqw is inconsisten *)
      apply exp_weight0LF in Hw. contradiction.
    +  simpl in Hw. inversion Hw.
    + caseLexp l ; inversion Hw as [Hw']; simpl in *;auto;
        try(
            assert(Hp: forall x,  |-F- B; M ++ [l]; UP (L ++ [Subst FX x] ++ L'))
            by (
                intro; generalize (H x); intro Hp'; simpl in *;subst; inversion Hp';subst;LexpContr;auto);
            apply IH  with (m:= L_weight  L) in Hp;  subst;simpl; try(apply tri_store;autoLexp);try(omega);auto;
            simpl in Hw';inversion Hw';try(omega);auto).
      ++ (* bot *)
        assert(Hp: forall x,  |-F- B; M; UP (L ++ [Subst FX x] ++ L')).
        intro; generalize (H x); intro Hp'; inversion Hp'; subst; LexpContr;auto.
        assert(Asynchronous Bot) by auto;contradiction.
        apply IH  with (m:= L_weight  L) in Hp; try(apply tri_bot);try(omega);auto.
        subst;simpl in Hw';inversion Hw';auto.
      ++ (* par *)
        assert(Hp: forall x,  |-F- B; M; UP ( F :: G :: L ++ [Subst FX x] ++ L')).
        intro; generalize (H x); intro Hp'; inversion Hp'; subst;LexpContr;auto.
        LexpSubst. auto.
        assert(Asynchronous (F $ G)) by auto;contradiction.
        apply IH  with (L:= F :: G :: L) (m:= Exp_weight  F + Exp_weight G + L_weight  L) in Hp.
        apply tri_par. simpl in Hp. auto.
        subst. simpl in Hw';inversion Hw';auto.
        simpl. omega.
      ++ (* With *)
        subst.
        assert(Hp1: forall x,  |-F- B; M; UP ( F:: L ++ [Subst FX x] ++ L')).
        intro; generalize (H x); intro Hp1'; inversion Hp1'; subst;LexpContr;intuition.
        LexpSubst;auto.
        assert(Hp2: forall x,  |-F- B; M; UP ( G:: L ++ [Subst FX x] ++ L')).
        intro; generalize (H x); intro Hp2'; inversion Hp2'; subst;LexpContr;intuition.
        LexpSubst;auto.
        inversion Hw'.
        apply IH  with (L:= F :: L) (m:= Exp_weight F + L_weight L) in Hp1;try(omega); subst;autounfold;simpl;try(omega); auto.
        apply IH  with (L:= G :: L) (m:= Exp_weight G + L_weight L) in Hp2;try(omega); subst;autounfold;simpl;try(omega); auto.
      ++  (* quest *)

        assert(Hp: forall x,  |-F- B ++ [F]; M; UP (L ++ [Subst FX x] ++ L')) .
        intro; generalize (H x); intro Hp'; inversion Hp'; subst;LexpContr;intuition.
        subst;LexpSubst;auto.
        apply IH  with (m:= L_weight  L) in Hp. apply tri_quest;auto.
        subst;inversion Hw';omega.
        auto.

      ++ (* forall *)
        subst.
        assert(Hp: forall x x', |-F- B; M; UP ((Subst FX0 x') :: L ++ [Subst FX x] ++ L')).
        intro; generalize (H x); intro Hp'; inversion Hp'; subst;LexpContr;auto.
        assert(Asynchronous (F{ FX0})) by auto;contradiction.
        LexpSubst;auto.
        apply tri_fx;intro.

        apply IH with (L:= Subst FX0 x :: L) (m:= Exp_weight  (Subst FX0  x) + L_weight  L).
        simpl in Hw';inversion Hw'. autounfold.
        rewrite <- subs_weight_weak with (x:=x). auto.
        intro. simpl.
        apply Hp;auto.
        simpl. auto.

  Qed.

  Theorem EquivUpArrow : forall B L L' M n, n |-F- B ; M ; UP L -> L =mul= L' ->|-F- B ; M ;  UP L'.
  Proof.
    intros.
    remember (L_weight L) as w.
    generalize dependent n .
    generalize dependent L .
    generalize dependent L' .
    generalize dependent B .
    generalize dependent M .
    generalize dependent w .

    induction w as [| w' IH] using strongind;  intros ;  destruct L as [|l].
    +assert (L'= []) by( apply emp_mult;auto).
     subst.
     eapply AdequacyTri1;eauto.
    + inversion Heqw.
      generalize(exp_weight0  l);intros.
      omega.
    + assert (L'= []) by( apply emp_mult;auto).
      subst.
      eapply AdequacyTri1;eauto.
    + destruct L' as [_| l'].
      (* H0 is inconsisten *)
      apply DestructMulFalse in H0. contradiction.

      apply DestructMSet2 in H0 as Heq.

      destruct Heq as [Heq | Heq].
      ++ destruct Heq;subst.
         inversion H;subst;try(simpl in Heqw; inversion Heqw; subst;simpl;try(omega)).
         +++  (* top *)
           eapply tri_top.
         +++ (* bottom *)
           eapply IH with (L' :=L') in H6;auto.
         +++ (* par *)
           eapply IH with (L' := F::G::L') in H6;auto.
           simpl. autounfold. omega.

         +++ (* with *)
           eapply IH with (m:= L_weight (F::L)) (L:= F ::L) (L' := F :: L') in H7;auto.
           eapply IH with (m:= L_weight (G::L)) (L := G :: L) (L' := G :: L') in H8;auto.
           simpl. autounfold. omega.
           simpl. autounfold. omega.
         +++  (* quest *)
           eapply IH with (m:= L_weight L) (L' :=L') in H6;auto.
           omega.
         +++  (* store *)
           eapply IH with (m:= L_weight L) (L' :=L') in H8;auto.
           generalize(exp_weight0  l');intro.
           omega.
         +++ (* forall *)
           eapply tri_fx;auto.
           intro.
           generalize (H6 x);intro.
           eapply IH with (m:= Exp_weight (Subst FX x) + L_weight L) (L' := Subst FX x :: L') in H1;auto.
           simpl. rewrite <- subs_weight_weak with (x:=x). auto.
      ++
        destruct Heq as [L1 [L2 [L1' [L2' Heq]]]].

        destruct Heq as [Heq [Heq1 Heq2]];subst.

        inversion H;subst.
        +++ (* top *)
          eapply EquivAuxTop with (L:= l' :: L1').
        +++ (* bottom *)
          eapply IH with (m:= L_weight(L1 ++ l' :: L2))(L:=L1 ++ l' :: L2) (L' := [l'] ++ L1' ++ L2') in H5 .
          simpl in H5.
          eapply AdequacyTri2 in H5. destruct H5.

          apply EquivAuxBot with (L:= l' :: L1');simpl.
          apply AdequacyTri1 in H1.
          auto.

          simpl in Heqw. inversion Heqw. auto.
          solve_permutation.
          reflexivity.
        +++ (* par *)
          eapply IH with (m:= L_weight(F :: G :: L1 ++ l' :: L2))
                           (L:=F :: G :: L1 ++ l' :: L2)
                           (L' := [l'] ++ L1' ++ [F ; G] ++ L2') in H5 .
          eapply AdequacyTri2 in H5. destruct H5.

          eapply EquivAuxPar with (L:= l' :: L1');eauto.
          simpl in Heqw. inversion Heqw. auto.
          simpl. rewrite Nat.add_assoc. auto.
          solve_permutation.
          reflexivity.

        +++ (* with *)
          eapply IH with (m:= L_weight(F :: L1 ++ l' :: L2))
                           (L:=F :: L1 ++ l' :: L2)
                           (L' := [l'] ++ L1' ++ [F ] ++ L2') in H6 .
          eapply IH with (m:= L_weight(G :: L1 ++ l' :: L2))
                           (L:=G :: L1 ++ l' :: L2)
                           (L' := [l'] ++ L1' ++ [G ] ++ L2') in H7 .

          apply EquivAuxWith with (L := l' :: L1'); simpl;auto.
          simpl in Heqw. inversion Heqw. auto.
          simpl. rewrite plus_assoc_reverse. apply le_plus_r.

          solve_permutation.
          reflexivity.
          simpl in Heqw. inversion Heqw. simpl.
          autounfold. omega.
          solve_permutation.
          reflexivity.

        +++ (* quest *)
          eapply IH with (m:= L_weight(L1 ++ l' :: L2))(L:=L1 ++ l' :: L2) (L' := [l'] ++ L1' ++ L2') in H5 .
          eapply AdequacyTri2 in H5. destruct H5.
          eapply EquivAuxQuest with (L := l' :: L1');eauto.

          simpl in Heqw. inversion Heqw. auto.
          simpl. omega.
          solve_permutation.
          reflexivity.

        +++ (* copy *)
          eapply IH with (m:= L_weight(L1 ++ l' :: L2))(L:=L1 ++ l' :: L2) (L' := [l'] ++ L1' ++ L2') in H7 .

          eapply EquivAuxSync with (L:=l' :: L1');eauto.

          simpl in Heqw. rewrite L_weightApp in Heqw. simpl in Heqw.
          rewrite L_weightApp.

          generalize(exp_weight0  l);intro.
          apply GtZero in H1.
          destruct H1.
          rewrite H1 in Heqw. simpl in Heqw.

          inversion Heqw.
          simpl. autounfold. omega.
          rewrite <- Heq2.
          solve_permutation.

          reflexivity.
        +++ (* forall *)

          assert(forall x, |-F- B; M; UP ((l' :: L1' ) ++ [Subst FX x] ++ L2')).
          intro x.
          eapply IH with (m:= L_weight(Subst FX x :: L1 ++ l' :: L2)) (L:=Subst FX x :: L1 ++ l' :: L2)  ;auto.
          inversion Heqw.
          simpl.
          rewrite <- subs_weight_weak with (x:=x). auto.

          solve_permutation.

          apply EquivAuxForAll in H1.
          apply H1.
  Qed.

  Theorem EquivUpArrow2 : forall B L L' M , |-F- B ; M ; UP L -> L =mul= L' ->|-F- B ; M ;  UP L'.
    intros.
    apply AdequacyTri2 in H.
    destruct H.
    eapply EquivUpArrow in H;eauto.
  Qed.

  (* Weakening *)
  Theorem TriWeakening : forall B L F X n, n |-F- B ; L ; X -> n |-F- B ++ [F] ; L ; X.
    intros.
    generalize dependent L .
    generalize dependent B .
    generalize dependent F .
    generalize dependent X .
    generalize dependent n .
    induction n using strongind;intros;auto.
    + (* Base *)
      inversion H;subst.
      ++ eapply trih_init1;auto.
      ++ apply trih_init2 with (B' := B' ++ [F]);auto.
         rewrite H1.  solve_permutation.

      ++ eapply trih_one.
      ++ eapply trih_top.
    + (* Inductive *)
      inversion H0;subst.
      ++ eapply H in H3;auto.
         eapply H in H4;auto.
         eapply trih_tensor;eauto.
      ++ eapply H in H2;auto.
         eapply trih_plus1;eauto.
      ++ eapply H in H2;auto.
         eapply trih_plus2;eauto.
      ++ eapply H in H2;auto.
         eapply trih_bang;eauto.
      ++ eapply H in H3;auto.
         eapply trih_rel;eauto.
      ++ eapply H in H2;auto.
         eapply trih_bot;eauto.
      ++ eapply H in H2;auto.
         eapply trih_par;eauto.
      ++ eapply H in H2;auto.
         eapply H in H3;auto.
         eapply trih_with;eauto.
      ++  eapply H with (B := B ++ [F0]) (F:=F) in H2;auto.
          eapply trih_quest;auto.
          assert( (B ++ [F]) ++ [F0] =mul= (B ++ [F0]) ++ [F]) by solve_permutation.
          rewrite H1.
          auto.
      ++ eapply H in H3;auto.
         eapply trih_store;eauto.
      ++ eapply H in H4;auto.
         eapply trih_dec1 with (F:=F0);eauto.
      ++ eapply H with (F:=F) in H4;auto.
         rewrite H3. rewrite H3 in H4.
         eapply trih_dec2 with (F:=F0);eauto.
      ++ eapply H in H2;auto.
         eapply trih_ex;eauto.
      ++ assert(forall x,  n |-F- B ++ [F]; L; UP (Subst FX x :: M)).
         intro.
         generalize(H2 x);intro.
         eapply H in H1;eauto.
         eapply trih_fx; auto.

  Qed.

  (* Up and Down relation *)
  Lemma UpExtension: forall B M L F n, LexpPos (M ++ [F]) -> n |-F- B; M ++ [F] ; UP L ->
                                                                                exists m, m<= S n /\ m |-F- B; M ; UP (L ++ [F]).

    intros.
    remember (L_weight  L) as w.
    generalize dependent L .
    generalize dependent B .
    generalize dependent M .
    generalize dependent n .
    generalize dependent w .

    induction w as [| w' IH] using strongind .  intros n  M HPos  B L HD Hw.
    + (* w = 0 *)
      destruct L. (* L must be empty. The second case is trivial *)
      exists ((S n)).
      split;auto.
      simpl.
      eapply trih_store ;auto.

      generalize(LPos3 M [F] (meq_refl (M ++ [F])) HPos);intro.
      inversion H;auto.

      simpl in Hw.
      apply AsyncEqNeg;auto.

      apply exp_weight0LF in Hw;contradiction.

    + intros.
      destruct L. (* L cannot be empty *)
      inversion Heqw.
      inversion H0;auto;subst;inversion Heqw;subst.
      ++ (* top *)
        exists 0%nat;split;auto.
        eapply trih_top.
      ++ (* bot *)
        apply IH with (m:= L_weight  L) in H5;auto.
        destruct H5 as [n'  [IHn IHd]].
        exists (S n');split;auto. omega. simpl. eapply trih_bot;auto.
      ++  (* PAR *)
        apply IH with (m:= Exp_weight  F0 + Exp_weight  G + L_weight  L) in H5;auto.
        destruct H5 as [n'  [IHn IHd]].
        exists (S n');split;auto. omega. simpl. eapply trih_par;auto.
        simpl. omega.
      ++ (* with *)
        apply IH with (m:= Exp_weight  F0 + L_weight  L) in H6;auto.
        apply IH with (m:= Exp_weight  G + L_weight L) in H7;auto.
        destruct H6 as [n'  [IHn IHd]].
        destruct H7 as [m'  [IHn' IHd']].
        simpl.

        exists (S (Init.Nat.max n' m'));split;auto. simpl.
        apply le_n_S.
        rewrite Max.succ_max_distr.
        apply Nat.max_le_compat;auto.
        autounfold. omega.
        autounfold. omega.

      ++  (* quest *)
        apply IH with (m:= L_weight  L) in H5;auto.
        destruct H5 as [n'  [IHn IHd]].
        exists (S n');split;auto. omega. simpl; eauto.
        omega.
      ++ (* Store *)
        assert(exists m0 : nat, m0 <= S n0 /\ m0 |-F- B; M ++ [l]; UP (L ++ [F])).
        apply IH with (m:= L_weight  L);eauto using WeightLeq.
        apply LPos1 with (L:= [l] ++ (M ++ [F]));auto.
        rewrite app_assoc_reverse.
        solve_permutation.

        apply lexpPosUnion;auto.
        apply AsynchronousFlexpPos;auto.
        apply AsyncEqNeg;auto.
        assert((M ++ [l]) ++ [F] =mul=  (M ++ [F]) ++ [l]) by solve_permutation.
        rewrite H1;auto.
        destruct H1 as [n'  [IHn IHd]].
        exists (S n');split;auto. omega. simpl;eauto.
      ++  (* FORALL *)
        assert(forall x, exists m, m <= S n0 /\ m |-F- B; M; UP ((Subst FX x :: L)  ++ [F])).
        intro.
        generalize (H5 x);intro.
        eapply IH with (m:=Exp_weight (Subst FX x) + L_weight L);auto.
        rewrite <- subs_weight_weak with (x:=x). auto.
        apply ax_subs_prop in H1.
        destruct H1 as [n H1].
        destruct H1 as [H1 H1'].
        exists (S n). split.
        omega.
        eapply trih_fx.
        intro x.
        generalize (H1' x); intro Hx.
        auto.
  Qed.
End SRule.


(*! Tactics for proofs about bit vectors !*)
Require Import Coq.micromega.Lia.
Require Export Koika.EqDec Koika.Vect Koika.Primitives Koika.PrimitiveProperties.
Import BitFuns.

(* This definition is useful for the next tactics *)
Definition bits_get_size {sz} (bs: bits sz) :=
  sz.

Ltac Bits_to_N_t :=
  unfold PrimSpecs.sigma1, CircuitPrimSpecs.sigma1,
  PrimSpecs.sigma2, CircuitPrimSpecs.sigma2,
  Bits.plus, Bits.mul in *;
  simpl arg1Sig;
  repeat match goal with
         | _ => progress bool_step
         | _ => progress (rewrite Bits.of_N_to_N in * )
         | [ H: Ob~_ = Ob~_ |- _ ] => injection H as H
         | [ H: Bits.single (Bits.neg _) = true |- _ ] =>
           apply negb_true_iff in H
         | [ H: Bits.single (Bits.neg _) = false |- _ ] =>
           apply negb_false_iff in H
         | [ H: Bits.single (Bits.and _ _) = true |- _ ] =>
           apply andb_true_iff in H; destruct H
         | [ H: Bits.single (Bits.and _ _) = false |- _ ] =>
           apply andb_false_iff in H
         | [ H: Bits.single (BitFuns._eq _ _) = true |- _ ] =>
           apply beq_dec_iff in H
         | [ H: Bits.single (BitFuns._eq _ _) = false |- _ ] =>
           apply beq_dec_false_iff in H
         | [ H: Bits.single ?bs = _ |- _ ] =>
           apply Bits.single_to_bits in H
         | _ => progress (rewrite sel_spec in * )
         | [ H: context[Bits.to_N (BitFuns.lsl ?x ?y)] |- _ ] =>
           rewrite to_N_lsl in H
         | [ |- context[Bits.to_N (BitFuns.lsl ?x ?y)] ] =>
           rewrite to_N_lsl
         | [ H: context[Bits.to_N (Bits.extend_end ?bs ?sz' false)] |- _ ] =>
           setoid_rewrite (to_N_extend_end_false (bits_get_size bs) bs sz') in H
         | [ |- context[Bits.to_N (Bits.extend_end ?bs ?sz' false)] ] =>
           setoid_rewrite (to_N_extend_end_false (bits_get_size bs) bs sz')
         | [ H: _ = _ |- _ ] =>
           apply (f_equal Bits.to_N) in H
         | [ H: _ <> _ |- _ ] =>
           apply Bits.to_N_inj_contra in H
         end.

Ltac remember_bits_to_N :=
  repeat match goal with
         | [ |- context[Bits.to_N ?bs] ] =>
           remember_once (Bits.to_N bs)
         | [ H: context[Bits.to_N ?bs] |- _ ] =>
           remember_once (Bits.to_N bs)
         end.

Ltac pose_bits_bound_proofs :=
  repeat match goal with
         | [ H: context[Bits.to_N ?bs] |- _ ] =>
           pose_once Bits.to_N_bounded bs
         | [ |- context[Bits.to_N ?bs] ] =>
           pose_once Bits.to_N_bounded bs
         end.

(** Lia with some support for the Bits.to_N function **)
Ltac lia_bits :=
  Bits_to_N_t; cbn in *; pose_bits_bound_proofs; remember_bits_to_N; cbn in *; lia.