(* 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 isocele.
Set Implicit Arguments.
Unset Strict Implicit.
Parameter reflexion : PO -> PO -> PO -> PO.

Axiom
  reflexion_def :
    forall A B M M' H : PO,
    A <> B ->
    H = projete_orthogonal A B M ->
    M' = reflexion A B M -> vec M M' = mult_PP 2 (vec M H).

Axiom
  reflexion_def2 :
    forall A B M M' H : PO,
    A <> B ->
    H = projete_orthogonal A B M ->
    vec M M' = mult_PP 2 (vec M H) -> M' = reflexion A B M.

Lemma reflexion_axe :
 forall A B M : PO, A <> B -> alignes A B M -> M = reflexion A B M.
intros A B M H2 H0; try assumption.
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H3; try clear existence_projete_orthogonal; try exact H3 | auto ].
apply reflexion_def2 with H; auto.
cut (M = H); intros.
rewrite <- H1; Ringvec.
rewrite H3.
apply def_projete_orthogonal; auto.
replace (vec M M) with zero; auto with geo.
Ringvec.
Qed.
Hint Resolve reflexion_axe: geo.

Lemma reflexion_projete_orthogonal_milieu :
 forall A B M M' H : PO,
 A <> B ->
 H = projete_orthogonal A B M -> M' = reflexion A B M -> H = milieu M M'.
intros.
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros H5.
cut (2 <> 0); intros.
apply vecteur_milieu.
rewrite H5; auto.
replace (mult_PP (/ 2) (mult_PP 2 (vec M H))) with
 (mult_PP (/ 2 * 2) (vec M H)).
replace (/ 2 * 2) with 1.
Ringvec.
auto with real.
Ringvec.
discrR.
Qed.

Lemma reflexion_image_distinct :
 forall A B M M' : PO, ~ alignes A B M -> M' = reflexion A B M -> M <> M'.
intros A B M M' H0 H1; try assumption.
cut (A <> B); intros H2; [ idtac | auto with geo ].
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H3; try clear existence_projete_orthogonal; try exact H3 | auto ].
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros H5.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
cut (M <> H); intros.
apply dist_non_nulle.
unfold not in |- *; intros; apply H6.
apply distance_nulle.
rewrite (milieu_vecteur2 (A:=M) (B:=M') (M:=H)); auto.
Simplscal.
rewrite carre_scalaire_distance; rewrite H7; ring.
unfold not in |- *; intros; apply H0.
rewrite H6.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := M) (H := H);
 [ intros; try exact H7 | auto | auto ].
Qed.

Lemma reflexion_mediatrice :
 forall A B M M' : PO,
 ~ alignes A B M ->
 M' = reflexion A B M -> mediatrice M M' A /\ mediatrice M M' B.
intros A B M M' H1 H3; try assumption.
cut (A <> B); intros H0; [ idtac | auto with geo ].
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H2; try clear existence_projete_orthogonal | auto ].
generalize (reflexion_image_distinct (A:=A) (B:=B) (M:=M) (M':=M'));
 intros H5.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := M) (H := H);
 [ intros | auto | auto ].
halignes H7 ipattern:(k).
split; [ try assumption | idtac ].
elim (classic (H = A)); intros.
rewrite <- H10.
apply milieu_mediatrice; auto.
apply orthogonale_segment_milieu_mediatrice with H; auto.
apply ortho_sym.
cut (orthogonal (vec A B) (vec M M')); intros.
replace (vec H A) with (mult_PP (- k) (vec A B)).
Simplortho.
replace (vec H A) with (mult_PP (-1) (vec A H)).
rewrite H9.
Ringvec.
Ringvec.
apply ortho_sym.
rewrite H6; auto.
Simplortho.
elim (classic (H = B)); intros.
rewrite <- H10.
apply milieu_mediatrice; auto.
apply orthogonale_segment_milieu_mediatrice with H; auto.
apply ortho_sym.
cut (orthogonal (vec A B) (vec M M')); intros.
replace (vec H B) with
 (add_PP (mult_PP (- k) (vec A B)) (mult_PP 1 (vec A B))).
Simplortho.
replace (mult_PP (- k) (vec A B)) with (mult_PP (-1) (mult_PP k (vec A B))).
rewrite <- H9.
Ringvec.
Ringvec.
apply ortho_sym.
rewrite H6; auto.
Simplortho.
Qed.

Lemma reflexion_axe_orthogonal_segment :
 forall A B M M' : PO,
 ~ alignes A B M -> M' = reflexion A B M -> orthogonal (vec M M') (vec A B).
intros.
assert (A <> B); auto with geo.
apply ortho_sym; auto.
elim (reflexion_mediatrice (A:=A) (B:=B) (M:=M) (M':=M')); auto; intros.
apply mediatrice_orthogonale_segment; auto.
apply reflexion_image_distinct with (2 := H0); auto.
Qed.

Lemma projete_orthogonal_image :
 forall A B M M' H : PO,
 A <> B ->
 H = projete_orthogonal A B M ->
 M' = reflexion A B M -> H = projete_orthogonal A B M'.
intros.
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros H5.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := M) (H := H);
 [ intros | auto | auto ].
apply def_projete_orthogonal; auto.
apply ortho_sym.
replace (vec H M') with (vec M H); auto with geo.
Qed.

Lemma non_axe_image_non_axe :
 forall A B M M' : PO,
 ~ alignes A B M -> M' = reflexion A B M -> ~ alignes A B M'.
intros A B M M' H0 H2; try assumption.
cut (A <> B); intros H1; [ idtac | auto with geo ].
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H3; try clear existence_projete_orthogonal; try exact H3 | auto ].
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros H5.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
elim reflexion_mediatrice with (A := A) (B := B) (M := M) (M' := M');
 [ intros H6 H7; try clear reflexion_mediatrice; try exact H7 | auto | auto ].
generalize (mediatrice_orthogonale_segment (A:=M) (B:=M') (M:=A) (N:=B));
 intros.
generalize (reflexion_image_distinct (A:=A) (B:=B) (M:=M) (M':=M')); intros.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := M) (H := H);
 [ intros | auto | auto ].
cut (H = projete_orthogonal A B M'); intros.
cut (M' <> H); intros.
unfold not in |- *; intros; apply H13.
rewrite H12.
apply def_projete_orthogonal; auto.
replace (vec M' M') with zero.
apply zero_ortho_tout.
Ringvec.
rewrite H4; auto.
apply milieu_distinct2; auto.
apply projete_orthogonal_image with M; auto.
Qed.

Lemma reflexion_symetrie :
 forall A B M M' : PO, A <> B -> M' = reflexion A B M -> M = reflexion A B M'.
intros A B M M' H1 H0; try assumption.
elim (classic (alignes A B M)); intros H20.
rewrite H0.
rewrite <- reflexion_axe.
rewrite <- reflexion_axe; auto.
auto.
rewrite <- reflexion_axe; auto.
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H3; try clear existence_projete_orthogonal; try exact H3 | auto ].
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros H5.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
generalize (projete_orthogonal_image (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
generalize (non_axe_image_non_axe (A:=A) (B:=B) (M:=M) (M':=M')); intros.
apply reflexion_def2 with H; auto with geo.
Qed.

Lemma reflexion_isocele :
 forall A B M M' : PO, A <> B -> M' = reflexion A B M -> isocele A M M'.
intros.
elim (classic (alignes A B M)); intros.
replace M' with M; auto.
unfold isocele in |- *; auto.
rewrite H0; rewrite <- reflexion_axe; auto.
apply mediatrice_isocele.
elim (reflexion_mediatrice (A:=A) (B:=B) (M:=M) (M':=M')); auto.
Qed.

Lemma axe_reflexion_droite :
 forall A B C M M' : PO,
 A <> B ->
 A <> C -> alignes A B C -> M' = reflexion A B M -> M' = reflexion C A M.
intros A B C M M' H10 H0 H1 H2; try assumption.
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H4; try clear existence_projete_orthogonal; try exact H3 | auto ].
halignes H1 ipattern:(k).
elim def_projete_orthogonal2 with (A := A) (B := B) (C := M) (H := H);
 [ intros | auto | auto ].
apply reflexion_def2 with H; auto.
apply def_projete_orthogonal.
auto.
halignes H5 ipattern:(k0).
elim (classic (k = 0)); intros.
absurd (A = C); auto.
rewrite H8 in H3.
apply conversion_PP with (a := 1) (b := 1); auto with real.
RingPP2 H3.
Ringvec.
apply colineaire_alignes with (/ k * (k + - k0)).
replace (vec C H) with (add_PP (vec A H) (mult_PP (-1) (vec A C))).
replace (vec C A) with (mult_PP (-1) (vec A C)).
rewrite H7; rewrite H3.
replace (mult_PP (/ k * (k + - k0)) (mult_PP (-1) (mult_PP k (vec A B))))
 with (mult_PP (/ k * (k + - k0) * (-1 * k)) (vec A B)).
replace (/ k * (k + - k0) * (-1 * k)) with (/ k * k * (-1 * (k + - k0))).
replace (/ k * k) with 1.
Ringvec.
auto with real.
ring.
Ringvec.
Ringvec.
Ringvec.
replace (vec C A) with
 (add_PP (mult_PP 0 (vec A B)) (mult_PP (- k) (vec A B))).
apply ortho_combinaison_lineaire; auto.
replace (vec C A) with (mult_PP (-1) (vec A C)).
rewrite H3.
Ringvec.
Ringvec.
rewrite (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); auto.
Qed.

Theorem axe_reflexion_bissectrice :
 forall A B M M' : PO,
 ~ alignes A B M ->
 M' = reflexion A B M ->
 cons_AV (vec A M) (vec A B) = cons_AV (vec A B) (vec A M').
intros A B M M' H1 H2; try assumption.
cut (A <> B); intros H0; [ idtac | auto with geo ].
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H4; try clear existence_projete_orthogonal; try exact H3 | auto ].
generalize (non_axe_image_non_axe (A:=A) (B:=B) (M:=M) (M':=M')); intros.
generalize (non_alignes_distincts (A:=A) (B:=B) (C:=M')); intros.
generalize (non_alignes_distincts (A:=A) (B:=B) (C:=M)); intros.
elim def_projete_orthogonal2 with (A := A) (B := B) (C := M) (H := H);
 [ intros; try exact H13 | auto | auto ].
elim (classic (A = H)); intros.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
apply milieu_angles_orthogonaux; auto.
apply reflexion_image_distinct with (2 := H2); auto.
rewrite H9; auto.
generalize (reflexion_def (A:=A) (B:=B) (M:=M) (M':=M') (H:=H)); intros.
replace (vec M M') with
 (add_PP (mult_PP (-1) (vec H M)) (mult_PP (-1) (vec H M))).
apply ortho_combinaison_lineaire; apply ortho_sym; auto.
rewrite H11; auto.
Ringvec.
cut (cons_AV (vec A M) (vec A H) = cons_AV (vec A H) (vec A M')); intros;
 auto.
rewrite angles_representants_unitaires; auto.
rewrite angles_representants_unitaires; auto.
elim existence_representant_unitaire with (A := A) (B := H);
 [ intros; try clear existence_representant_unitaire | auto ].
elim existence_representant_unitaire with (A := A) (B := M');
 [ intros; try clear existence_representant_unitaire | auto ].
elim existence_representant_unitaire with (A := A) (B := M);
 [ intros; try clear existence_representant_unitaire | auto ].
elim alignes_representant_unitaire with (A := A) (B := B) (C := H);
 [ intros; try clear alignes_representant_unitaire; auto
 | intros; auto
 | auto
 | auto
 | auto ].
rewrite H14.
rewrite <- angles_representants_unitaires; auto.
rewrite <- angles_representants_unitaires; auto.
replace (representant_unitaire (vec A B)) with
 (mult_PP (-1) (representant_unitaire (vec A H))).
cut (A <> x); intros.
replace (mult_PP (-1) (representant_unitaire (vec A H))) with (vec x A).
replace (cons_AV (representant_unitaire (vec A M)) (vec x A)) with
 (plus (cons_AV (representant_unitaire (vec A M)) (vec A x))
    (cons_AV (vec A x) (vec x A))).
replace (cons_AV (vec x A) (representant_unitaire (vec A M'))) with
 (plus (cons_AV (vec x A) (vec A x))
    (cons_AV (vec A x) (representant_unitaire (vec A M')))).
rewrite <- angle_plat; auto.
rewrite <- angle_plat; auto.
rewrite H11.
rewrite <- angles_representants_unitaires; auto.
rewrite <- angles_representants_unitaires; auto.
rewrite <- H10; auto.
mesure A M A H.
replace (x2 + pi) with (pi + x2); (try ring; auto).
rewrite <- H12.
cut (A <> x0); intros.
rewrite Chasles; auto.
apply distance_non_nulle.
elim def_representant_unitaire2 with (A := A) (B := M') (C := x0);
 [ intros; elim H17; intros H22 H23; try clear H17 def_representant_unitaire2;
    rewrite H22; try discrR
 | auto
 | auto ].
rewrite <- H13.
cut (A <> x1); intros.
rewrite Chasles; auto.
apply distance_non_nulle.
elim def_representant_unitaire2 with (A := A) (B := M) (C := x1);
 [ intros; elim H17; intros H22 H23; try clear H18 def_representant_unitaire2;
    rewrite H22; try discrR
 | auto
 | auto ].
rewrite <- H11; Ringvec.
apply distance_non_nulle.
elim def_representant_unitaire2 with (A := A) (B := H) (C := x);
 [ intros; elim H16; intros H22 H23; try clear H18 def_representant_unitaire2;
    rewrite H22; try discrR
 | auto
 | auto ].
rewrite H14.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros; try clear existence_representant_unitaire | auto ].
rewrite <- H15; Ringvec.
generalize (reflexion_image_distinct (A:=A) (B:=B) (M:=M) (M':=M')); intros.
generalize (reflexion_mediatrice (A:=A) (B:=B) (M:=M) (M':=M')); intros.
elim H11; auto; intros.
generalize
 (reflexion_projete_orthogonal_milieu (A:=A) (B:=B) (M:=M) (M':=M') (H:=H));
 intros.
apply mediatrice_milieu_angles; auto.
Qed.

Lemma reflexion_isocele2 :
 forall A B M M' : PO, A <> B -> M' = reflexion A B M -> isocele B M M'.
intros.
apply reflexion_isocele with A; auto.
apply axe_reflexion_droite with B; auto with geo.
Qed.

Lemma reflexion_inverse_angle :
 forall A B M M' : PO,
 A <> B ->
 M <> A ->
 M <> B ->
 M' = reflexion A B M ->
 cons_AV (vec M' A) (vec M' B) = opp (cons_AV (vec M A) (vec M B)).
intros.
elim (classic (alignes A B M)); intros.
replace M' with M; auto.
cut (double_AV (cons_AV (vec M A) (vec M B)) = image_angle 0); intros.
replace (opp (cons_AV (vec M A) (vec M B))) with
 (plus (image_angle 0) (opp (cons_AV (vec M A) (vec M B))));
 auto.
rewrite <- H4; unfold double_AV in |- *.
mesure M A M B.
replace (x + x + - x) with x; auto.
ring.
mesure M A M B.
replace (0 + - x) with (- x); auto.
ring.
apply angle_alignes; auto with geo.
rewrite H2; rewrite <- reflexion_axe; auto.
cut (M <> M'); intros.
cut (~ alignes A B M'); intros.
cut (A <> M'); intros.
cut (B <> M'); intros.
replace (cons_AV (vec M A) (vec M B)) with
 (plus (cons_AV (vec M A) (vec M M')) (cons_AV (vec M M') (vec M B))).
rewrite opp_plus_plus_opp; auto.
rewrite def_opp; auto.
lapply (reflexion_isocele (A:=A) (B:=B) (M:=M) (M':=M')); auto; intros.
lapply (reflexion_isocele2 (A:=A) (B:=B) (M:=M) (M':=M')); auto; intros.
lapply (isocele_angles_base (A:=A) (B:=M) (C:=M')); auto; intros.
lapply (isocele_angles_base (A:=B) (B:=M) (C:=M')); auto; intros.
rewrite H11; auto.
rewrite H10; auto.
rewrite def_opp; auto.
rewrite Chasles; auto.
rewrite Chasles; auto.
lapply (non_alignes_distincts2 (A:=A) (B:=B) (C:=M')); auto; intros.
lapply (non_alignes_distincts (A:=A) (B:=B) (C:=M')); auto; intros.
apply non_axe_image_non_axe with M; auto.
apply reflexion_image_distinct with (2 := H2); auto.
Qed.

Lemma reflexion_isometrie :
 forall A B M M' N N' : PO,
 A <> B ->
 M' = reflexion A B M ->
 N' = reflexion A B N -> distance M N = distance M' N'.
intros.
discrimine M N.
rewrite H2 in H0.
rewrite H0; rewrite <- H1.
rewrite distance_refl2; auto.
rewrite distance_refl2; auto.
elim (classic (alignes A B M)); intros.
replace M' with M; auto.
elim (classic (alignes A B N)); intros.
replace N' with N; auto.
rewrite H1; rewrite <- reflexion_axe; auto.
cut (A <> N); intros.
cut (A <> N'); intros.
discrimine M A.
elim (reflexion_mediatrice (A:=A) (B:=B) (M:=N) (M':=N')); auto;
 unfold mediatrice in |- *; intros.
lapply (axe_reflexion_droite (A:=A) (B:=B) (C:=M) (M:=N) (M':=N')); auto;
 intros.
elim (reflexion_mediatrice (A:=M) (B:=A) (M:=N) (M':=N')); auto with geo;
 unfold mediatrice in |- *; intros.
lapply (alignes_non_alignes_trans (A:=A) (B:=B) (C:=N) (D:=M)); auto with geo;
 intros.
lapply (non_alignes_distincts (A:=A) (B:=B) (C:=N')); auto with geo; intros.
apply non_axe_image_non_axe with N; auto with geo.
apply non_alignes_distincts with B; auto with geo.
rewrite H0; rewrite <- reflexion_axe; auto.
cut (A <> M); intros.
cut (A <> M'); intros.
elim (classic (alignes A B N)); intros.
replace N' with N; auto.
discrimine N A.
rewrite distance_sym; rewrite (distance_sym M' A).
elim (reflexion_mediatrice (A:=A) (B:=B) (M:=M) (M':=M')); auto with geo;
 unfold mediatrice in |- *; intros.
lapply (axe_reflexion_droite (A:=A) (B:=B) (C:=N) (M:=M) (M':=M'));
 auto with geo; intros.
rewrite distance_sym; rewrite (distance_sym M' N).
elim (reflexion_mediatrice (A:=N) (B:=A) (M:=M) (M':=M')); auto with geo;
 unfold mediatrice in |- *; intros.
lapply (alignes_non_alignes_trans (A:=A) (B:=B) (C:=M) (D:=N)); auto with geo;
 intros.
rewrite H1; rewrite <- reflexion_axe; auto.
cut (A <> N); intros.
cut (A <> N'); intros.
elim
 cas_egalite_triangle_indirect
  with (A := A) (B := M) (C := N) (A' := A) (B' := M') (C' := N');
 (auto; intros).
elim (reflexion_mediatrice (A:=A) (B:=B) (M:=M) (M':=M')); auto with geo;
 unfold mediatrice in |- *; intros.
elim (reflexion_mediatrice (A:=A) (B:=B) (M:=N) (M':=N')); auto with geo;
 unfold mediatrice in |- *; intros.
replace (cons_AV (vec A M) (vec A N)) with
 (plus (cons_AV (vec A M) (vec A B)) (cons_AV (vec A B) (vec A N))).
rewrite (axe_reflexion_bissectrice (A:=A) (B:=B) (M:=M) (M':=M')); auto.
replace (cons_AV (vec A B) (vec A N)) with (cons_AV (vec A N') (vec A B)).
replace (plus (cons_AV (vec A B) (vec A M')) (cons_AV (vec A N') (vec A B)))
 with (plus (cons_AV (vec A N') (vec A B)) (cons_AV (vec A B) (vec A M'))).
rewrite Chasles; auto.
mesure A B A M'.
mesure A N' A B.
replace (x0 + x) with (x + x0); auto.
ring.
apply permute_angles; auto.
rewrite (axe_reflexion_bissectrice (A:=A) (B:=B) (M:=N) (M':=N')); auto.
rewrite Chasles; auto.
lapply (non_alignes_distincts (A:=A) (B:=B) (C:=N')); auto; intros.
apply non_axe_image_non_axe with N; auto.
apply non_alignes_distincts with B; auto.
lapply (non_alignes_distincts (A:=A) (B:=B) (C:=M')); auto; intros.
apply non_axe_image_non_axe with M; auto.
apply non_alignes_distincts with B; auto.
Qed.

Lemma reflexion_inverse_AMN :
 forall A B M M' N N' : PO,
 A <> B ->
 A <> M ->
 A <> N ->
 M' = reflexion A B M ->
 N' = reflexion A B N ->
 cons_AV (vec A M') (vec A N') = opp (cons_AV (vec A M) (vec A N)).
intros.
elim (classic (alignes A B M)); intros.
replace M' with M; auto.
elim (classic (alignes A B N)); intros.
replace N' with N; auto.
lapply (alignes_trans (A:=A) (B:=B) (C:=M) (D:=N)); auto; intros.
cut (double_AV (cons_AV (vec A M) (vec A N)) = image_angle 0); intros.
replace (opp (cons_AV (vec A M) (vec A N))) with
 (plus (image_angle 0) (opp (cons_AV (vec A M) (vec A N))));
 auto.
rewrite <- H7; unfold double_AV in |- *.
mesure A M A N.
replace (x + x + - x) with x; auto.
ring.
rewrite plus_commutative; auto with geo.
apply angle_alignes; auto.
rewrite H3; rewrite <- reflexion_axe; auto.
cut (A <> N'); intros.
lapply (axe_reflexion_droite (A:=A) (B:=B) (C:=M) (M:=N) (M':=N')); auto;
 intros.
rewrite <- (axe_reflexion_bissectrice (A:=A) (B:=M) (M:=N) (M':=N')); auto.
rewrite def_opp; auto.
lapply (alignes_non_alignes_trans (A:=A) (B:=B) (C:=N) (D:=M)); auto; intros.
lapply (axe_reflexion_droite (A:=M) (B:=A) (C:=A) (M:=N) (M':=N'));
 auto with geo; intros.
lapply (non_alignes_distincts (A:=A) (B:=B) (C:=N')); auto; intros.
apply non_axe_image_non_axe with N; auto.
rewrite H2; rewrite <- reflexion_axe; auto.
cut (A <> M'); intros.
elim (classic (alignes A B N)); intros.
replace N' with N; auto.
lapply (axe_reflexion_droite (A:=A) (B:=B) (C:=N) (M:=M) (M':=M')); auto;
 intros.
rewrite (axe_reflexion_bissectrice (A:=A) (B:=N) (M:=M) (M':=M')); auto.
rewrite def_opp; auto.
lapply (alignes_non_alignes_trans (A:=A) (B:=B) (C:=M) (D:=N)); auto; intros.
lapply (axe_reflexion_droite (A:=N) (B:=A) (C:=A) (M:=M) (M':=M'));
 auto with geo; intros.
rewrite H3; rewrite <- reflexion_axe; auto.
cut (A <> N'); intros.
replace (cons_AV (vec A M) (vec A N)) with
 (plus (cons_AV (vec A M) (vec A B)) (cons_AV (vec A B) (vec A N))).
rewrite (axe_reflexion_bissectrice (A:=A) (B:=B) (M:=M) (M':=M')); auto.
replace (cons_AV (vec A B) (vec A N)) with (cons_AV (vec A N') (vec A B)).
replace (plus (cons_AV (vec A B) (vec A M')) (cons_AV (vec A N') (vec A B)))
 with (plus (cons_AV (vec A N') (vec A B)) (cons_AV (vec A B) (vec A M'))).
rewrite Chasles; auto.
rewrite def_opp; auto.
mesure A B A M'.
mesure A N' A B.
replace (x0 + x) with (x + x0); auto.
ring.
apply permute_angles; auto.
rewrite (axe_reflexion_bissectrice (A:=A) (B:=B) (M:=N) (M':=N')); auto.
rewrite Chasles; auto.
lapply (non_alignes_distincts (A:=A) (B:=B) (C:=N')); auto; intros.
apply non_axe_image_non_axe with N; auto.
apply non_alignes_distincts with B; auto.
apply non_axe_image_non_axe with M; auto.
Qed.

Theorem reflexion_anti_deplacement :
 forall A B M M' N N' P P' : PO,
 A <> B ->
 M <> N ->
 M <> P ->
 N <> P ->
 M' = reflexion A B M ->
 N' = reflexion A B N ->
 P' = reflexion A B P ->
 cons_AV (vec M' N') (vec M' P') = opp (cons_AV (vec M N) (vec M P)).
intros.
cut (M' <> N'); intros.
cut (M' <> P'); intros.
discrimine M A.
cut (M' = A); intros.
rewrite H9.
cut (A <> N); intros.
cut (A <> P); intros.
apply reflexion_inverse_AMN with B; auto.
red in |- *; intros; apply H1.
rewrite H8; auto.
red in |- *; intros; apply H0.
rewrite H8; auto.
rewrite H3; rewrite H8; rewrite <- reflexion_axe; auto with geo.
discrimine N A.
cut (N' = A); intros.
rewrite H10.
cut (A <> P); intros.
elim
 cas_egalite_triangle_indirect
  with (A := A) (B := M) (C := P) (A' := A) (B' := M') (C' := P');
 (auto; intros).
elim H13; intros.
rewrite <- H14; rewrite def_opp; auto.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=M) (N':=M'));
 auto with geo.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=P) (N':=P'));
 auto with geo.
rewrite (reflexion_inverse_AMN (A:=A) (B:=B) (M:=P) (M':=P') (N:=M) (N':=M'));
 auto.
rewrite def_opp; auto.
red in |- *; intros; apply H2.
rewrite H9; auto.
rewrite H4; rewrite H9; rewrite <- reflexion_axe; auto with geo.
discrimine P A.
cut (P' = A); intros.
rewrite H11.
elim
 cas_egalite_triangle_indirect
  with (A := A) (B := M) (C := N) (A' := A) (B' := M') (C' := N');
 (auto; intros).
elim H13; intros.
rewrite H14; rewrite def_opp; auto.
red in |- *; intros; apply H7.
rewrite H16; auto.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=M) (N':=M'));
 auto with geo.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=N) (N':=N'));
 auto with geo.
rewrite (reflexion_inverse_AMN (A:=A) (B:=B) (M:=N) (M':=N') (N:=M) (N':=M'));
 auto.
rewrite def_opp; auto.
rewrite H5; rewrite H10; rewrite <- reflexion_axe; auto with geo.
cut (A <> M'); intros.
elim
 cas_egalite_triangle_indirect
  with (A := A) (B := M) (C := N) (A' := A) (B' := M') (C' := N');
 (auto; intros).
elim H13; intros.
elim
 cas_egalite_triangle_indirect
  with (A := A) (B := M) (C := P) (A' := A) (B' := M') (C' := P');
 (auto; intros).
elim H17; intros.
replace (cons_AV (vec M N) (vec M P)) with
 (plus (cons_AV (vec M N) (vec M A)) (cons_AV (vec M A) (vec M P))).
replace (cons_AV (vec M A) (vec M P)) with (cons_AV (vec M' P') (vec M' A)).
rewrite H14.
replace
 (plus (cons_AV (vec M' A) (vec M' N')) (cons_AV (vec M' P') (vec M' A)))
 with
 (plus (cons_AV (vec M' P') (vec M' A)) (cons_AV (vec M' A) (vec M' N'))).
rewrite Chasles; auto.
rewrite def_opp; auto.
mesure M' P' M' A.
mesure M' A M' N'.
replace (x + x0) with (x0 + x); auto.
ring.
apply permute_angles; auto.
rewrite Chasles; auto.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=M) (N':=M'));
 auto with geo.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=P) (N':=P'));
 auto with geo.
rewrite (reflexion_inverse_AMN (A:=A) (B:=B) (M:=P) (M':=P') (N:=M) (N':=M'));
 auto.
rewrite def_opp; auto.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=M) (N':=M'));
 auto with geo.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=N) (N':=N'));
 auto with geo.
rewrite (reflexion_inverse_AMN (A:=A) (B:=B) (M:=N) (M':=N') (N:=M) (N':=M'));
 auto.
rewrite def_opp; auto.
apply (isometrie_distinct (A:=A) (B:=M) (A':=A) (B':=M')); auto with geo.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=A) (M':=A) (N:=M) (N':=M'));
 auto with geo.
apply (isometrie_distinct (A:=M) (B:=P) (A':=M') (B':=P')); auto.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=M) (M':=M') (N:=P) (N':=P'));
 auto.
apply (isometrie_distinct (A:=M) (B:=N) (A':=M') (B':=N')); auto.
rewrite (reflexion_isometrie (A:=A) (B:=B) (M:=M) (M':=M') (N:=N) (N':=N'));
 auto.
Qed.

Lemma mediatrices_reflexion :
 forall A B M M' : PO,
 M <> M' ->
 ~ alignes A B M ->
 mediatrice M M' A -> mediatrice M M' B -> M' = reflexion A B M.
intros A B M M' H0 H1 H2 H3; try assumption.
cut (A <> B); intros H; [ idtac | auto with geo ].
soit_milieu M M' ipattern:(K).
apply reflexion_def2 with K; auto with geo.
apply def_projete_orthogonal; auto.
discrimine K A.
apply alignes_ordre_cycle; auto.
apply mediatrice_droite with (2 := H4); auto.
cut (orthogonal (vec M M') (vec A B)); intros.
apply ortho_sym.
replace (vec K M) with (mult_PP (-1) (vec M K)).
rewrite (milieu_vecteur2 (A:=M) (B:=M') (M:=K)); auto.
replace (mult_PP (-1) (mult_PP (/ 2) (vec M M'))) with
 (mult_PP (- / 2) (vec M M')).
Simplortho.
cut (2 <> 0); intros; auto with real.
Fieldvec 2.
Ringvec.
apply ortho_sym.
apply mediatrice_orthogonale_segment; auto.
Qed.

Lemma existence_reflexion_AB :
 forall A B M : PO, A <> B -> exists M' : PO, M' = reflexion A B M.
intros A B M H1; try assumption.
elim existence_projete_orthogonal with (A := A) (B := B) (C := M);
 [ intros H H4; try clear existence_projete_orthogonal; try exact H3 | auto ].
elim existence_representant_vecteur with (A := H) (B := M) (C := H);
 intros M' H3; try clear existence_representant_vecteur;
 try exact H3.
exists M'.
apply reflexion_def2 with H; auto.
replace (vec M M') with (add_PP (vec M H) (vec H M')).
rewrite H3; Ringvec.
Ringvec.
Qed.


Require Import VST.floyd.proofauto.
Require Import VST.progs.floyd_tests.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition test_sizeof_spec :=
 DECLARE _test_sizeof
  WITH p: val, sh : share, i: Z
  PRE [ tptr tint ]
          PROP  (readable_share sh; 0 <= i <= Int.max_signed)
          PARAMS (p) SEP (data_at sh tint (Vint (Int.repr i)) p)
  POST [ tint ]
        PROP () RETURN (Vint (Int.repr 9)) SEP (data_at sh tint (Vint (Int.repr i)) p).

Definition Gprog : funspecs :=
        ltac:(with_library prog [test_sizeof_spec]).

Lemma body_test_sizeof_spec: semax_body Vprog Gprog f_test_sizeof test_sizeof_spec.
Proof.
start_function.
forward.
forward.
forward.
Qed.


Require Import Kami.Kami.

Set Implicit Arguments.
Set Asymmetric Patterns.

(** Welcome to the Kami tutorial!  This tutorial gives a demo of implementing and verifying very simple producer-consumer components. *)

(** Kami has its own syntax, which is very similar to Bluespec.  Syntax is built with "Notation" in Coq, so module definitions are automatically type-checked internally by the Gallina type-checker. *)

(** Let's design a producer module first.  A module consists of registers, rules, and methods.  A rule or a method is defined as a sequence of actions.  Semantically, rules are executed by a global rule scheduler. Methods are executed by method calls, which can be called by other modules once they are composed. *)

(** Producer has a data register and a rule to send the data to Consumer. *)
Definition producer :=
  MODULE {
    Register "data" : Bit 32 (* type *) <- Default (* initial value *)

    with Rule "produce" :=
      Read data <- "data";
        (* Explicit actions are required to read values of registers into local variables. *)
      Call (MethodSig "send" (Bit 32 (* parameter type *)): Void (* return type*)) (#data) (* using [#] to read from variables *);
        (* Note embedding of a type assumption for the function being called, not just its name. *)
      Write "data" <- #data + $1 (* using [$] for a literal expression *);
      Retv
  }.

(** For proof automation, it is recommended to register module definitions to "ModuleDefs". *)
#[global] Hint Unfold producer : ModuleDefs.

(** Consumer only has one method, which takes the data sent by Producer and calls an external function with the data. *)
Definition consumer :=
  MODULE {
    Method "send" (data: Bit 32): Void :=
      Call (MethodSig "extCall" (Bit 32): Void) (#data);
      Retv
  }.
#[global] Hint Unfold consumer : ModuleDefs.

(** Now we compose Producer and Consumer to make the complete implementation. *)
Definition producerConsumerImpl := (producer ++ consumer)%kami.
#[global] Hint Unfold producerConsumerImpl : ModuleDefs.

(** What is a specification of the Producer-Consumer module?  We define specifications also as modules in Kami.  A specification is usually defined as a single module.  In this case, we define the specification simply by calling the external call with the current data and update it as Producer does. *)
Definition producerConsumerSpec :=
  MODULE {
    Register "data" : Bit 32 <- Default

    with Rule "produce_consume" :=
      Read data <- "data";
      Call (MethodSig "extCall" (Bit 32): Void) (#data);
      Write "data" <- #data + $1;
      Retv
  }.

(** Inlining and Decomposition are mostly used to prove refinement between [impl] and [spec].  Inlining collapses all internal method calls in [impl], which enables us only to consider external calls.  Decomposition allows us to relate each fine-grained state transition (by a rule or a method) in [impl] to one in [spec]. *)

(** In order to use the decomposition theorem, we have to define two maps, one for rules and the other for internal states.  See "src/Notations.v" for detailed notations for mapping. *)
Definition producer_consumer_ruleMap (_: RegsT): string -> option string :=
  "produce" |-> "produce_consume"; ||.
Definition producer_consumer_regMap (r: RegsT): RegsT.
  (* We are using tactics to build a map from register valuations in [impl] to register valuations in [spec]. *)
  kgetv "data"%string datav r (Bit 32) (M.empty _: RegsT).
  (* First, extract the value of [impl] register ["data"]. *)
  exact (M.add "data"%string (existT _ _ datav) (M.empty _)).
  (* Then, give the corresponding values of all registers for [spec]. *)
Defined.
#[global] Hint Unfold producer_consumer_regMap: MethDefs. (* for kdecompose_regMap_init *)

(** The Kami syntax is built by PHOAS, so sometimes we need to prove a PHOAS equivalence for any two variable mappings.  Adding the equivalence lemma to the Coq hint database will allow related features to use it automatically. *)
Lemma impl_ModEquiv:
  ModPhoasWf producerConsumerImpl.
Proof. kequiv. Qed.
#[global] Hint Resolve impl_ModEquiv.

(** Now we are ready to prove the refinement! *)
Theorem producer_consumer_refinement:
  producerConsumerImpl <<== producerConsumerSpec.
Proof.
  kinline_left implInlined.
  (* Inlining: replace internal function calls in [impl]. *)
  kdecompose_nodefs producer_consumer_regMap producer_consumer_ruleMap.
  (* Decomposition: consider all steps [impl] could take, requiring that each be matched appropriately in [spec]. *)

  kinvert.
  (* Inversion on the took-a-step hypothesis, to produce one new subgoal per [impl] rule, etc. *)
  kinv_magic_light.
  (* We have only one case for this example (for the one rule), and it's easy. *)
Qed.

(** We can also build refinement proofs by the one-line tactic with a proof configuration. *)
Definition producer_consumer_refinement_config :=
  {| inlining := ITManual;
     decomposition := DTFunctional producer_consumer_regMap producer_consumer_ruleMap;
     invariants := IVNil
  |}.

(** Here is the shortest proof of the refinement. *)
Theorem producer_consumer_refinement_again:
  producerConsumerImpl <<== producerConsumerSpec.
Proof.
  kami_ok producer_consumer_refinement_config idtac idtac.
Qed.


Require Export Cat Pseudofunctor.Core.
Require Import Common NaturalTransformation.Isomorphisms.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope morphism_scope.

(** Every functor to Cat is a pseudofunctor *)
Section of_functor.
  Context `{Funext}.
  Variable C : PreCategory.
  Context `{HP : forall C D, P C -> P D -> IsHSet (Functor C D)}.

  Let Cat := SubPreCat P.

  Variable F : Functor C Cat.

  Definition functor_eq_helper A B (F1 F2 : Functor A B) (pf1 pf2 : F1 = F2)
  : P A -> P B -> pf1 = pf2
    := fun _ _ => allpath_hprop _ _.

  Local Hint Extern 0 (P ?x.1) => exact x.2.

  Local Tactic Notation "transitivity_idtoiso" open_constr(hyp) :=
    lazymatch goal with
      | [ |- ?f (idtoiso ?C _) = _ ] => etransitivity (f (idtoiso C hyp));
                                       [ do 2 apply ap;
                                         apply functor_eq_helper;
                                         unfold SubPreCatCat; simpl; trivial
                                       | nt_eq ]
    end.

  Local Ltac pseudofunctor_t :=
    intros;
    unfold NaturalIsomorphismNT;
    rewrite ?idtoiso_NTWhiskerR, ?idtoiso_NTWhiskerL;
    repeat (
        let C := match goal with |- @paths (@NaturalTransformation ?C ?D ?F ?G) _ _ => constr:([C, D]%category) end in
        first [ eapply (@iso_moveL_pV C)
              | eapply (@iso_moveL_Vp C)
              | eapply (@iso_moveL_pM C)
              | eapply (@iso_moveL_Mp C) ];
        simpl
      );
    rewrite ?idtoiso_inv;
    simpl;
    change @NTComposeT with (fun C D F G H => @Compose [C, D] F G H);
    cbv beta;
    rewrite ?idtoiso_comp;
    first [ transitivity_idtoiso (LeftIdentityFunctor _)
          | transitivity_idtoiso (inverse (LeftIdentityFunctor _))
          | transitivity_idtoiso (RightIdentityFunctor _)
          | transitivity_idtoiso (inverse (RightIdentityFunctor _))
          | transitivity_idtoiso (ComposeFunctorsAssociativity _ _ _)
          | transitivity_idtoiso (inverse (ComposeFunctorsAssociativity _ _ _)) ];
    rewrite eta_idtoiso_FunctorCategory;
    simpl;
    rewrite ?ap_V, ?LeftIdentityFunctor_fst, ?RightIdentityFunctor_fst, ?ComposeFunctorsAssociativity_fst;
    try reflexivity.

  (* The following helpers were generated with
<<
intros.
    repeat match goal with
             | [ |- appcontext[idtoiso ?C (?f ?x)] ] => generalize (f x); intro
             | [ |- appcontext[MorphismOf ?F ?f] ] => generalize dependent (MorphismOf F f); repeat (let x := fresh "x" in intro x)
             | [ |- appcontext[ObjectOf ?F ?f] ] => generalize dependent (ObjectOf F f); repeat (let x := fresh "x" in intro x)
           end.
    simpl in *.
    unfold SubPreCatCat.
    simpl in *.
    clear.
    destruct_head_hnf @sigT.
    simpl in *.
    repeat match goal with
             | [ H : _ |- _ ] => revert H
           end.
    intros H P.
>> *)

  Lemma PseudofunctorOfFunctor_FCompositionOf
        {x0 x1 x2 x : PreCategory}
        {x7 x11 : Functor x0 x1}
        {x12 : x7 = x11}
        {x6 : Functor x0 x2} {x9 : Functor x2 x1}
        {x14 : x11 = (x9 ∘ x6)%functor}
        {x4 : Functor x0 x} {x5 : Functor x x1}
        {x8 : x7 = (x5 ∘ x4)%functor} {x10 : Functor x x2}
        {x13 : x6 = (x10 ∘ x4)%functor} {x15 : x5 = (x9 ∘ x10)%functor}
        (H0' : P x0) (H1' : P x1) (H2' : P x2) (H' : P x)
  : (ComposeFunctorsAssociator1 x9 x10 x4 ∘ (idtoiso [x, x1] x15 ∘ x4 ∘ idtoiso [x0, x1] x8))%natural_transformation =
    (x9 ∘ idtoiso [x0, x2] x13 ∘ (idtoiso [x0, x1] x14 ∘ idtoiso [x0, x1] x12))%natural_transformation.
  Proof.
    subst_body.
    clear HP F.
    abstract (apply symmetry; simpl; pseudofunctor_t).
  Qed.

  Lemma PseudofunctorOfFunctor_LeftIdentityOf
        {x0 x : PreCategory}
        {x2 : Functor x x} {x3 : x2 = 1%functor}
        {x4 x5 : Functor x0 x} {x6 : x4 = x5} {x7 : x4 = (x2 ∘ x5)%functor}
        (H0' : P x0) (H' : P x)
  : (idtoiso [x, x] x3 ∘ x5 ∘ idtoiso [x0, x] x7)%natural_transformation =
    (LeftIdentityFunctorNaturalTransformation2 x5 ∘ idtoiso [x0, x] x6)%natural_transformation.
  Proof.
    subst_body.
    clear HP F.
    abstract (simpl; pseudofunctor_t).
  Qed.

  Lemma PseudofunctorOfFunctor_RightIdentityOf
        {x0 x : PreCategory}
        {x4 : Functor x0 x0} {x5 : x4 = 1%functor}
        {x2 x3 : Functor x0 x} {x6 : x2 = x3} {x7 : x2 = (x3 ∘ x4)%functor}
        (H0' : P x0) (H' : P x)
  : (x3 ∘ idtoiso [x0, x0] x5 ∘ idtoiso [x0, x] x7)%natural_transformation =
    (RightIdentityFunctorNaturalTransformation2 x3 ∘ idtoiso [x0, x] x6)%natural_transformation.
  Proof.
    subst_body.
    clear HP F.
    abstract (simpl; pseudofunctor_t).
  Qed.

  Definition PseudofunctorOfFunctor : Pseudofunctor C
    := Build_Pseudofunctor
         C
         (fun x => projT1 (F x))
         (fun s d m => MorphismOf F m)
         (fun s d d' m0 m1 => idtoiso [_, _] (FCompositionOf F _ _ _ m1 m0))
         (fun x => idtoiso [_, _] (FIdentityOf F x))
         (fun w x y z _ _ _ => PseudofunctorOfFunctor_FCompositionOf (F w).2 (F z).2 (F y).2 (F x).2)
         (fun x y _ => PseudofunctorOfFunctor_LeftIdentityOf (F x).2 (F y).2)
         (fun x y _ => PseudofunctorOfFunctor_RightIdentityOf (F x).2 (F y).2).
End of_functor.

Definition FunctorToCat `{Funext} {C} `{forall C D, P C -> P D -> IsHSet (Functor C D)}
  := Functor C (SubPreCat P).
Identity Coercion FunctorToCat_id : FunctorToCat >-> Functor.
Definition PseudofunctorOfFunctorToCat `(F : @FunctorToCat H C P HP)
  := @PseudofunctorOfFunctor _ C P HP F.

Coercion PseudofunctorOfFunctorToCat : FunctorToCat >-> Pseudofunctor.


Require Export Iron.DiscipleKernel.Ki.

(* Type Constructors. *)
Inductive tycon : Type :=
  | TyConImpl    : tycon
  | TyConFun     : tycon

  (* Witness Types *)
  | TyConConst   : tycon
  | TyConMutable : tycon
  | TyConPure    : tycon
  | TyConEmpty   : tycon

  (* Effect Types *)
  | TyConRead    : tycon
  | TyConWrite   : tycon
  | TyConAlloc   : tycon

  (* Closure Types *)
  | TyConUse     : tycon

  (* Value Types *)
  | TyConBool    : tycon
  | TyConNat     : tycon
  | TyConArray   : tycon
  | TyConData    : nat   -> ki -> tycon.
Hint Constructors tycon.

Fixpoint tycon_beq t1 t2 :=
  match t1, t2 with
  | TyConImpl,      TyConImpl      => true
  | TyConFun,       TyConFun       => true
  | TyConConst,     TyConConst     => true
  | TyConMutable,   TyConMutable   => true
  | TyConPure,      TyConPure      => true
  | TyConEmpty,     TyConEmpty     => true
  | TyConRead,      TyConRead      => true
  | TyConWrite,     TyConWrite     => true
  | TyConAlloc,     TyConAlloc     => true
  | TyConUse,       TyConUse       => true
  | TyConBool,      TyConBool      => true
  | TyConNat,       TyConNat       => true
  | TyConArray,     TyConArray     => true
  | TyConData n1 _, TyConData n2 _ => beq_nat n1 n2
  | _,              _              => false
  end.

Definition isTyConFun  (tc: tycon) : Prop :=
  match tc with
  | TyConFun      => True
  | _             => False
  end.
Hint Unfold isTyConFun.

Definition isTyConData (tc: tycon) : Prop :=
  match tc with
  | TyConData _ _ => True
  | _             => False
  end.
Hint Unfold isTyConData.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(*******************************
 * Operators typed equivalence *
 *******************************)

Require Import Equivalence.
Require Import Morphisms.
Require Import Setoid.
Require Import EquivDec.
Require Import Program.
Require Import List.
Require Import String.
Require Import Utils.
Require Import Types.
Require Import DataModel.
Require Import ForeignData.
Require Import ForeignOperators.
Require Import ForeignDataTyping.
Require Import ForeignOperatorsTyping.
Require Import Operators.
Require Import TData.
Require Import TUnaryOperators.
Require Import TBinaryOperators.

Section TOperatorsEq.
  (* Two well-typed operators are type equivalent iff they return the
     same value for every well-typed input.
   *)
  Context {fdata:foreign_data}.
  Context {foperators:foreign_operators}.
  Context {ftype:foreign_type}.
  Context {fdtyping:foreign_data_typing}.
  Context {m:brand_model}.
  Context {foptyping:foreign_operators_typing}.

  Definition typed_unary_op τin τout := {u:unary_op|unary_op_type u τin τout}.

  Definition tunary_op_eq {τin τout} (uop1 uop2:typed_unary_op τin τout) : Prop :=
    forall (x:data),
      data_type x τin ->
      (unary_op_eval brand_relation_brands (`uop1)) x
      = (unary_op_eval brand_relation_brands (`uop2)) x.

  Global Instance tunary_op_equiv {τin τout} : Equivalence (@tunary_op_eq τin τout).
  Proof.
    constructor.
    - unfold Reflexive, tunary_op_eq.
      intros; reflexivity.
    - unfold Symmetric, tunary_op_eq.
      intros; rewrite (H x0); [reflexivity|assumption].
    - unfold Transitive, tunary_op_eq.
      intros;
        rewrite (H x0); try assumption;
        rewrite (H0 x0); [reflexivity|assumption].
  Qed.

  Definition tunary_op_rewrites_to (u1 u2:unary_op) :=
    forall τ₁ τ₂,
    unary_op_type u1 τ₁ τ₂ ->
    unary_op_type u2 τ₁ τ₂ /\
    (forall (x:data),
        data_type x τ₁ ->
        (unary_op_eval brand_relation_brands u1) x
        = (unary_op_eval brand_relation_brands u2) x).

  Global Instance tunary_op_rewrites_to_pre : PreOrder tunary_op_rewrites_to.
  Proof.
    unfold tunary_op_rewrites_to.
    constructor; red.
    - intuition.
    - intros x y z Hx Hy; intros ? ? typx.
      specialize (Hx _ _ typx).
      destruct Hx as [typy Hx].
      specialize (Hy _ _ typy).
      destruct Hy as [typz Hy].
      split; trivial; intros.
      rewrite Hx, Hy; trivial.
  Qed.

  Definition typed_binary_op τ₁ τ₂ τout := {b:binary_op|binary_op_type b τ₁ τ₂ τout}.

  Definition tbinary_op_eq {τ₁ τ₂ τout} (bop1 bop2:typed_binary_op τ₁ τ₂ τout) : Prop :=
    forall (x1 x2:data),
      data_type x1 τ₁ -> data_type x2 τ₂ ->
      (binary_op_eval brand_relation_brands (`bop1)) x1 x2
      = (binary_op_eval brand_relation_brands (`bop2)) x1 x2.

  Global Instance tbinary_op_equiv {τ₁ τ₂ τout} : Equivalence (@tbinary_op_eq τ₁ τ₂ τout).
  Proof.
    constructor.
    - unfold Reflexive, tbinary_op_eq.
      intros; reflexivity.
    - unfold Symmetric, tbinary_op_eq.
      intros; rewrite (H x1 x2); try assumption; reflexivity.
    - unfold Transitive, tbinary_op_eq.
      intros;
        rewrite (H x1 x2); try assumption;
          rewrite (H0 x1 x2); try assumption; reflexivity.
  Qed.

  Definition tbinary_op_rewrites_to (b1 b2:binary_op) :=
    forall τ₁ τ₂ τ₃,
    binary_op_type b1 τ₁ τ₂ τ₃ ->
    binary_op_type b2 τ₁ τ₂ τ₃ /\
    (forall (x1 x2:data),
        data_type x1 τ₁ ->
        data_type x2 τ₂ ->
        (binary_op_eval brand_relation_brands b1) x1 x2
        = (binary_op_eval brand_relation_brands b2) x1 x2).

  Global Instance tbinary_op_rewrites_to_pre : PreOrder tbinary_op_rewrites_to.
  Proof.
    unfold tbinary_op_rewrites_to.
    constructor; red.
    - intuition.
    - intros x y z Hx Hy; intros ? ? ? typx.
      specialize (Hx _ _ _ typx).
      destruct Hx as [typy Hx].
      specialize (Hy _ _ _ typy).
      destruct Hy as [typz Hy].
      split; trivial; intros.
      rewrite Hx, Hy; trivial.
  Qed.

End TOperatorsEq.


Require Import FcEtt.sigs.

Require Import FcEtt.imports.
Require Import FcEtt.tactics.
Require Import FcEtt.fset_facts.

Require Import FcEtt.ett_ott.
Require Import FcEtt.ett_inf.
Require Import FcEtt.ett_inf_cs.
Require Import FcEtt.ett_ind.

Require Import FcEtt.erase_syntax.
Require Export Metalib.CoqEqDec.
Require Import Coq.Logic.Decidable.
Require Import Metalib.Metatheory.
Require Import FcEtt.fc_unique.

Require Import FcEtt.fc_wf.
Require Import FcEtt.toplevel.
Require Import FcEtt.fc_context_fv.

Module fc_invert (wf : fc_wf_sig) (weak : fc_weak_sig) (subst : fc_subst_sig).
Import weak subst.

Module unique := fc_unique wf subst.
Import unique.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

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

Lemma AnnTyping_regularity :
  (forall G a A, AnnTyping G a A -> AnnTyping G A a_Star).
Proof.
  induction 1; eauto with ctx_wff.
  - eapply binds_to_AnnTyping; eauto.
  - inversion IHAnnTyping1. eapply AnnTyping_tm_subst_nondep; eauto.
  - inversion IHAnnTyping. eapply AnnTyping_co_subst_nondep; eauto.
  - eapply AnnTyping_weakening with (F:=nil)(G:=nil) in H1.
    simpl_env in H1.
    eauto.
    auto.
    simpl_env.
    auto.
Qed.

Lemma AnnPropWff_regularity :
  forall G A B A1, AnnPropWff G (Eq A B A1) -> exists B1 g,
      AnnTyping G A A1 /\ AnnTyping G B B1 /\ AnnDefEq G empty g A1 B1.
Proof.
  intros G A B A1 H.
  inversion H. subst.
  pose K := AnnTyping_regularity H4.
  pose L := AnnTyping_regularity H5.
  pose M := AnnTyping_regularity K.
  pose N := AnnTyping_regularity M.
  pose g := g_Refl2 A1 B0 (g_Refl a_Star).
  assert (DE : AnnDefEq G empty g A1 B0). eapply An_EraseEq; eauto.
  exists B0. eexists. eauto.
Qed.

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

(*  Interlude: some lemmas about how erasure and typing interact. *)

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

Lemma erase_pi : forall G AB0 rho A B S, erase AB0 = (a_Pi rho A B) -> AnnTyping G AB0 S ->
  exists A1 B0, erase AB0 = erase (a_Pi rho A1 B0) /\ erase A1 = A /\ erase B0 = B /\ AnnTyping G (a_Pi rho A1 B0) a_Star.
Proof.
  induction AB0; intros rho' A B S H; try solve [try destruct rho; simpl in H; inversion H].
  - simpl in H; inversion H.
    intros. exists AB0_1. exists AB0_2.
    repeat split. inversion H0. subst. auto.
  - simpl in H; inversion H.
    intros H0.  inversion H0. destruct (IHAB0 rho' A B A0 H) as [A2 [B2 [E1 [E2 [E3 AT]]]]]; auto.
    subst.
    exists A2. exists B2. simpl in *. subst. repeat split. auto.
    auto.
Qed.

Lemma erase_cpi : forall AB0 A B G S,
    erase AB0 = (a_CPi A B) -> AnnTyping G AB0 S ->
    exists A1 B0, erase AB0 = erase (a_CPi A1 B0) /\ erase_constraint A1 = A /\ erase B0 = B
             /\ AnnTyping G (a_CPi A1 B0) a_Star.
Proof.
  induction AB0; intros A B G S H; try destruct rho; simpl in H; inversion H.
  - intros J.
    inversion J. subst.
    destruct (IHAB0 A B G A0 H) as [A1 [B0 [E1 [E2 E3]]]]; auto.
    subst.
    exists A1. exists B0. simpl. subst. auto.
  - exists phi. exists AB0. inversion H0. subst.  auto.
Qed.

Lemma erase_app_Rel :
  forall AB0 A B C G, erase AB0 = (a_App A Rel B) -> AnnTyping G AB0 C ->
  exists A1 B0 g D, erase AB0 = erase (a_App A1 Rel B0) /\ erase A1 = A /\ erase B0 = B /\
          AnnTyping G (a_App A1 Rel B0) D /\ AnnDefEq G (dom G) g C D.
Proof.
  induction AB0;
    move=> A B C G H; try destruct rho;
            simpl in H;

    inversion H;
    eauto.
  - intros T.
    pose K := AnnTyping_regularity T.
    eexists. eexists. eexists. eexists.
    repeat split. eauto.  eauto.
  - intros T.
    inversion T. subst.
    destruct (IHAB0 _ _ _ _ H H3) as [A1 [B0 [g1 [D [E1 [E2 [E3 [T1 DE]]]]]]]].
    simpl in E1. inversion E1. subst.
    pose K := AnnTyping_regularity T. clearbody K.
    pose K2 := AnnTyping_regularity T1. clearbody K2.
    pose K3 := AnnTyping_regularity H3. clearbody K3.
    assert (AnnCtx G). eauto using AnnTyping_AnnCtx.
    exists A1, B0. eexists. exists D.
    repeat split. simpl. eauto. eauto.
    eapply An_Trans with (a1 := A0).
    eapply An_Sym; eauto. eauto. eauto. eauto.
    eapply An_Refl. eauto.
Qed.

Lemma erase_app_Irrel :
  forall AB0 A C G, erase AB0 = (a_App A Irrel a_Bullet) -> AnnTyping G AB0 C ->
  exists A1 B0 g D, erase AB0 = erase (a_App A1 Irrel B0) /\ erase A1 = A /\
          AnnTyping G (a_App A1 Irrel B0) D /\ AnnDefEq G (dom G) g C D.
Proof.
  induction AB0;
    move=> A C G H; try destruct rho;
            simpl in H;
    inversion H;
    eauto.
  - intros T.
    pose K := AnnTyping_regularity T.
    eexists. eexists. eexists. eexists.
    repeat split. eauto.  eauto.
  - intros T.
    inversion T. subst.
    destruct (IHAB0 _ _ _  H H3) as [A1 [B0 [g1 [D [E1 [E3 [T1 DE]]]]]]].
    simpl in E1. inversion E1. subst.
    pose K := AnnTyping_regularity T. clearbody K.
    pose K2 := AnnTyping_regularity T1. clearbody K2.
    pose K3 := AnnTyping_regularity H3. clearbody K3.
    assert (AnnCtx G). eauto using AnnTyping_AnnCtx.
    exists A1, B0. eexists. exists D.
    repeat split. simpl. eauto. eauto.
    eapply An_Trans with (a1 := A0).
    eapply An_Sym; eauto. eauto. eauto. eauto.
    eapply An_Refl. eauto.
Qed.

(*
Lemma erase_abs : forall AB0 rho B, erase AB0 = (a_UAbs rho B) ->
  exists A1 B0, erase AB0 = erase (a_Abs rho A1 B0) /\ erase B0 = B.
Proof.
  induction AB0;
    move=> rho' B H;
            try destruct rho;
    simpl in H;
    inversion H;
    eauto.
Qed.
*)
(*
Lemma erase_capp :
  forall AB0 A C G, erase AB0 = (a_CApp A g_Triv) -> AnnTyping G AB0 C ->
  exists A1 g0 g D, erase AB0 = erase (a_CApp A1 g0) /\ erase A1 = A /\
          AnnTyping G (a_CApp A1 g0) D /\ AnnDefEq G (dom G) g C D.
Proof.
  induction AB0;
    move=> A C G H;
    simpl in H;
    inversion H;
    eauto.
  - intros T.
    inversion T. subst.
    destruct (IHAB0 _  _ _ H H3) as [A1 [g0 [g1 [D [E1 [E3 [T1 DE]]]]]]].
    simpl in E1. inversion E1. subst.
    pose K := AnnTyping_regularity T. clearbody K.
    pose K2 := AnnTyping_regularity T1. clearbody K2.
    pose K3 := AnnTyping_regularity H3. clearbody K3.
    assert (AnnCtx G). eauto.
    exists A1, g0. eexists. eexists.
    repeat split. simpl. eauto. eauto. eapply An_Trans with (a1 := A0).
    eapply An_Sym; eauto. eauto. eauto. eauto.
    eapply An_Refl. eauto.
   -  intros T.
    pose K := AnnTyping_regularity T.
    eexists. eexists. eexists. eexists.
    repeat split. eauto.  eauto.
Qed.
*)

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

Lemma erasure_compatible : forall G a A (H1 :AnnTyping G a A),
    forall b B (H2 : AnnTyping G b B)
      (E : erase a = erase b)
      (F : erase A = erase B),
    exists g1, AnnDefEq G (dom G) g1 a b.
Proof.
  intros.
  pose K1 := AnnTyping_regularity H1.
  pose K2 := AnnTyping_regularity H2.
  eexists.
  eapply An_EraseEq.
  eauto. eauto. eauto.
  eapply An_EraseEq; eauto using AnnTyping_AnnCtx.
Qed.

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

(*
    Challenging lemma: coercible terms have coercible types.

     NOTE: this result for AnnDefEq is *not* AnnPropWff G (Eq A B).

 *)
Lemma AnnDefEqAnnIso_regularity :
  (forall G0 a A, AnnTyping G0 a A -> True ) /\
  (forall G0 phi,   AnnPropWff G0 phi -> True ) /\
  (forall G D g p1 p2, AnnIso G D g p1 p2 ->
                 AnnPropWff G p1 /\ AnnPropWff G p2) /\
  (forall G D g A B,   AnnDefEq G D g A B ->
           exists C1 C2 g', AnnTyping G A C1 /\ AnnTyping G B C2 /\ AnnDefEq G (dom G) g' C1 C2) /\
  (forall G0, AnnCtx G0 -> True).
Proof.
  apply ann_typing_wff_iso_defeq_mutual; eauto.
  { intros.
  destruct H as [C1 [C2 [g' [AT1 [AT2 DE]]]]].
  inversion AT1. inversion AT2. subst. split; auto. }
  all: intros.
  - destruct H. eauto.
  - pose K:= binds_to_AnnPropWff _ _ _ _ a0 b0.
    destruct (AnnPropWff_regularity K) as [B1 [g [TA [TB DE]]]].
    exists A, B1, g. split. auto. split. auto. eapply AnnDefEq_weaken_available. eauto.
  - exists A, A, (g_Refl A).
    pose N := AnnTyping_regularity a0.
    eauto.
  - pose N1 := AnnTyping_regularity a0.
    pose N2 := AnnTyping_regularity a1.
    exists A, B. eexists.
    repeat split.
    eauto. eauto. eauto.
  - exists A, B, (g_Sym g1).
    pose K1 := AnnTyping_regularity a0.
    pose K2 := AnnTyping_regularity a1.
    split. auto. split. auto.
    eapply An_Sym. eauto. eauto. eapply An_Refl. eapply An_Star.
    eauto using AnnTyping_AnnCtx.
    eapply AnnDefEq_weaken_available.
    eauto.
  - destruct H as [C1 [D1 [g1' [TbC1 [TaD1 EQ1]]]]]; auto.
    destruct H0 as [C2 [D2 [g2' [TbC2 [TaD2 EQ2]]]]]; auto.
    assert (D1 = C2). eapply AnnTyping_unique; eauto.
    subst.
    exists C1, D2. eexists.
    repeat split. auto. auto.
    eapply An_Trans. eauto. eauto.
    eapply AnnTyping_regularity. eauto.
    eapply AnnTyping_regularity. eauto.
    eapply An_Refl. eapply An_Star. eauto with ctx_wff.
  - exists B0, B1. eexists.
    pose N1 := AnnTyping_regularity a.
    pose N2 := AnnTyping_regularity a0.
    repeat split.
    eauto. eauto.
    eapply An_EraseEq; eauto with ctx_wff.
  - exists a_Star, a_Star. eexists.
    assert (HG : AnnCtx G); eauto with ctx_wff.
  - (* abs cong *)
    clear H1. clear H2. clear H3.

    assert (ANG : AnnCtx G). eauto with ctx_wff.
    pick fresh x1. assert (FR1 : x1 `notin` L). eauto.
    destruct (H0 x1 FR1) as [B1 [B2 [g' [Tb1 [Tb2 EqB1B2]]]]]. clear H0.
    assert (FRB1 : x1 `notin` fv_tm_tm_tm (close_tm_wrt_tm x1 B1)).
    autorewrite with lngen; eauto.
    assert (R1 : AnnTyping G (a_Abs rho A1 b1) (a_Pi rho A1 (close_tm_wrt_tm x1 B1))).
    { eapply (An_Abs_exists); eauto.
      rewrite open_tm_wrt_tm_close_tm_wrt_tm. eauto. }
    pick fresh x2. assert (FR2 : x2 `notin` L). eauto.
    pose N1 := (e x2 FR2). clearbody N1. clear e.
    assert (HSG : AnnDefEq G D (g_Sym g1) A2 A1). {
      assert (AnnDefEq G D (g_Refl a_Star) a_Star a_Star). eauto with ctx_wff.
      eapply An_Sym; eauto with ctx_wff.
      }
    remember (tm_subst_tm_tm (a_Conv (a_Var_f x2) (g_Sym g1)) x1 B2) as B3.
    assert (EQB : open_tm_wrt_tm (close_tm_wrt_tm x2 B3) (a_Var_f x2) =
                  open_tm_wrt_tm (close_tm_wrt_tm x1 B2) (a_Conv (a_Var_f x2) (g_Sym g1))).
    { rewrite HeqB3.
      rewrite (tm_subst_tm_tm_intro x1 (close_tm_wrt_tm x1 B2) (a_Conv (a_Var_f x2) (g_Sym g1))).
      rewrite (open_tm_wrt_tm_close_tm_wrt_tm B2 x1).
      rewrite (open_tm_wrt_tm_close_tm_wrt_tm).
      auto.
      autorewrite with lngen; auto.
    }
    assert (x2 `notin` fv_tm_tm_tm (close_tm_wrt_tm x2 B3)). {
      autorewrite with lngen; auto. }
    assert (R2 : AnnTyping G (a_Abs rho A2 b3) (a_Pi rho A2 (close_tm_wrt_tm x2 B3))).
    { eapply An_Abs_exists with (x := x2). eauto. eauto.
      rewrite N1.
      rewrite EQB.
      rewrite (tm_subst_tm_tm_intro x1); auto.
      rewrite (tm_subst_tm_tm_intro x1 (close_tm_wrt_tm x1 B2)).
      eapply (@AnnTyping_tm_subst ([(x2, Tm A2)] ++ G) x1 A1).
      rewrite open_tm_wrt_tm_close_tm_wrt_tm.
      eapply AnnTyping_weakening; eauto.
      eapply An_ConsTm; eauto with ctx_wff.
      eapply (AnnTyping_weakening a1 _ nil); simpl; eauto.
      eapply An_ConsTm; eauto with ctx_wff.
      eapply An_Conv. eauto.
      eapply AnnDefEq_weaken_available.
      eapply (AnnDefEq_weakening HSG _ nil); simpl; eauto.
      eapply An_ConsTm; eauto.
      eapply (AnnTyping_weakening a1 _ nil); simpl; eauto.
      eapply An_ConsTm; eauto.
      autorewrite with lngen. auto.
      move: (r0 x2 FR2) => r2'. auto.
    }
    exists (a_Pi rho A1 (close_tm_wrt_tm x1 B1)), (a_Pi rho A2 (close_tm_wrt_tm x2 B3)).
    exists (g_PiCong rho g1 (close_co_wrt_tm x1 g') ).
    repeat split. auto. auto.
    eapply An_PiCong_exists with (x1:=x1)(x2:=x2)(B2 := close_tm_wrt_tm x1 B2).
    autorewrite with lngen. auto.
    autorewrite with lngen. auto.
    eapply AnnDefEq_weaken_available. eauto.
    {
      rewrite (open_co_wrt_tm_close_co_wrt_tm g').
      rewrite (open_tm_wrt_tm_close_tm_wrt_tm).
      rewrite (open_tm_wrt_tm_close_tm_wrt_tm).
      eapply AnnDefEq_strengthen_available_tm; eauto.
      assert (x1 `notin` dom G). auto.
      simpl.  clear Fr0. clear Fr.
      fsetdec.
    }
    eauto.
    eapply AnnTyping_regularity. eauto.
    eapply AnnTyping_regularity. eauto.
    destruct (AnnDefEq_context_fv EqB1B2) as (_ & _ & _ & _ & h4 & _).
    simpl in h4.
    autorewrite with lngen.
    clear Fr0. assert (x1 `notin` dom G). auto. clear Fr.
    {
      eapply An_Pi_exists with (x:= x1); eauto 1.
      autorewrite with lngen.
      fsetdec.
      autorewrite with lngen.
      eapply AnnTyping_regularity; eauto.
    }
  - inversion a3.
    inversion a4.
    subst.
    destruct H as [P1 [P2 [g [AT1 [AT2 EP]]]]].
    destruct H0 as [Q1 [Q2 [g' [AU1 [AU2 EP']]]]].
    resolve_unique_subst.
    resolve_unique_subst.
    resolve_unique_subst.
    resolve_unique_subst.
    assert (HG : AnnCtx G); eauto with ctx_wff.
    eexists. eexists. eexists.
    split. eauto. split. eauto.
    eapply AnnDefEq_weaken_available; eauto.
  - destruct H as [C1 [C2 [g' [T1 [T2 E1]]]]].
    inversion T1. inversion T2. subst.
    exists a_Star. exists a_Star. exists (g_Refl a_Star).
    assert (HG : AnnCtx G); eauto with ctx_wff.
  - destruct H as [C1 [C2 [g [T1 [T2 E1]]]]].
    destruct H0 as [C1' [C2' [g' [T12 [T22 E2]]]]].
    inversion T1. inversion T2. subst.
    pick fresh x1. assert (FRL: x1 `notin` L). auto.
    pose N1 := H6 x1 FRL. clearbody N1. clear H6.
    pick fresh x2.
    assert (FRL0 : x2 `notin` L0). auto.
    pose N2 := H13 x2 FRL0. clearbody N2. clear H13.
    exists a_Star. exists a_Star. exists (g_Refl a_Star).
    repeat split.
    move: (AnnTyping_tm_subst N1 a3) => K1.
    simpl in K1.
    rewrite tm_subst_tm_tm_open_tm_wrt_tm in K1; auto.
    rewrite tm_subst_tm_tm_var in K1.
    rewrite tm_subst_tm_tm_fresh_eq in K1; auto.
    apply (AnnTyping_lc a3). clear Fr.
    pose K2 := AnnTyping_tm_subst N2 a4. clearbody K2.
    simpl in K2.
    rewrite tm_subst_tm_tm_open_tm_wrt_tm in K2; auto.
    rewrite tm_subst_tm_tm_var in K2.
    rewrite tm_subst_tm_tm_fresh_eq in K2; auto.
    apply (AnnTyping_lc a4). clear Fr0.
    assert (HG : AnnCtx G); eauto with ctx_wff.
  - exists a_Star. exists a_Star. eexists.
    assert (HG : AnnCtx G); eauto with ctx_wff.
  - (* cabs_cong *)
    exists (a_CPi phi1 B1), (a_CPi phi2 B2).
    exists g4.
    repeat split. auto. auto. auto.
  - clear H2. clear H3.
    destruct H as [C1 [D1 [g [T1 [T2 E1]]]]].
    destruct H0 as [C2 [D2 [g2' [T12 [T22 E2]]]]].
    destruct H1 as [C3 [D3 [g3' [T13 [T23 E3]]]]].
    inversion a5. inversion a6. subst.
    assert ((a_CPi (Eq a9 b A1) B0) = C1). eapply AnnTyping_unique; eauto.
    assert ((a_CPi (Eq a11 b0 A0) B1) = D1). eapply AnnTyping_unique; eauto.
    subst.
    eexists. eexists. eexists.
    eauto.
 -  destruct H as [C1 [D1 [g [T1 [T2 E1]]]]].
    destruct H0 as [C2 [D2 [g2' [T12 [T22 E2]]]]].
    destruct H1 as [C3 [D3 [g3' [T13 [T23 E3]]]]].
    inversion T1. inversion T2. subst.
    exists a_Star. exists a_Star. eexists.
    repeat split.
    eapply AnnTyping_co_subst_nondep; eauto.
    eapply AnnTyping_co_subst_nondep; eauto.
    eauto.
 - destruct H as [C1 [D1 [g [T1 [T2 E1]]]]].
   destruct H0 as [WF1 WF2].
   inversion WF1. inversion WF2.
   subst.
   assert (HG : AnnCtx G); eauto with ctx_wff.
   assert (U1 : AnnTyping G B a_Star). eapply AnnTyping_regularity; eauto.
   assert (U2 : AnnTyping G B1 a_Star). eapply AnnTyping_regularity; eauto.
   eexists. eexists. eexists.
   split. eauto. split.  eauto.
   eapply An_EraseEq; eauto.
 - split_hyp.
   inversion H. inversion H0. subst.
   assert (HG : AnnCtx G); eauto with ctx_wff.
   assert (U1 : AnnTyping G A a_Star). eapply AnnTyping_regularity; eauto.
   assert (U2 : AnnTyping G B a_Star). eapply AnnTyping_regularity; eauto.
   eexists. eexists. eexists.
   repeat split; eauto 1.
   eapply An_Refl; eauto 1.
   eapply An_Star. eauto.
 - assert (HG : AnnCtx G); eauto with ctx_wff.
   assert (U1 : AnnTyping G (a_Pi rho A B) a_Star).
   eapply AnnTyping_regularity; eauto.
   inversion U1.
   exists (a_Pi rho A B), (a_Pi rho A B). eexists.
   repeat split; eauto 1.
   pick fresh x and apply An_Abs; auto.
   + rewrite e; eauto. econstructor.
   eapply AnnTyping_weakening with (F:=nil); simpl; eauto.
   econstructor; eauto.
   econstructor; eauto.
   + rewrite e; eauto.
   destruct rho. econstructor; eauto. econstructor; eauto.
   simpl. autorewcs. apply union_notin_iff. split.
   eapply fv_tm_erase_tm. auto. auto.
(*   rewrite e; eauto.
   econstructor. eapply lc_erase. eauto using AnnTyping_lc1. *)
   + eapply An_Refl. eauto.
 - assert (HG : AnnCtx G); eauto with ctx_wff.
   assert (U1 : AnnTyping G (a_CPi phi B) a_Star).
   eapply AnnTyping_regularity; eauto.
   inversion U1. subst.
   exists (a_CPi phi B), (a_CPi phi B). eexists.
   repeat split; eauto 1.
   pick fresh x and apply An_CAbs; auto.
   inversion H3; subst.
   + rewrite e; eauto. econstructor.
     eapply AnnTyping_weakening with (F:=nil); simpl; eauto.
     econstructor; eauto. econstructor; eauto.
   + eapply An_Refl. eauto.
 (* Left/Right
 -  exists (a_Pi rho A B), (a_Pi rho A' B'), g2. repeat split; eauto 1.
 -  exists A, A'. eexists.  repeat split; eauto 1.
    eapply An_PiFst. eauto.
 - exists (a_CPi (Eq a1 a2 A0) B), (a_CPi (Eq a1' a2' A0') B'), g2. repeat split; eauto 1. *)
Qed.

Definition  AnnDefEq_regularity :
    (forall G D g A B,   AnnDefEq G D g A B ->
                    exists C1 C2 g', AnnTyping G A C1 /\ AnnTyping G B C2
                                /\ AnnDefEq G (dom G) g' C1 C2) :=
  fourth AnnDefEqAnnIso_regularity.

Definition AnnIso_regularity :
  forall G D g phi1 phi2, AnnIso G D g phi1 phi2 ->
                     AnnPropWff G phi1 /\ AnnPropWff G phi2 :=
  third AnnDefEqAnnIso_regularity.

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

(* Smart constructors for the annotated language *)

  Lemma An_Sym2
    : ∀ (G : context) (D : available_props) (g : co) (a b : tm),
      AnnDefEq G D g b a → AnnDefEq G D (g_Sym g) a b.
  Proof.
    intros.
    destruct (AnnDefEq_regularity H) as [A1 [A2 [g3 [T1 [T2 DE]]]]].
    eapply An_Sym ; eassumption.
  Qed.

Lemma An_Trans2
     : ∀ (G : context) (D : available_props) (g1 g2 : co)
       (a b a1 : tm),
       AnnDefEq G D g1 a a1
       → AnnDefEq G D g2 a1 b
       → AnnDefEq G D (g_Trans g1 g2) a b .
Proof.
  intros.
  destruct (AnnDefEq_regularity H) as [A1 [A2 [g3 [T1 [T2 DE]]]]].
    eapply An_Trans; eassumption.
Qed.

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

Lemma erase_capp :
  forall AB0 C G, AnnTyping G AB0 C -> forall A, erase AB0 = (a_CApp A g_Triv) ->
  exists a1 g0 g D, erase AB0 = erase (a_CApp a1 g0) /\ erase a1 = A /\
          AnnTyping G (a_CApp a1 g0) D /\ AnnDefEq G (dom G) g C D.
Proof.
  induction 1; intros a0 EQ; try destruct rho; inversion EQ; subst.
  - move: (IHAnnTyping1 _ H3) => [A1 [g0 [g1 [D hyp]]]]. split_hyp.
    subst.
    ann_invert_clear.
    exists A1.
    exists g0.
    eexists.
    eexists.
    repeat split.
    + simpl. simpl in *.  auto.
    + eapply An_CApp. eassumption. auto.
    + eapply An_Trans2 with (a1 := A). eapply An_Sym2; eauto.
      eauto.
  - exists a1. exists g. eexists. eexists.
    repeat split. eauto.
    eapply An_Refl.
    move: (AnnTyping_regularity H) => h0. inversion h0. subst.
    eapply AnnTyping_co_subst_nondep. eauto. eauto.
Qed.

Lemma An_AppCong2 : ∀ (G : context) (D : available_props) rho (g1 g2 : co)
       (a1 a2 b1 b2 A B : tm),
       AnnDefEq G D g1 a1 b1
       → AnnDefEq G D g2 a2 b2
         → AnnTyping G (a_App a1 rho a2) A
           → AnnTyping G (a_App b1 rho b2) B
           → AnnDefEq G D (g_AppCong g1 rho g2) (a_App a1 rho a2) (a_App b1 rho b2).
Proof.
  intros.
  assert (TMP: exists g3, AnnDefEq G (dom G) g3 A B).
  { destruct (AnnDefEq_regularity H) as (A1 & B1 & g4 & T1 & T2 & DE).
    destruct (AnnDefEq_regularity H0) as (A2 & B2 & g5 & T3 & T4 & DE2).
    inversion H1.
    inversion H2.
    resolve_unique_subst.
    resolve_unique_subst.
    resolve_unique_subst.
    resolve_unique_subst.
    eexists.
    eapply An_PiSnd; eauto 2. eapply AnnDefEq_weaken_available; eauto 1.
  } destruct TMP as [g3 EQ].
  eapply An_AppCong; eauto 1.
Qed.

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

Lemma An_CAppCong2 :
      ∀ (G : context) (D : available_props) (g1 g2 g3 : co) (a1 b1 a2 b2 a3 b3 A B : tm),
       AnnDefEq G D g1 a1 b1
       → AnnDefEq G (dom G) g2 a2 b2
       → AnnDefEq G (dom G) g3 a3 b3
       → AnnTyping G (a_CApp a1 g2) A
       → AnnTyping G (a_CApp b1 g3) B
       → AnnDefEq G D (g_CAppCong g1 g2 g3) (a_CApp a1 g2) (a_CApp b1 g3).
Proof.
  intros.
  assert (TMP : exists g4, AnnDefEq G (dom G) g4 A B).
  {
    destruct (AnnDefEq_regularity H) as (A1 & B1 & g4 & T1 & T2 & DE).
    inversion H2.
    inversion H3.
    resolve_unique_subst.
    resolve_unique_subst.
    resolve_unique_subst.
    resolve_unique_subst.
    eexists.
    eapply An_CPiSnd; eauto 2.
  } destruct TMP as [g4 EQ].
  eapply An_CAppCong; eauto 1.
Qed.

Lemma An_Trans'
     : ∀ (G : context) (D : available_props) (g1 g2 : co)
       (a b a1 : tm),
       AnnDefEq G D g1 a a1
       → AnnDefEq G D g2 a1 b
       → exists g, AnnDefEq G D g a b .
Proof.
  intros.
  destruct (AnnDefEq_regularity H) as [A1 [A2 [g3 [T1 [T2 DE]]]]].
  eexists.
  eapply An_Trans; eassumption.
Qed.

Lemma An_Sym'
   : ∀ (G : context) (D : available_props) (g : co) (a b : tm),
       AnnDefEq G D g b a → exists g, AnnDefEq G D g a b.
Proof.
  intros.
  destruct (AnnDefEq_regularity H) as [A1 [A2 [g3 [T1 [T2 DE]]]]].
  eexists.
  eapply An_Sym ; eassumption.
Qed.

Lemma An_Refl_Star : forall G D a b A,
     erase a = erase b -> AnnTyping G b a_Star ->
     AnnTyping G a A -> erase A = a_Star ->
     exists g, AnnDefEq G D g a b.
  Proof.
    intros.
    eexists.
    eapply An_EraseEq. eauto. eauto. eauto.
    eapply An_EraseEq. eapply AnnTyping_regularity. eauto.
    eapply An_Star. eauto with ctx_wff.
    eauto. eapply An_Refl. eapply An_Star.
    eauto with ctx_wff.
  Qed.

Lemma An_IsoRefl2_derivable  : ∀ (G : context) (D : available_props) (phi1 phi2 : constraint),
       AnnPropWff G phi1
       → AnnPropWff G phi2
       → erase_constraint phi1 = erase_constraint phi2 →
       exists g,
       AnnIso G D g phi1 phi2.
Proof.
  intros G D phi1 phi2 H H0 H1.
  destruct phi1 as [a1 b1 A1].
  destruct phi2 as [a2 b2 B2].
  assert (AnnCtx G). eauto 2 with ctx_wff.
  inversion H. inversion H0. simpl in H1. inversion H1. clear H1. subst.
  eexists.
  eapply An_IsoConv; eauto 1.
  eapply An_EraseEq; eauto 1.
  eapply AnnTyping_regularity; eauto 1.
  eapply AnnTyping_regularity; eauto 1.
  eapply An_Refl; eauto.
Qed.

Lemma An_Pi_exists2
     : ∀ (x : atom) (G : list (atom * sort)) (rho : relflag) (A B : tm),
       x `notin` union (dom G) (fv_tm_tm_tm B)
       → AnnTyping ([(x, Tm A)] ++ G) (open_tm_wrt_tm B (a_Var_f x)) a_Star
       → AnnTyping G (a_Pi rho A B) a_Star.
Proof.
  intros.
  eapply An_Pi_exists; eauto.
  sort_inversion.
Qed.

Lemma An_Abs_exists2
  : ∀ (x : atom) (G : context) (rho : relflag) (A a B : tm),
    x `notin` union (dom G) (union (fv_tm_tm_tm a) (fv_tm_tm_tm B))
    → AnnTyping ([(x, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x)) (open_tm_wrt_tm B (a_Var_f x))
    → RhoCheck rho x (erase_tm (open_tm_wrt_tm a (a_Var_f x)))
    → AnnTyping G (a_Abs rho A a) (a_Pi rho A B).
Proof.
  intros.
  eapply An_Abs_exists; eauto.
  sort_inversion.
Qed.

Lemma An_CPi_exists2
  : ∀ (c : atom) (G : context) (phi : constraint) (B : tm),
       c `notin` union (dom G) (fv_co_co_tm B)
       → AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co B (g_Var_f c)) a_Star
       → AnnTyping G (a_CPi phi B) a_Star.
Proof.
  intros.
  eapply An_CPi_exists; eauto.
  sort_inversion.
Qed.

Lemma An_CAbs_exists2
   : ∀ (c : atom) (G : context) (phi : constraint) (a B : tm),
       c `notin` union (dom G) (union (fv_co_co_tm a) (fv_co_co_tm B))
       → AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c)) (open_tm_wrt_co B (g_Var_f c))
       → AnnTyping G (a_CAbs phi a) (a_CPi phi B).
Proof.
  intros.
  eapply An_CAbs_exists; eauto.
  sort_inversion.
Qed.

Lemma An_Fam2 :  ∀ (G : context) (F : tyfam) (A a : tm),
       AnnCtx G
       → binds F (Ax a A) an_toplevel
       → AnnTyping G (a_Fam F) A.
Proof.
  intros.
  eapply An_Fam.
  eauto. eauto.
  move: (an_toplevel_closed H0) => h0.
  move: (AnnTyping_regularity h0) => h1.
  eauto.
Qed.

Lemma An_AbsCong_exists2
      : ∀ (x1 x2 : atom) (G : context) (D : available_props) (rho : relflag) (g1 g2 : co)
        (A1 b1 A2 b3 b2 B : tm),
        x1 `notin` union (dom G) (union (fv_tm_tm_tm b1) (union (fv_tm_tm_tm b2) (fv_tm_tm_co g2)))
        → x2 `notin` union (dom G) (union (fv_tm_tm_tm b2) (union (fv_tm_tm_tm b3) (fv_tm_tm_co g1)))
          → AnnDefEq G D g1 A1 A2
            → AnnDefEq ([(x1, Tm A1)]++ G) D (open_co_wrt_tm g2 (a_Var_f x1))
                (open_tm_wrt_tm b1 (a_Var_f x1)) (open_tm_wrt_tm b2 (a_Var_f x1))
              → open_tm_wrt_tm b3 (a_Var_f x2) = open_tm_wrt_tm b2 (a_Conv (a_Var_f x2) (g_Sym g1))
                  → AnnTyping G A2 a_Star
                    → RhoCheck rho x1 (erase_tm (open_tm_wrt_tm b1 (a_Var_f x1)))
                      → RhoCheck rho x2 (erase_tm (open_tm_wrt_tm b3 (a_Var_f x2)))
                        → AnnTyping G (a_Abs rho A1 b2) B
                          → AnnDefEq G D (g_AbsCong rho g1 g2) (a_Abs rho A1 b1) (a_Abs rho A2 b3).
 Proof.
   intros. eapply An_AbsCong_exists; eauto.
   inversion H7. auto.
 Qed.

 Lemma An_CPiCong_exists2
      : ∀ (c : atom) (G : context) (D : available_props)
        (g1 g3 : co) (phi1 : constraint) (B1 : tm)
        (phi2 : constraint) (B3 B2 : tm),
        AnnIso G D g1 phi1 phi2
        → c
          `notin` (union (dom G)
                   (union D
                    (union (fv_co_co_tm B2)
                       (union (fv_co_co_tm B1)
                          (union (fv_co_co_co g3)
                              (union (fv_co_co_co g1)
                                     (fv_co_co_tm B3)))))))
          → AnnDefEq ([(c, Co phi1)] ++ G) D
                     (open_co_wrt_co g3 (g_Var_f c))
                     (open_tm_wrt_co B1 (g_Var_f c))
                     (open_tm_wrt_co B2 (g_Var_f c))
          → open_tm_wrt_co B3 (g_Var_f c) =
            open_tm_wrt_co B2 (g_Cast (g_Var_f c) (g_Sym g1))
          → AnnTyping G (a_CPi phi1 B1) a_Star
          → AnnTyping G (a_CPi phi1 B2) a_Star
          → AnnDefEq G D (g_CPiCong g1 g3) (a_CPi phi1 B1) (a_CPi phi2 B3).
 Proof.
   intros. eapply An_CPiCong_exists with (B1 := B1) (B2 := B2) (B3:= B3); eauto.
   eapply An_CPi_exists2 with (c:= c).
   fsetdec.
   rewrite H2.
   move: (AnnIso_regularity H) => [h0 h1].
   move: (AnnIso_AnnCtx H) => h2.
   destruct phi1 as [a1 b1 A1].
   destruct phi2 as [a2 b2 A2].
   inversion h1. subst.
   inversion H4. subst.
   eapply AnnTyping_co_subst_nondep with (D := dom ([(c, Co (Eq a2 b2 A2))] ++ G))(L := L \u {{c}} \u dom G).
   eapply An_Cast.
   eapply An_Assn.
   eauto.
   eauto.
   simpl. eauto.
   eapply An_IsoSym.
   eapply AnnIso_weakening with (F := nil); simpl; eauto using AnnIso_weaken_available.
   eapply (third ann_weaken_available_mutual).
   eapply AnnIso_weaken_available. eauto. eauto.
   econstructor; eauto.
   intros c1 Fr.
   move: (H12 c1 ltac:(auto)) => h3.
   eapply AnnTyping_weakening with (F:= (c1 ~ Co (Eq a1 b1 A1))); eauto.
   econstructor; eauto.
   eapply AnnPropWff_weakening with (F:=nil); eauto.
   simpl. econstructor; eauto.
 Qed.

(* Left/Right
  Lemma An_Left2 :
      ∀ (G : context) (D : available_props) (g1 g2 : co)
       (a a' : tm) (T : ett_ott.const) (rho : relflag)
       (A B A' B' b b' : tm),
       Path T a
       → Path T a'
       → AnnTyping G a (a_Pi rho A B)
       → AnnTyping G a' (a_Pi rho A' B')
       → AnnDefEq G D g1 (a_App a rho b) (a_App a' rho b')
       → AnnDefEq G (dom G) g2 (a_Pi rho A B) (a_Pi rho A' B')
       → AnnDefEq G D (g_Left g1 g2) a a'.
  Proof.
    intros.
    move: (AnnDefEq_regularity H3) => [s1 [s2 [g4 hyp]]]. split_hyp.
    ann_invert_clear.
    ann_invert_clear.
    resolve_unique_subst.
    resolve_unique_subst.
    invert_syntactic_equality.
    eapply An_Left with (b:=b)(b':=b'); try eassumption.
  Qed.

  Lemma An_Right2 : ∀ (G : context) (D : available_props) (g1 g2 : co) (b b' : tm) (T : ett_ott.const) (a a' : tm) (A A' B B' : tm),
      Path T a
      → Path T a'
      → AnnTyping G a (a_Pi Rel A B)
      → AnnTyping G a' (a_Pi Rel A' B')
      → AnnDefEq G D g1 (a_App a Rel b) (a_App a' Rel b')
      → AnnDefEq G (dom G) g2 (a_Pi Rel A B) (a_Pi Rel A' B')
      → AnnDefEq G D (g_Right g1 g2) b b'.
  Proof.
    intros.
    move: (AnnDefEq_regularity H3) => [T1 [T2 [g hyp]]]. split_hyp.
    ann_invert_clear.
    ann_invert_clear.
    resolve_unique_subst.
    resolve_unique_subst.
    invert_syntactic_equality.
    eapply An_Right with (a:=a)(a':=a'); try eassumption.
  Qed.

  Lemma An_CLeft2 : ∀ (G : context) (D : available_props) (g1 g2 : co) (a a' : tm)
                      (T : const) phi B phi' B'
                      (g g': co),
      Path T a
      → Path T a'
      → AnnTyping G a (a_CPi phi B)
      → AnnTyping G a' (a_CPi phi' B')
      → AnnDefEq G D g1 (a_CApp a g) (a_CApp a' g')
      → AnnDefEq G (dom G) g2 (a_CPi phi B) (a_CPi phi' B')
      → AnnDefEq G D (g_Left g1 g2) a a'.
  Proof.
    intros.
    move: (AnnDefEq_regularity H3) => [T1 [T2 [s hyp]]]. split_hyp.
    inversion H5. inversion H6. subst.
    destruct phi as [a1 a2 A]. destruct phi' as [a1' a2' A'].
    resolve_unique_subst.
    resolve_unique_subst.
    inversion H8.
    inversion H9.
    subst.
    eapply An_CLeft with (g := g)(g':=g')(a1 := a0)(a2:=b)(A0:=A1)(a1':=a3)(a2':=b0)(A0':=A0); try eassumption.
  Qed.
*)

End fc_invert.


Require Import List ListSet.

Import ListNotations.

From CasperCBC
  Require Import
    Lib.Preamble
    Lib.ListExtras
    Lib.ListSetExtras
    Lib.Measurable
    VLSM.Common
    Validator.State
    Validator.Equivocation
    VLSM.Equivocation
    VLSM.ObservableEquivocation
    .

(** * VLSM Full-Node Client *)

Section CompositeClient.

(**
This section defines a full-node client as a VLSM.
The full node client does not produce messages, but incorporates received
messages, implementing a limited equivocation tolerance policy.
*)

  Context
    {C V : Type}
    {about_C : StrictlyComparable C}
    {about_V : StrictlyComparable V}
    {Hmeasurable : Measurable V}
    {Hrt : ReachableThreshold V}
    (eq_V := @strictly_comparable_eq_dec _ about_V)
    (message := State.message C V)
    (happens_before := validator_message_preceeds C V)
    (happens_before_dec := validator_message_preceeds_dec C V)
    (message_eq : EqDecision message := @message_eq _ _ about_C about_V)
    .

  Existing Instance eq_V.
  Existing Instance happens_before_dec.

  Definition full_node_client_has_been_observed
    (s : set message)
    (m : message)
    : Prop
    := In m s.

  Definition full_node_message_subject_of_observation
    (m : message)
    : option V
    := Some (sender m).

  Program Instance observable_messages
    : observable_events message message
    := {
      has_been_observed (m e :message) := m = e \/ In e (get_message_set (unmake_justification (get_justification m)))
    }.
  Next Obligation.
    intros m e. apply Decision_or; [| apply in_dec]; apply message_eq.
  Defined.

  Definition full_node_client_observable_messages_fn
    (s : set message)
    (v : V)
    : set message
    :=
    filter (fun m => bool_decide (sender m = v)) s.

  Definition full_node_client_state_validators
    (s : set message)
    : set V
    :=
    set_map decide_eq sender s.

  Instance full_node_client_observable_messages
    : observable_events (set message) message
    :=
    state_observable_events_instance (set message) V message _
      full_node_client_observable_messages_fn full_node_client_state_validators.

  Lemma full_node_client_has_been_observed_iff
    (s : set message)
    (m : message)
    : has_been_observed s m <-> In m s.
  Proof.
    simpl.
    unfold observable_events_has_been_observed.
    unfold state_observable_events_fn.
    split; intro H.
    - apply union_fold in H.
      destruct H as [needle [Hm Hneedle]] .
      apply in_map_iff in Hneedle.
      destruct Hneedle as [v0 [Hneedle Hv0]].
      subst needle.
      apply filter_In in Hm.
      destruct Hm as [Hm Hv0eq].
      assumption.
    - apply union_fold.
      exists (full_node_client_observable_messages_fn s (sender m)).
      split.
      * apply filter_In.
        split; [assumption|].
        apply bool_decide_eq_true. reflexivity.
      * apply in_map_iff.
        exists (sender m). split; [intuition|].
        apply set_map_exists.
        exists m. split; [assumption|reflexivity].
  Qed.

  Instance full_node_client_observation_based_equivocation_evidence
    : observation_based_equivocation_evidence (set message) V message _ decide_eq _ happens_before_dec full_node_message_subject_of_observation
    :=
    observable_events_equivocation_evidence _ _ _ _
      full_node_client_observable_messages_fn full_node_client_state_validators
      _ happens_before_dec full_node_message_subject_of_observation.

  Instance full_node_client_observation_based_equivocation_evidence_dec
    : RelDecision (@equivocation_evidence _ _ _ _ _ _ _ _ full_node_client_observation_based_equivocation_evidence)
    :=
    observable_events_equivocation_evidence_dec _ _ _ _
      full_node_client_observable_messages_fn full_node_client_state_validators
      _ _ happens_before_dec full_node_message_subject_of_observation.

  Lemma full_node_client_state_validators_nodup
    (s : set message)
    : NoDup (full_node_client_state_validators s).
  Proof.
    apply set_map_nodup.
  Qed.

  Definition client_basic_equivocation
    : basic_equivocation (set message) V
    := @basic_observable_equivocation (set message) V message
        message_eq _ happens_before_dec full_node_client_observable_messages full_node_message_subject_of_observation full_node_client_observation_based_equivocation_evidence _ _ _  full_node_client_state_validators full_node_client_state_validators_nodup.

  Existing Instance client_basic_equivocation.

  (* 2.5.1 Minimal full client protocol: Client2 *)
  Definition label2 : Type := unit.

  Definition vtransition2
    (l : unit)
    (sm : set message * option message)
    : set message * option message
    :=
    let (msgs, om) := sm in
    match om with
    | None => pair msgs None
    | Some msg => pair (set_add decide_eq msg msgs)  None
    end.

  Definition valid_client2
    (_ : unit)
    (som : set message * option message)
    :=
    let (msgs, om) := som in
    match om with
    | None => True
    | Some msg =>
      ~In msg msgs
      /\ incl (get_message_set (unmake_justification (get_justification msg))) msgs
      /\ not_heavy (set_add decide_eq msg msgs)
    end.

  Instance VLSM_type_full_client2 : VLSM_type message :=
    { state := set message
    ; label := label2
    }.

  Definition initial_state_prop
    (s : set message)
    : Prop
    :=
    s = [].

  Definition state0 : {s | initial_state_prop s} :=
    exist _ [] eq_refl.

  Definition initial_message_prop (m : message) : Prop := False.

  Instance LSM_full_client2 : VLSM_sign VLSM_type_full_client2 :=
    { initial_state_prop := initial_state_prop
    ; initial_message_prop := initial_message_prop
    ; s0 := state0
    ; m0 := State.message0
    ; l0 := tt
    }.

  Definition VLSM_full_client2_machine  : VLSM_class LSM_full_client2 :=
    {| transition := vtransition2
      ; valid := valid_client2
    |}.

  Definition VLSM_full_client2 : VLSM message := mk_vlsm VLSM_full_client2_machine.

  Program Instance full_node_client_vlsm_observable_messages
    : vlsm_observable_events VLSM_full_client2 full_node_message_subject_of_observation.
  Next Obligation.
    replace s with (@nil message) in He by assumption.
    inversion He.
  Qed.
  Next Obligation.
  inversion His.
  Qed.
  Next Obligation.
    unfold vtransition in Ht. simpl in Ht. destruct o; congruence.
  Qed.

  Section proper_sent_received.
  Context
    (vlsm := VLSM_full_client2)
    (bvlsm := pre_loaded_with_all_messages_vlsm vlsm)
    .

  Lemma client_protocol_state_nodup
    (s : set message)
    (Hs : protocol_state_prop bvlsm s)
    : NoDup s.
  Proof.
    induction Hs using protocol_state_prop_ind.
    - inversion Hs. constructor.
    - destruct Ht as [_ Ht].
      simpl in Ht. unfold vtransition in Ht. simpl in Ht.
      destruct om as [msg|]; inversion Ht.
      * apply set_add_nodup. assumption.
      * subst. assumption.
  Qed.

  Lemma protocol_transition_inv_in
    (l : label)
    (s s' : set message)
    (m : message)
    (om' : option message)
    (Ht : protocol_transition bvlsm l (s, Some m) (s', om'))
    : s' = set_add decide_eq m s
    /\ om' = None
    /\ ~In m s
    /\ incl
        (unmake_message_set (justification_message_set (get_justification m)))
        s
    /\ not_heavy s'
    /\ protocol_state_prop bvlsm s
    /\ protocol_message_prop bvlsm m
    /\ protocol_state_prop bvlsm s'.
  Proof.
    pose Ht as Hs'.
    apply protocol_transition_destination in Hs'.
    destruct Ht as [[Hs [Hm [Hnin [Hincl Hnh]]]] Ht].
    inversion Ht. subst. simpl.
    repeat split; try reflexivity; assumption.
  Qed.

  Lemma protocol_transition_inv_out
    (l : vlabel bvlsm)
    (s1 s2 : set message)
    (iom : option message)
    (m : message)
    (Ht : protocol_transition bvlsm l (s1, iom) (s2, Some m))
    : False.
  Proof.
    destruct Ht as [Hv Ht].
    simpl in Ht. unfold vtransition in Ht. simpl in Ht.
    destruct iom; inversion Ht.
  Qed.

  Lemma in_protocol_state
    (s : set message)
    (Hs : protocol_state_prop bvlsm s)
    (m : message)
    (Hm : In m s)
    : incl (unmake_message_set (justification_message_set (get_justification m))) s.
  Proof.
    induction Hs using protocol_state_prop_ind.
    - inversion Hs. subst s. inversion Hm.
    - destruct Ht as [[Hps [Hom Hv]] Ht].
      simpl in Ht. unfold vtransition in Ht. simpl in Ht.
      simpl in Hv. unfold vvalid in Hv. simpl in Hv.
      destruct om as [msg|]; inversion Ht; subst; clear Ht
      ; simpl in IHHs; simpl in Hv; simpl;
        [|apply IHHs;assumption].
      destruct Hv as [Hnmsg [Hv Hnh]].
      apply set_add_iff in Hm.
      destruct Hm as [Heqm | Hm].
      + subst m.
        apply incl_tran with s; try assumption.
        intros x Hx; apply set_add_iff. right. assumption.
      + specialize (IHHs Hm).
        apply incl_tran with s; try assumption.
        intros x Hx; apply set_add_iff. right. assumption.
  Qed.

  Lemma get_messages_in_futures
    (s1 s2 : set message)
    (Hs : in_futures bvlsm s1 s2)
    : incl s1 s2.
  Proof.
    unfold in_futures in Hs. destruct Hs as [tr Htr].
    induction Htr.
    - apply incl_refl.
    - apply incl_tran with s;[|assumption].
      clear -H.
      destruct H as [_ Ht]. simpl in Ht. unfold vtransition in Ht. simpl in Ht.
      destruct iom as [msg|]; inversion Ht; try apply incl_refl.
      simpl. intros m Hm. apply set_add_iff. right. assumption.
  Qed.

  Definition client_has_been_sent
    : state_message_oracle vlsm
    :=
    fun _ _ => false.

  Global Instance client_has_been_sent_dec
    : RelDecision client_has_been_sent
    := fun _ _ => right (fun Hn => Hn).

  Definition client_has_been_received
    : state_message_oracle vlsm
    :=
    fun s m => In m s.
  Global Instance client_has_been_received_dec
    : RelDecision client_has_been_received
    :=
    fun s m => in_dec decide_eq m s.

  Lemma VLSM_full_client_has_been_sent_step_properties:
    has_been_sent_stepwise_props client_has_been_sent.
  Proof.
    unfold client_has_been_sent.
    split.
    - tauto.
    - intros l s im s' om Hptrans msg.
      assert (om <> Some msg).
      {
        destruct Hptrans as [_ Htrans].
        cbn in Htrans.
        destruct im;inversion Htrans;congruence.
      }
      tauto.
  Qed.

  Definition VLSM_full_client_has_been_sent
    : has_been_sent_capability VLSM_full_client2
    := has_been_sent_capability_from_stepwise client_has_been_sent_dec
                                              VLSM_full_client_has_been_sent_step_properties.

  Lemma VLSM_full_client_has_been_received_step_properties:
    has_been_received_stepwise_props client_has_been_received.
  Proof.
    unfold client_has_been_received.
    split.
    - intros s ->. tauto.
    - intros l s im s' om Hptrans msg.
      simpl.
      destruct Hptrans as [_ Htrans].
      cbn in Htrans.
      destruct im;inversion Htrans;subst;
      [rewrite set_add_iff|];intuition congruence.
  Qed.

  Definition VLSM_full_client_has_been_received
    : has_been_received_capability VLSM_full_client2
  := has_been_received_capability_from_stepwise _
      VLSM_full_client_has_been_received_step_properties.

End proper_sent_received.

End CompositeClient.


Require Import Div2.
Require Import Even.
Require Import Arith.
Require Import Arith.Bool_nat.
Require Import AuxiliaryProofs.
Require Import Bool.
Require Import While.
Require Import Usability.
Require Import Heap.
Require Import Coq.FSets.FMapFacts.
Import While.Language.
Import While.Semantics.

Module Swap.
Import Bool.

Lemma add_neq_o : forall m x y (e : val),
 ~ M.E.eq x y -> M.find y (M.add x e m) = M.find y m.
Admitted.

Lemma MapsTo_iff : forall m x y (e : Addr.t), M.E.eq x y -> (M.MapsTo x e m <-> M.MapsTo y e m).
Admitted.

Lemma add_neq_mapsto_iff : forall m x y (e e' : Addr.t),
 ~ M.E.eq x y -> (M.MapsTo y e' (M.add x e m) <-> M.MapsTo y e' m).
Admitted.

Lemma find_mapsto_iff : forall m x (e : Addr.t), M.MapsTo x e m <-> M.find x m = Some e.
Admitted.

Lemma mapsto_find : forall m x (e : Addr.t), M.MapsTo x e m -> M.find x m = Some e.
Admitted.

Lemma in_find_iff : forall (m : heap) x, M.In x m <-> M.find x m <> None.
Admitted.

Lemma mem_in_iff : forall (m : heap) (x : Addr.t), M.In x m <-> M.mem x m = true.
Admitted.

Lemma add_eq_b : forall m x y (e : val),
 M.E.eq x y -> M.mem y (M.add x e m) = true.
Admitted.

Lemma add_neq_b : forall m x y (e : val),
 ~M.E.eq x y -> M.mem y (M.add x e m) = M.mem y m.
Admitted.

Lemma add_eq_o : forall m x y (e : val),
 M.E.eq x y -> M.find y (M.add x e m) = Some e.
Admitted.

Lemma add_in_iff : forall m x y (e : val), M.In y (M.add x e m) <-> M.E.eq x y \/ M.In y m.
Admitted.

Definition P : Addr.t := Addr.MkAddr 0.
Definition Q : Addr.t := Addr.MkAddr 1.
Definition N : Addr.t := Addr.MkAddr 2.

Definition SWAP :=
  Spec ([ fun s => M.In P s /\ M.In Q s /\ M.In N s
        , fun s _ s' => find s P = find s' Q
                     /\ find s Q = find s' P
                     /\ M.In P s'
                     /\ M.In Q s'
                     /\ M.In N s']).

(*
Definition SWAP := Spec ([fun _ => True, fun s _ s' => varP s = varQ s' /\ varP s' = varQ s]).
*)

Definition swapResult :
  SWAP ⊑ (N ::= Var Q ; Q ::= Var P ; P ::= Var N).
Proof.
  apply (refineTrans
          (Spec ([ fun s => M.In P s /\ M.In Q s /\ M.In N s
                 , fun s _ s' => find s Q = find s' N
                              /\ find s P = find s' Q
                              /\ M.In P s' /\ M.In Q s' /\ M.In N s']) ;
           P ::= Var N)).
  apply refineFollowAssign.

  intros s [PinS [QinS NinS]] s' [eq1 [eq2 [PinS' [QinS' NinS']]]].
  unfold subst; simpl; repeat split.
  unfold setIdent,getIdent,update,find; rewrite add_neq_o; [ assumption | auto].
  unfold setIdent,getIdent,update,find; rewrite add_eq_o; unfold find in eq1.
  rewrite eq1; apply in_find_iff in NinS'.
  destruct (M.find (elt:=val) N s'); [ | contradict NinS']; trivial.
  unfold M.E.eq; trivial.

  unfold setIdent,getIdent,update; rewrite mem_in_iff; apply add_eq_b; unfold M.E.eq; trivial.
  unfold setIdent,getIdent,update; rewrite <- eq1; rewrite add_in_iff; right; assumption.
  unfold setIdent,getIdent,update; rewrite add_in_iff; right; assumption.
  assumption.

  apply refineSeqAssocR.
  apply refineSplit; try apply refineRefl.
  apply (refineTrans
          (Spec ([ fun s => M.In P s /\ M.In Q s /\ M.In N s
                 , fun s _ s' => find s P = find s' P
                              /\ find s Q = find s' N
                              /\ M.In P s' /\ M.In Q s' /\ M.In N s']) ;
           Q ::= Var P)).
  apply refineFollowAssign.

  intros s [PinS [QinS NinS]] s' [eq1 [eq2 [PinS' [QinS' NinS']]]].
  unfold subst; simpl; repeat split.
  unfold setIdent,getIdent,update,find; rewrite add_neq_o; [ assumption | auto].

  unfold setIdent,getIdent,update,find; rewrite add_eq_o.
  unfold find in eq1; rewrite eq1; apply in_find_iff in PinS'.
  destruct (M.find (elt:=val) P s'); [ | contradict PinS']; trivial.
  unfold M.E.eq; trivial.

  unfold setIdent,getIdent,update,find; rewrite add_in_iff; right; assumption.
  unfold setIdent,getIdent,update,find; rewrite add_in_iff; left; unfold M.E.eq; trivial.
  unfold setIdent,getIdent,update,find; rewrite add_in_iff; right; assumption.
  assumption.

  apply refineSplit; try apply refineRefl.
  apply refineAssign.
  simpl; intros s [PinS [QinS NinS]].

  repeat split.
  unfold setIdent,getIdent,update,find; rewrite add_neq_o; trivial.
  unfold N, P, M.E.eq; intros contra; inversion contra.

  unfold setIdent,getIdent,update,find; rewrite add_eq_o; rewrite in_find_iff in QinS.
  destruct (M.find (elt:=val) Q s); [ | contradict QinS]; trivial.

  unfold M.E.eq; trivial.
  unfold setIdent,getIdent,update,find; rewrite add_in_iff; right; assumption.
  unfold setIdent,getIdent,update,find; rewrite add_in_iff; right; assumption.
  unfold setIdent,getIdent,update,find; rewrite add_in_iff; right; assumption.

  unfold subset; simpl; intros s [PinS [QinS NinS]]; assumption.
Defined.

End Swap.

Module Definitions.

Definition square : nat -> nat := fun n => n * n.

Definition Inv : S -> Prop := fun X => square (varR X) <= varN X < square (varQ X).

Definition WSPEC := Spec ([ (fun _ => True), fun _ _ X => square (varR X) <= varN X < square (1 + varR X)]).

Definition W1 := Spec ([ fun _ => True, fun _ _ X => Inv X /\ 1 + varR X = varQ X]).

Definition W2 := (Spec ([fun _ => True , K Inv])) ; (Spec ([Inv, fun _ _ X => Inv X /\ 1 + varR X = varQ X])).

Definition PT3a :=
  Assign_PT (fun s => mkS (varN s) (varP s) (1 + (varN s)) 0).

Definition W3aa :=
  R ::= (EConst 0).

Definition W3ab :=
  Q ::= (Plus (EConst 1) (Var N)).

Definition W3a := W3aa ; W3ab.

Definition WBody :=
  Spec ([(fun s => Inv s /\ Is_true (negb (beq_nat (1 + varR s) (varQ s)))),
          (fun _ _ s' => Inv s')]).

Definition W3b :=
  let guard := (Not (Eq (Plus (EConst 1) (Var R)) (Var Q))) in
  While Inv guard WBody.

Definition W4 :=
  (Spec ([fun X => 1 + varR X < varQ X /\ Inv X,
          fun _ _ X => varR X < varP X < varQ X /\ Inv X])) ;
  (Spec ([fun X => varR X < varP X < varQ X /\ Inv X, fun _ _ X => Inv X])).

Definition W5a :=
  P ::= (Div2 (Plus (Var Q) (Var R))).

Definition W5bThen :=
  Spec ([fun s => (varN s < square (varP s)) /\ (varP s < varQ s) /\ Inv s,
         fun _ _ s' => Inv s']).

Definition W5bElse :=
  Spec ([fun s => (varN s >= square (varP s)) /\ (varR s < varP s) /\ Inv s,
         fun _ _ s' => Inv s']).

Definition W5b :=
  If (Lt (Var N) (Mult (Var P) (Var P))) W5bThen W5bElse.

End Definitions.

Module Proof.

Import Definitions.
Import While.CodeGeneration.
Import Bool.

Ltac refine_post_pt pt1 pt2 := apply (Refinement _ _ (fun s (y : pre pt1 s) => y : pre pt2 s)).

Ltac refine_post w1 w2 :=
  apply (Refinement _ _ (fun s (y : pre (semantics w1) s) => y : pre (semantics w2) s)).

Ltac assert_pre w1 w2 :=
  assert (d : pre (semantics w1) ⊂ pre (semantics w2));
  unfold pre,subset,semantics,w1,w2.

Lemma step1 : WSPEC ⊑ W1.
  Proof.
    refine_post WSPEC W1.
    unfold subset.
    intros X tt s [H1 H2]; simpl in *; rewrite H2; apply H1.
  Qed.

Lemma step2 : W1 ⊑ W2.
  Proof.
    assert_pre W1 W2.
    intros; exists I; intros; auto.
    apply (Refinement _ _ d).
    simpl; intros s Pre s' [t [H1 [H2 H3]]]; split; auto.
Qed.

Lemma step3 : W2 ⊑ W3a ; W3b.
Proof.
  unfold W2,W3a,W3aa,W3ab,W3b,"⊑",semantics.
  apply refineSplitPT.
  simpl.
  unfold Assign_PT, K, Inv.
  apply (refineTransPT PT3a).
  (* Part a *)
    unfold K, Inv, PT3a, square; apply refineAssignPT.
    simpl; intros; split; auto with arith.
  (* refineTrans *)
  unfold PT3a,Assign_PT.
  apply refineSeqAssignPT.
  intros; destruct s; simpl; reflexivity.
  (* Part b *)
     apply refineWhile.
     intros.
     destruct s as [N P Q R]; simpl in *.
     destruct Q as [|Q].
     inversion H.
     case_eq (beq_nat R Q); intros H'.
     symmetry in H'; apply beq_nat_eq in H'.
     rewrite H'; reflexivity.
     rewrite H' in H; inversion H.
  Qed.

Lemma step4 : WBody ⊑ W4.
  assert_pre WBody W4.
  simpl; intros.
  split.
  inversion H as [H1 H2]; inversion H1 as [H3 H4].
  split.
  unfold square in *; destruct s as [N P Q R]; unfold Inv in *; simpl in *.
  unfold Is_true,negb in H2.
  remember (if match Q with
             | 0 => false
             | Datatypes.S m1 => beq_nat R m1
             end
          then false
          else true) as e.
  destruct e; induction Q as [|Q HQ].
  unfold square in H4; simpl in H; inversion H4.
  remember (beq_nat R Q) as beq; destruct beq; inversion Heqe.
  symmetry in Heqbeq; apply beq_nat_false in Heqbeq.
  unfold not in Heqbeq; clear H2; clear Heqe.
  unfold square in *.
  apply le_lt_trans with (p:=Datatypes.S Q * Datatypes.S Q) in H3.
  apply lt_sq_n in H3; unfold "<" in H3; inversion H3.
  exfalso; apply Heqbeq; assumption.
  subst; unfold "<"; apply le_n_S; assumption.
  assumption.
  exfalso; assumption.
  exfalso; assumption.
  assumption.
  intros s' [H1 H2]; inversion H as [H3 H4]; split; assumption.

  apply (Refinement _ _ d).
  intros s PreS; unfold post,subset in *; simpl in *.
  intros; inversion H as [x [H1 x']]; assumption.
Qed.

Lemma step5 : W4 ⊑ W5a ; W5b.
  apply refineSplit.
  simpl.
  apply refineAssign.
  simpl.
  intros s H.
  split.
  destruct s as [N P Q R].
  unfold Inv in H.
  simpl in *.
  inversion H as [H1 H2].
  split.

  apply plus_lt_compat_r with (p:=R) in H1.
  simpl in H1.
  apply lt_S_div2 in H1.
  replace (R + R) with (2 * R) in H1 by (omega).
  rewrite div2_double in H1.
  assumption.

  apply plus_lt_compat_r with (p:=Q) in H1.
  simpl in H1.
  apply lt_S_div2 in H1.
  replace (Q + Q) with (2 * Q) in H1 by (omega).
  rewrite div2_double in H1.
  rewrite plus_comm in H1.
  assumption.

  inversion H as [H1 [H2 H3]].
  unfold Inv in *.
  split; destruct s as [N P Q R]; simpl in *; assumption.
  unfold Inv,W5b.
  unfold "⊑",semantics,W5bThen,W5bElse.
  assert (d: pre ([fun X : S => varR X < varP X < varQ X /\ square (varR X) <= varN X < square (varQ X),
             fun (s : S) (_ : varR s < varP s < varQ s /\ square (varR s) <= varN s < square (varQ s))
             (X : S) => square (varR X) <= varN X < square (varQ X)])
             ⊂ pre (semantics W5b)).
  unfold pre,semantics,subset,W5b; simpl.
  intros s [[H1 H2] [H3 H4]].
  destruct s as [N P Q R]; simpl in *.
  unfold Inv,Is_true,Is_false; simpl.
  remember (proj1_sig (nat_lt_ge_bool N (P * P))) as e; destruct e.
  unfold proj1_sig,nat_lt_ge_bool,Sumbool.bool_of_sumbool,sumbool_rec in *.
  unfold sumbool_rect,Sumbool.sumbool_not in *.
  remember (lt_ge_dec N (P * P)) as e; destruct e.
  split; intros H5.
  repeat split; assumption.
  inversion H5.
  inversion Heqe.
  unfold proj1_sig,nat_lt_ge_bool,Sumbool.bool_of_sumbool,sumbool_rec in *.
  unfold sumbool_rect,Sumbool.sumbool_not in *.
  remember (lt_ge_dec N (P * P)) as e; destruct e.
  inversion Heqe.
  split; intros H5.
  inversion H5.
  repeat split; assumption.

  apply (Refinement _ _ d).
  simpl; unfold subset; intros s PreS s' H.
  inversion PreS as [H1 H2].
  assert (Ha: forall b, or (Is_true b) (Is_false b)) by
         (intros; destruct b; simpl in *; auto).
  destruct s as [N P Q R]; simpl in *.
  inversion H as [H3 H4].
  assert (H': or (Is_true (proj1_sig (nat_lt_ge_bool N (P * P))))
                 (Is_false (proj1_sig (nat_lt_ge_bool N (P * P))))) by (apply Ha).
  inversion H' as [H5 | H5].
  apply H3 in H5; assumption.
  apply H4 in H5; assumption.
Qed.

Lemma step6Then : W5bThen ⊑ Q ::= (Var P).
Proof.
  apply refineAssign.
  simpl.
  intros s H.
  unfold Inv in *.
  destruct H as [H1 [H2 [H3 H4]]].
  destruct s as [N P Q R].
  simpl in *.
  split.
  assumption.
  assumption.
Qed.

Lemma step6Else : W5bElse ⊑ R ::= (Var P).
Proof.
  apply refineAssign.
  simpl.
  intros s H.
  destruct H as [H1 [H2 [H3 H4]]].
  destruct s. unfold Inv in *.
  simpl in *.
  split; auto.
Qed.

Definition prgrm := (R ::= (EConst 0) ; Q ::= (Plus (EConst 1) (Var N))) ;
  (While Inv (Not (Eq (Plus (EConst 1) (Var R)) (Var Q)))
         (P ::= (Div2 (Plus (Var Q) (Var R))) ; (If (Lt (Var N) (Mult (Var P) (Var P)))
                      (Q ::= (Var P))
                      (R ::= (Var P))))).

Theorem result : WSPEC ⊑ prgrm.
Proof.
  apply (refineTrans W1); try apply step1.
  apply (refineTrans W2); try apply step2.
  apply (refineTrans (W3a ; W3b)); try apply step3.
  apply refineSplit; try apply refineRefl.
  unfold W3b; apply refineBody.
  apply (refineTrans W4); try apply step4.
  apply (refineTrans (W5a ; W5b)); try apply step5.
  apply refineSplit; try apply refineRefl.
  unfold W5b; apply refineSplitIf; [apply step6Then | apply step6Else].
Qed.

Lemma prgrmProof : isExecutable prgrm.
Proof.
  unfold prgrm,isExecutable; simpl; auto.
Qed.

(*
Require Import String.
Compute (whileToCode prgrm prgrmProof).
*)

End Proof.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(**** Tactics Tauto and Intuition ****)

(**** Tauto:
  Tactic for automating proof in Intuionnistic Propositional Calculus, based on
  the contraction-free LJT of Dickhoff ****)

(**** Intuition:
  Simplifications of goals, based on LJT calcul ****)

(* Fails because Tauto does not perform any Apply *)
Goal (forall A : Prop, A \/ ~ A) -> forall x y : nat, x = y \/ x <> y.
Proof.
   tauto.