(* 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 cercle.
Set Implicit Arguments.
Unset Strict Implicit.

Theorem angle_inscrit :
 forall O A B C : PO,
 A <> B ->
 A <> C ->
 O <> B ->
 circonscrit O A B C ->
 double_AV (cons_AV (vec A B) (vec A C)) = cons_AV (vec O B) (vec O C).
unfold double_AV in |- *; intros O A B C H H0 H2 H4.
cut (O <> A); intros.
2: apply circonscrit_distinct3 with (2 := H4); auto.
cut (O <> C); intros.
2: apply circonscrit_distinct2 with (2 := H4); auto.
generalize (circonscrit_isocele (O:=O) (A:=A) (B:=B) (C:=C)); intros.
lapply (circonscrit_isocele (O:=O) (A:=A) (B:=B) (C:=C)); auto; intros.
unfold circonscrit in H4.
elim H4; clear H4; intros.
replace (cons_AV (vec O B) (vec O C)) with
 (plus (cons_AV (vec O B) (vec O A)) (cons_AV (vec O A) (vec O C))).
generalize (somme_triangle (A:=O) (B:=B) (C:=A)); intros.
replace (cons_AV (vec O B) (vec O A)) with
 (plus (image_angle pi)
    (opp (plus (cons_AV (vec B A) (vec B O)) (cons_AV (vec A O) (vec A B))))).
generalize (somme_triangle (A:=O) (B:=A) (C:=C)); intros.
replace (cons_AV (vec O A) (vec O C)) with
 (plus (image_angle pi)
    (opp (plus (cons_AV (vec A C) (vec A O)) (cons_AV (vec C O) (vec C A))))).
replace
 (opp (plus (cons_AV (vec B A) (vec B O)) (cons_AV (vec A O) (vec A B))))
 with
 (plus (opp (cons_AV (vec B A) (vec B O)))
    (opp (cons_AV (vec A O) (vec A B)))).
replace
 (opp (plus (cons_AV (vec A C) (vec A O)) (cons_AV (vec C O) (vec C A))))
 with
 (plus (opp (cons_AV (vec A C) (vec A O)))
    (opp (cons_AV (vec C O) (vec C A)))).
replace (cons_AV (vec A B) (vec A C)) with
 (plus (cons_AV (vec A B) (vec A O)) (cons_AV (vec A O) (vec A C))).
rewrite def_opp; auto.
rewrite def_opp; auto.
rewrite def_opp; auto.
rewrite def_opp; auto.
generalize (isocele_angles_base (A:=O) (B:=A) (C:=B)); auto; intros.
rewrite <- H10; auto.
generalize (isocele_angles_base (A:=O) (B:=C) (C:=A)); auto with geo; intros.
rewrite <- H11; auto with geo.
mesure A B A O.
mesure C A C O.
replace (pi + (x + x) + (pi + (x0 + x0))) with
 (pi + pi + (x + x + (x0 + x0))).
replace (pi + pi) with deuxpi; auto.
symmetry  in |- *.
rewrite add_mes_compatible; rewrite pi_plus_pi; rewrite <- add_mes_compatible.
replace (0 + (x + x + (x0 + x0))) with (x + x0 + (x + x0)); auto.
ring.
ring.
rewrite Chasles; auto.
rewrite <- opp_plus_plus_opp; auto.
rewrite <- opp_plus_plus_opp; auto.
rewrite <- H9; auto.
rewrite opp_plus_plus_opp; auto.
mesure A C A O.
mesure C O C A.
mesure O A O C.
replace (x1 + (x + x0) + (- x + - x0)) with x1; auto.
ring.
rewrite <- H8; auto.
rewrite opp_plus_plus_opp; auto.
mesure B A B O.
mesure A O A B.
mesure O B O A.
replace (x1 + (x + x0) + (- x + - x0)) with x1; auto.
ring.
rewrite Chasles; auto.
Qed.

Theorem angle_inscrit2 :
 forall O A B C : PO,
 A <> C ->
 B <> C ->
 O <> B ->
 circonscrit O A B C ->
 double_AV (cons_AV (vec C A) (vec C B)) = cons_AV (vec O A) (vec O B).
intros O A B C H H0 H1 H2; try assumption.
cut (O <> A); intros.
2: apply circonscrit_distinct3 with (2 := H2); auto.
apply angle_inscrit; auto.
hcercle H2.
rewrite <- H6; auto.
Qed.

Lemma circonscrit_triangle_non_point :
 forall O A B C : PO,
 triangle A B C -> circonscrit O A B C -> O <> A /\ O <> B /\ O <> C.
intros.
cut (O <> A); intros.
split; [ try assumption | idtac ].
split; [ try assumption | idtac ].
apply circonscrit_distinct1 with (2 := H0); auto.
apply circonscrit_distinct2 with (2 := H0); auto.
hcercle H0.
deroule_triangle A B C.
red in |- *; intros.
apply H6.
rewrite <- H7.
assert (distance O B = 0); auto with geo.
rewrite <- H2.
rewrite <- H7; auto with geo.
Qed.

Theorem cocyclicite :
 forall A B C D : PO,
 triangle A B C ->
 triangle A B D ->
 sont_cocycliques A B C D ->
 double_AV (cons_AV (vec C A) (vec C B)) =
 double_AV (cons_AV (vec D A) (vec D B)).
unfold sont_cocycliques in |- *; intros.
deroule_triangle A B C.
deroule_triangle A B D.
elim H1; (clear H1; (intros O; intros)).
elim H1; (clear H1; intros).
lapply (circonscrit_triangle_non_point (O:=O) (A:=A) (B:=B) (C:=C)); auto;
 intros.
lapply (circonscrit_triangle_non_point (O:=O) (A:=A) (B:=B) (C:=D)); auto;
 intros.
elim H12; (clear H12; intros).
elim H13; (clear H13; intros).
elim H11; (clear H11; intros).
elim H15; (clear H15; intros).
lapply (angle_inscrit2 (O:=O) (A:=A) (B:=B) (C:=C)); auto; intros.
lapply (angle_inscrit2 (O:=O) (A:=A) (B:=B) (C:=D)); auto; intros.
rewrite H18; auto.
try exact H1.
try exact H10.
Qed.

Theorem existence_cercle_circonscrit :
 forall A B C : PO, triangle A B C -> ex (fun O : PO => circonscrit O A B C).
intros.
deroule_triangle A B C.
soit_mediatrice A B M K.
soit_mediatrice B C J L.
lapply
 (mediatrices_triangle_concours (A:=A) (B:=B) (C:=C) (I:=M) (J:=J) (K:=K)
    (L:=L)); auto; intros.
elim (def_concours2 (A:=M) (B:=K) (C:=J) (D:=L)); auto; intros.
exists x.
apply circonscrit_permute.
unfold circonscrit in |- *.
elim H19; clear H19; intros.
split; apply mediatrice_isocele.
discrimine J x.
apply milieu_mediatrice; auto.
apply orthogonale_segment_milieu_mediatrice with J; auto.
apply ortho_sym; auto.
apply paralleles_orthogonal with (A := J) (B := L); auto.
apply alignes_paralleles; auto.
apply mediatrice_orthogonale_segment; auto.
apply milieu_mediatrice; auto.
discrimine M x.
apply mediatrice_permute.
apply milieu_mediatrice; auto.
apply mediatrice_permute.
apply orthogonale_segment_milieu_mediatrice with M; auto.
apply ortho_sym; auto.
apply paralleles_orthogonal with (A := M) (B := K); auto.
apply alignes_paralleles; auto.
apply mediatrice_orthogonale_segment; auto.
apply milieu_mediatrice; auto.
Qed.

Lemma existence_cercle_circonscrit_diametre :
 forall A B C : PO,
 triangle A B C ->
 exists O : PO,
   (exists D : PO,
      circonscrit O A B C /\
      cercle_diametre A D C /\ sont_cocycliques A B C D).
intros.
elim existence_cercle_circonscrit with (A := A) (B := B) (C := C);
 [ unfold circonscrit, isocele in |- *; intros O H0; try exact H0 | auto ].
exists O.
symetrique O A D.
exists D.
split; [ try assumption | idtac ].
applatit_and.
icercle.
exists O.
icercle.
exists O.
icercle.
Qed.

Lemma cocycliques_trivial :
 forall A B C : PO, triangle A B C -> sont_cocycliques A B C A.
icercle.
elim existence_cercle_circonscrit with (A := A) (B := B) (C := C);
 [ unfold sont_cocycliques, circonscrit, isocele in |- *; intros O H0;
    try exact H0
 | auto ].
exists O.
split; [ try assumption | idtac ].
split; [ idtac | auto ].
elim H0; intros H1 H2; try clear H0; try exact H1.
Qed.
#[export] Hint Resolve cocycliques_trivial: geo.
(* soit_circonscrit construit le centre du cercle circonscrit du triangle ABC
   et ne marche que si on a (triangle A B C) dans les hypotheses*)

Ltac soit_circonscrit A B C O :=
  elim (existence_cercle_circonscrit (A:=A) (B:=B) (C:=C));
   [ intros O; intros;
      generalize (circonscrit_triangle_non_point (O:=O) (A:=A) (B:=B) (C:=C));
      intros toto; elim toto; clear toto;
      [ intros; applatit_and | auto | auto ]
   | auto ].
(* deroule_circonscrit ne marche que si on a (cisrconscrit O A B C) dans les hypothèses*)

Ltac deroule_circonscrit A B C O :=
  elim (circonscrit_triangle_non_point (O:=O) (A:=A) (B:=B) (C:=C));
   try assumption; intro; intros toto; elim toto; clear toto;
   intros.

Lemma triangle_intersection_mediatrices :
 forall A B C B' C' O : PO,
 triangle A B C ->
 C' <> O ->
 B' <> O ->
 C' = milieu A B ->
 B' = milieu A C -> circonscrit O A B C -> ~ alignes C' O B'.
unfold circonscrit, isocele in |- *; intros.
deroule_triangle A B C.
cut (~ paralleles (droite C' O) (droite B' O)); intros.
red in |- *; intros; apply H9.
rewrite droite_permute; auto.
rewrite (droite_permute (A:=B') (B:=O)); auto.
apply alignes_paralleles; auto with geo.
apply angle_non_paralleles; auto.
elim H4; intros H10 H11; try clear H4; try exact H11.
rewrite
 (angles_droites_orthogonales (A:=A) (B:=C) (C:=A) (D:=B) (E:=B') (F:=O)
    (G:=C') (I:=O)); auto with geo.
apply ortho_sym.
apply mediatrice_orthogonale_segment; auto.
apply milieu_mediatrice; auto.
apply ortho_sym.
apply mediatrice_orthogonale_segment; auto.
apply milieu_mediatrice; auto.
Qed.

Lemma milieu_centrecirconscrit_orthogonal_segment :
 forall A B C A' O : PO,
 A' = milieu B C -> circonscrit O A B C -> orthogonal (vec O A') (vec B C).
unfold circonscrit, isocele in |- *; intros.
elim H0; intros H1 H2; try clear H0; try exact H2.
discrimine O A'.
apply ortho_sym.
replace (vec A' A') with zero; [ idtac | Ringvec ].
auto with geo.
discrimine B C.
replace (vec C C) with zero; [ auto with geo | Ringvec ].
apply mediatrice_orthogonale_segment; auto.
unfold mediatrice in |- *.
rewrite <- H1; auto.
apply milieu_mediatrice; auto.
Qed.

Axiom
  angles_orthogonal :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    double_AV (cons_AV (vec A B) (vec C D)) = image_angle pi ->
    orthogonal (vec A B) (vec C D).

Theorem tangente :
 forall A B O T : PO,
 A <> B ->
 O <> A ->
 O <> B ->
 A <> T ->
 isocele O A B ->
 orthogonal (vec A T) (vec O A) ->
 double_AV (cons_AV (vec A T) (vec A B)) = cons_AV (vec O A) (vec O B).
intros A B O T H H0 H1 H2 H3 H4; try assumption.
lapply (isocele_angles_base (A:=O) (B:=A) (C:=B)); auto; intros.
lapply (orthogonal_angles (A:=A) (B:=T) (C:=O) (D:=A)); auto; intros.
lapply (somme_triangle (A:=O) (B:=A) (C:=B)); auto; intros.
replace (cons_AV (vec O A) (vec O B)) with
 (plus (image_angle pi)
    (opp (plus (cons_AV (vec A B) (vec A O)) (cons_AV (vec B O) (vec B A))))).
replace (cons_AV (vec A T) (vec A B)) with
 (plus (cons_AV (vec A T) (vec O A)) (cons_AV (vec O A) (vec A B))).
unfold double_AV in |- *.
rewrite <- H5; auto.
replace
 (plus (plus (cons_AV (vec A T) (vec O A)) (cons_AV (vec O A) (vec A B)))
    (plus (cons_AV (vec A T) (vec O A)) (cons_AV (vec O A) (vec A B)))) with
 (plus (plus (cons_AV (vec A T) (vec O A)) (cons_AV (vec A T) (vec O A)))
    (plus (cons_AV (vec O A) (vec A B)) (cons_AV (vec O A) (vec A B)))).
replace (plus (cons_AV (vec A T) (vec O A)) (cons_AV (vec A T) (vec O A)))
 with (double_AV (cons_AV (vec A T) (vec O A))); auto.
rewrite H6; auto.
rewrite opp_plus_plus_opp; auto.
replace (cons_AV (vec O A) (vec A B)) with
 (plus (cons_AV (vec O A) (vec A O)) (cons_AV (vec A O) (vec A B)));
 auto.
rewrite <- angle_plat; auto.
rewrite def_opp; auto.
mesure A O A B.
replace (pi + (pi + x + (pi + x))) with (pi + (x + x) + (pi + pi)).
rewrite add_mes_compatible.
replace (pi + pi) with deuxpi; auto.
rewrite pi_plus_pi.
repeat rewrite <- add_mes_compatible.
replace (pi + (x + x) + 0) with (pi + (x + x)); auto.
ring.
ring.
rewrite Chasles; auto.
mesure A T O A.
mesure O A A B.
replace (x + x + (x0 + x0)) with (x + x0 + (x + x0)); auto.
ring.
rewrite Chasles; auto.
rewrite <- H7; auto.
rewrite opp_plus_plus_opp; auto.
rewrite <- H5; auto.
mesure A B A O.
mesure O A O B.
replace (x0 + (x + x) + (- x + - x)) with x0; auto.
ring.
Qed.

Theorem tangente_reciproque :
 forall A B O T T' : PO,
 A <> B ->
 O <> A ->
 O <> B ->
 A <> T' ->
 isocele O A B ->
 orthogonal (vec A T) (vec O A) ->
 double_AV (cons_AV (vec A T') (vec A B)) = cons_AV (vec O A) (vec O B) ->
 alignes A T T'.
intros A B O T T' H H0 H1 H3 H4 H5 H6; try assumption.
discrimine A T.
apply alignes_angle; auto.
unfold double_AV in |- *.
replace (cons_AV (vec A T) (vec A T')) with
 (plus (cons_AV (vec A T) (vec A B)) (cons_AV (vec A B) (vec A T')));
 auto.
replace
 (plus (plus (cons_AV (vec A T) (vec A B)) (cons_AV (vec A B) (vec A T')))
    (plus (cons_AV (vec A T) (vec A B)) (cons_AV (vec A B) (vec A T')))) with
 (plus (plus (cons_AV (vec A T) (vec A B)) (cons_AV (vec A T) (vec A B)))
    (plus (cons_AV (vec A B) (vec A T')) (cons_AV (vec A B) (vec A T'))));
 auto.
replace (plus (cons_AV (vec A B) (vec A T')) (cons_AV (vec A B) (vec A T')))
 with (cons_AV (vec O B) (vec O A)); auto.
rewrite <- (def_opp (A:=O) (B:=A) (C:=O) (D:=B)); auto.
rewrite <- (tangente (A:=A) (B:=B) (O:=O) (T:=T)); auto.
unfold double_AV in |- *.
rewrite opp_plus_plus_opp; auto.
mesure A T A B.
replace (x + x + (- x + - x)) with 0; auto.
ring.
rewrite <- (def_opp (A:=O) (B:=A) (C:=O) (D:=B)); auto.
rewrite <- H6.
unfold double_AV in |- *.
rewrite opp_plus_plus_opp; auto.
rewrite def_opp; auto.
mesure A T A B.
mesure A B A T'.
replace (x + x + (x0 + x0)) with (x + x0 + (x + x0)); auto.
ring.
rewrite Chasles; auto.
Qed.

Theorem unicite_circonscrit_triangle :
 forall A B C O O1 : PO,
 triangle A B C -> circonscrit O A B C -> circonscrit O1 A B C -> O = O1.
intros.
deroule_triangle A B C.
soit_mediatrice A B M K.
soit_mediatrice B C J L.
lapply
 (mediatrices_triangle_concours (A:=A) (B:=B) (C:=C) (I:=M) (J:=J) (K:=K)
    (L:=L)); auto; intros.
cut (M <> J); intros.
generalize H1; unfold circonscrit in |- *; intros.
generalize H0; unfold circonscrit in |- *; intros.
lapply (circonscrit_isocele (O:=O) (A:=A) (B:=B) (C:=C)); auto; intros.
lapply (circonscrit_isocele (O:=O1) (A:=A) (B:=B) (C:=C)); auto; intros.
elim H22; (clear H22; intros).
elim H23; (clear H23; intros).
lapply (milieu_mediatrice (A:=A) (B:=B) (M:=M)); auto; intros.
lapply (milieu_mediatrice (A:=B) (B:=C) (M:=J)); auto; intros.
lapply (mediatrice_droite (A:=A) (B:=B) (I:=M) (J:=K) (K:=O)); auto; intros.
lapply (mediatrice_droite (A:=B) (B:=C) (I:=J) (J:=L) (K:=O)); auto; intros.
lapply (mediatrice_droite (A:=A) (B:=B) (I:=M) (J:=K) (K:=O1)); auto; intros.
lapply (mediatrice_droite (A:=B) (B:=C) (I:=J) (J:=L) (K:=O1)); auto; intros.
cut
 (double_AV (cons_AV (vec M K) (vec J L)) =
  double_AV (cons_AV (vec B A) (vec B C))).
intros H101.
elim (classic (alignes J M L)); intros.
apply (concours_unique (A:=M) (B:=J) (A1:=K) (B1:=M) (I:=O) (J:=O1)).
red in |- *; intros; apply H2.
cut
 (double_AV (cons_AV (vec M K) (vec M J)) =
  double_AV (cons_AV (vec B A) (vec B C))); intros.
apply permute_alignes; auto.
apply alignes_angle; auto.
rewrite <- H36.
apply angle_alignes; auto.
rewrite <- H101.
halignes H34 x.
absurd (J = M); auto.
cut (vec J L = mult_PP (- x) (vec M J)); intros.
cut (vec M K = mult_PP 1 (vec M K)); intros.
apply angles_et_colinearite with (5 := H38) (6 := H37); auto.
Ringvec.
rewrite H36.
Ringvec.
auto.
apply H30; auto.
discrimine O M.
discrimine O J.
apply alignes_ordre_cycle; auto.
apply alignes_ordre_cycle; auto.
apply alignes_trans with (B := L); auto with geo.
apply H32; auto.
discrimine O1 M.
discrimine O1 J.
apply alignes_ordre_cycle; auto.
apply alignes_ordre_cycle; auto.
apply alignes_trans with (B := L); auto with geo.
apply (concours_unique (A:=J) (B:=M) (A1:=L) (B1:=K) (I:=O) (J:=O1)); auto.
red in |- *; intros; apply H34.
apply alignes_ordre_permute; auto.
discrimine O M.
discrimine O K.
apply alignes_ordre_cycle; auto with geo.
discrimine O1 M.
discrimine O1 K.
apply alignes_ordre_cycle; auto with geo.
apply angles_droites_orthogonales; auto.
cut (orthogonal (vec M K) (vec A B)); intros; auto with geo.
apply mediatrice_orthogonale_segment; auto.
apply ortho_sym; auto.
apply mediatrice_orthogonale_segment; auto.
apply deux_milieux_distincts with (2 := H11) (3 := H18); auto.
Qed.

Lemma circonscrit_mediatrice :
 forall O A B C : PO,
 circonscrit O A B C ->
 mediatrice A B O /\ mediatrice B C O /\ mediatrice A C O.
unfold circonscrit, isocele, mediatrice in |- *; intros; auto.
elim H; intros; auto.
split; [ assumption | split; [ idtac | try assumption ] ].
rewrite <- H0; auto.
Qed.
Require Export rotation_plane.

Theorem reciproque_cocyclicite :
 forall A B C D : PO,
 triangle A B C ->
 triangle A B D ->
 double_AV (cons_AV (vec C A) (vec C B)) =
 double_AV (cons_AV (vec D A) (vec D B)) -> sont_cocycliques A B C D.
unfold sont_cocycliques in |- *; intros.
deroule_triangle A B C.
deroule_triangle A B D.
soit_circonscrit A B C O2.
soit_circonscrit A B D O1.
mesure C A C B.
lapply (angle_inscrit2 (O:=O2) (A:=A) (B:=B) (C:=C)); auto; intros.
lapply (angle_inscrit2 (O:=O1) (A:=A) (B:=B) (C:=D)); auto; intros.
exists O2.
split; [ try assumption | idtac ].
unfold circonscrit in |- *.
split; [ try assumption | idtac ].
elim H10; auto.
cut (double_AV (cons_AV (vec C A) (vec C B)) <> image_angle 0);
 [ intros H50 | idtac ].
cut (O2 = O1); intros.
rewrite H21.
elim H12; auto.
soit_mediatrice A B M J.
elim (circonscrit_mediatrice (O:=O2) (A:=A) (B:=B) (C:=C)); try assumption;
 intros H60 H61.
elim H61; clear H61; intros H61 H62.
elim (circonscrit_mediatrice (O:=O1) (A:=A) (B:=B) (C:=D)); try assumption;
 intros H70 H71.
elim H71; clear H71; intros H71 H72.
lapply (mediatrice_droite (A:=A) (B:=B) (I:=M) (J:=J) (K:=O2)); auto; intros.
lapply (mediatrice_droite (A:=A) (B:=B) (I:=M) (J:=J) (K:=O1)); auto; intros.
elim (existence_rotation_Ia A M (pisurdeux + - x)); intros K; intros.
cut (A <> K); intros.
cut (alignes A K O2); intros.
cut (alignes A K O1); intros.
elim (classic (alignes A K M)); intros.
apply (concours_unique (A:=M) (B:=A) (A1:=J) (B1:=K) (I:=O2) (J:=O1)); auto.
apply orthogonal_non_alignes; auto.
lapply (mediatrice_orthogonale_segment (A:=A) (B:=B) (M:=M) (N:=J)); auto;
 intros.
elim (orthogonal_segment_milieu (A:=A) (B:=B) (C:=M) (D:=J) (I:=M)); auto;
 intros.
auto with geo.
apply ortho_sym.
apply H35; auto.
apply milieu_mediatrice; auto.
apply permute_alignes; auto.
apply permute_alignes; auto.
apply (concours_unique (A:=A) (B:=M) (A1:=K) (B1:=J) (I:=O2) (J:=O1)); auto.
assert (alignes M J O2); auto with geo.
assert (alignes M J O1); auto with geo.
discrimine K O1.
apply alignes_angle; [ auto | auto | idtac ].
unfold double_AV in |- *.
replace (cons_AV (vec A K) (vec A O1)) with
 (plus (cons_AV (vec A K) (vec A M)) (cons_AV (vec A M) (vec A O1))).
generalize (somme_triangle (A:=O1) (B:=A) (C:=B)); intros.
generalize (isocele_angles_base (A:=O1) (B:=A) (C:=B)); auto; intros.
generalize (angles_milieu (A:=O1) (B:=A) (C:=B) (I:=M)); auto; intros.
rewrite <- H36; auto.
replace
 (plus (plus (cons_AV (vec A K) (vec A M)) (cons_AV (vec A B) (vec A O1)))
    (plus (cons_AV (vec A K) (vec A M)) (cons_AV (vec A B) (vec A O1)))) with
 (plus (plus (cons_AV (vec A K) (vec A M)) (cons_AV (vec A K) (vec A M)))
    (plus (cons_AV (vec A B) (vec A O1)) (cons_AV (vec A B) (vec A O1)))).
replace (plus (cons_AV (vec A B) (vec A O1)) (cons_AV (vec A B) (vec A O1)))
 with (plus (image_angle pi) (opp (cons_AV (vec O1 A) (vec O1 B)))).
rewrite def_opp; auto.
rewrite <- (mes_oppx (A:=O1) (B:=A) (C:=O1) (D:=B) (x:=x + x)); auto.
rewrite <- (mes_oppx (A:=A) (B:=M) (C:=A) (D:=K) (x:=pisurdeux + - x)); auto.
repeat rewrite <- add_mes_compatible.
replace pi with (pisurdeux + pisurdeux); auto.
replace
 (- (pisurdeux + - x) + - (pisurdeux + - x) +
  (pisurdeux + pisurdeux + - (x + x))) with 0; auto.
ring.
elim (rotation_def (I:=A) (A:=M) (B:=K) (a:=pisurdeux + - x)); auto.
rewrite <- H20; auto.
rewrite <- H1; unfold double_AV in |- *.
rewrite <- H16.
rewrite add_mes_compatible; auto.
rewrite <- H34; auto.
rewrite <- H35; auto.
mesure A B A O1.
mesure O1 A O1 B.
replace (x1 + (x0 + x0) + - x1) with (x0 + x0); auto.
ring.
mesure A K A M.
mesure A B A O1.
replace (x0 + x0 + (x1 + x1)) with (x0 + x1 + (x0 + x1)); auto.
ring.
rewrite Chasles; auto.
discrimine K O2.
apply alignes_angle; [ auto | auto | idtac ].
unfold double_AV in |- *.
replace (cons_AV (vec A K) (vec A O2)) with
 (plus (cons_AV (vec A K) (vec A M)) (cons_AV (vec A M) (vec A O2))).
generalize (somme_triangle (A:=O2) (B:=A) (C:=B)); intros.
generalize (isocele_angles_base (A:=O2) (B:=A) (C:=B)); auto; intros.
generalize (angles_milieu (A:=O2) (B:=A) (C:=B) (I:=M)); auto; intros.
rewrite <- H35; auto.
replace
 (plus (plus (cons_AV (vec A K) (vec A M)) (cons_AV (vec A B) (vec A O2)))
    (plus (cons_AV (vec A K) (vec A M)) (cons_AV (vec A B) (vec A O2)))) with
 (plus (plus (cons_AV (vec A K) (vec A M)) (cons_AV (vec A K) (vec A M)))
    (plus (cons_AV (vec A B) (vec A O2)) (cons_AV (vec A B) (vec A O2)))).
replace (plus (cons_AV (vec A B) (vec A O2)) (cons_AV (vec A B) (vec A O2)))
 with (plus (image_angle pi) (opp (cons_AV (vec O2 A) (vec O2 B)))).
rewrite def_opp; auto.
rewrite <- (mes_oppx (A:=O2) (B:=A) (C:=O2) (D:=B) (x:=x + x)); auto.
rewrite <- (mes_oppx (A:=A) (B:=M) (C:=A) (D:=K) (x:=pisurdeux + - x)); auto.
repeat rewrite <- add_mes_compatible.
replace pi with (pisurdeux + pisurdeux); auto.
replace
 (- (pisurdeux + - x) + - (pisurdeux + - x) +
  (pisurdeux + pisurdeux + - (x + x))) with 0; auto.
ring.
elim (rotation_def (I:=A) (A:=M) (B:=K) (a:=pisurdeux + - x)); auto.
rewrite <- H19; auto.
unfold double_AV in |- *.
rewrite <- H16.
rewrite add_mes_compatible; auto.
rewrite <- H33; auto.
rewrite <- H34; auto.
mesure A B A O2.
mesure O2 A O2 B.
replace (x1 + (x0 + x0) + - x1) with (x0 + x0); auto.
ring.
mesure A K A M.
mesure A B A O2.
replace (x0 + x0 + (x1 + x1)) with (x0 + x1 + (x0 + x1)); auto.
ring.
rewrite Chasles; auto.
apply image_distinct_centre with (2 := H30); auto.
red in |- *; intros; apply H2.
apply alignes_ordre_cycle; auto.
apply alignes_angle; auto.
Qed.


(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path.
From mathcomp Require Import div choice fintype fingraph tuple finfun bigop.
From mathcomp Require Import prime binomial ssralg finset fingroup finalg zmodp.
From mathcomp Require Import matrix.
Require Import Reals.
Require Import ssr_ext ssralg_ext ssrR Reals_ext Rbigop f2 summary.
Require Import subgraph_partition tanner tanner_partition proba channel.
Require Import checksum.

(** * Technical lemmas about the summary operator *)

(** OUTLINE
- Section dprojs_comb.
- Section dproj_F2.
- Section dprojs_subgraph.
- Section dprojs_subgraph_acyclic.
- Section dprojs_subsubgraph.
- Section dprojs_subsubgraph_acyclic.
*)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope vec_ext_scope.
Local Open Scope ring_scope.

Section dprojs_comb.

Variables (n : nat) (F : finFieldType).

Implicit Types d t : 'rV[F]_n.
Implicit Types s : {set 'I_n}.
Implicit Types A : finType.

Definition dproj d s t :=
  locked (\row_(j < n) if j \in s then t ``_ j else d ``_ j).

Lemma sub_vec_dproj d t s' s : s \subset s' -> (dproj d s' t) # s = t # s.
Proof.
move=> s's.
rewrite /dproj; unlock; apply/rowP => i; rewrite !mxE; case: ifPn => //.
move/subsetP: s's => /(_ (enum_val i)); by rewrite enum_valP => ->.
Qed.

Lemma dproj_out d t s i : i \notin s -> (dproj d s t) ``_ i = d ``_i.
Proof. move=> H; by rewrite /dproj; unlock; rewrite mxE (negbTE H). Qed.

Lemma dproj_in d t s i : i \in s -> (dproj d s t) ``_ i = t ``_i.
Proof. move=> H; by rewrite /dproj; unlock; rewrite mxE H. Qed.

Lemma freeon_dproj d t s : freeon s d (dproj d s t).
Proof.
apply/forallP => n1; rewrite in_setC; apply/implyP => n1s; by rewrite dproj_out.
Qed.

Lemma dprojIdef d d' t s : dproj d s (dproj d' s t) = dproj d s t.
Proof.
apply/rowP => b; case/boolP : (b \in s) => Hb; by
  [rewrite !dproj_in | rewrite dproj_out // dproj_out].
Qed.

Lemma dproj_freeon d s t : freeon s d t -> dproj d s t = t.
Proof.
move=> /= H; apply/rowP => i; case/boolP : (i \in s) => Hb; by
  [rewrite dproj_in | rewrite dproj_out // -(freeon_notin H)].
Qed.

(* family of projections with default *)
Definition dprojs d A (g : A -> {set 'I_n}) t :=
  locked [ffun a => dproj d (g a) t].

Lemma sub_vec_dprojs d t A (g : A -> {set 'I_n}) s a :
  s \subset g a -> ((dprojs d g t) a) # s = t # s.
Proof. rewrite /dprojs; unlock => H0; by rewrite ffunE sub_vec_dproj. Qed.

Lemma freeon_dprojs d t A (g : A -> {set 'I_n}) a : freeon (g a) d ((dprojs d g t) a).
Proof. rewrite /dprojs; unlock; rewrite ffunE; by rewrite freeon_dproj. Qed.

Lemma dprojs_in d t A (g : A -> {set 'I_n}) n0 a :
  n0 \in g a -> ((dprojs d g t) a) ``_ n0 = t ``_ n0.
Proof. move=> ?; by rewrite /dprojs; unlock; rewrite ffunE dproj_in. Qed.

Lemma dprojs_out d t A (g : A -> {set 'I_n}) n0 a :
  n0 \notin g a -> ((dprojs d g t) a) ``_ n0 = d ``_n0.
Proof. move=> ?; by rewrite /dprojs; unlock; rewrite ffunE dproj_out. Qed.

(* combination of projections *)
Definition comb d A (f : {ffun A -> 'rV[F]_n}) (g : A -> {set 'I_n}) :=
  locked (\row_(j < n) (if [pick a | j \in g a] is Some a then (f a) ``_ j else d ``_ j)).

Lemma comb_in d A (f : {ffun A -> 'rV[F]_n}) (g : A -> {set 'I_n}) n1 a :
  [pick a | n1 \in g a] = Some a -> (comb d f g) ``_ n1 = (f a) ``_ n1.
Proof. by rewrite /comb; unlock; rewrite mxE => ->. Qed.

Lemma comb_out d A (f : {ffun A -> 'rV[F]_n}) (g : A -> {set 'I_n}) n1 :
  [pick a | n1 \in g a] = None-> (comb d f g) ``_ n1 = d ``_ n1.
Proof. move=> Hn1; rewrite /comb; unlock => /=; by rewrite mxE Hn1. Qed.

Lemma comb_dprojs_not_in_partition d A (g : A -> {set 'I_n}) n0 t :
  [forall a, n0 \notin g a] ->
  (comb d (dprojs d g t) g) ``_ n0 = d ``_ n0.
Proof.
move=> /forallP H0.
rewrite comb_out //.
case: pickP => // m0.
by rewrite (negbTE (H0 _)).
Qed.

Lemma comb_dprojs d A (g : A -> {set 'I_n}) t :
  (forall n0, t ``_ n0 = d ``_ n0 \/ exists a, n0 \in g a) ->
  comb d (dprojs d g t) g = t.
Proof.
move=> K.
apply/rowP => n1.
rewrite /comb; unlock => /=; rewrite mxE.
case: pickP => [/= a Ha | ]; first by rewrite dprojs_in.
move=> /= Hpred0.
case: {K}(K n1) => [ //| [a Ha]].
exfalso.
move: (Hpred0 a); by rewrite Ha.
Qed.

End dprojs_comb.

Section dproj_F2.

Variable n : nat.

Implicit Types d t : 'rV['F_2]_n.
Implicit Types s : {set 'I_n}.

Lemma checksubsum_dproj d t s s0 : (forall i, i \in s :\: s0 -> t ``_ i = d ``_ i) ->
  \delta s (dproj d s0 t) = \delta s t.
Proof.
move=> H1.
rewrite /checksubsum; congr (_ == Zp0).
apply eq_big => n1 // Hn1.
case/boolP : (n1 \in s0) => [H|H]; first by rewrite dproj_in.
by rewrite dproj_out // H1 // in_setD H.
Qed.

Lemma checksubsum_dprojD1 d n0 t s : t ``_ n0 = d ``_ n0 ->
  \delta s (dproj d (s :\ n0) t) = \delta s t.
Proof.
move=> ?; rewrite checksubsum_dproj // => n1.
by rewrite in_setD in_setD1 negb_and negbK => /andP[] /orP[/eqP -> //|/negbTE ->].
Qed.

Lemma checksubsum_dproj_freeon d s0 s t : freeon s0 d t ->
  \delta s (dproj d s0 t) = \delta s t.
Proof.
move=> Ht.
rewrite checksubsum_dproj // => i; rewrite in_setD => /andP[H1 H2].
by rewrite (freeon_notin Ht).
Qed.

End dproj_F2.

Section dprojs_subgraph.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).
Hypothesis Hconnected : forall a b, connect (tanner_rel H) a b.
Local Notation "''V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "''F(' x ',' y ')'" := (Fgraph H x y).
Local Notation "''V'" := (Vnext H).
Local Notation "''F'" := (Fnext H).

Implicit Types d t : 'rV['F_2]_n.

Definition sgraph n0 m0 := 'V(m0, n0) :\ n0.

(* family of projections; for each m1 : 'I_m, returns a projection on `V(m1, n0) :\ n0 *)
Definition dprojs_V d n0 t : {ffun 'I_m -> 'rV_n} := dprojs d (sgraph n0) t.

Lemma pfamily_dprojs_V d n0 t : dprojs d (sgraph n0) t \in
  pfamily d ('F n0) (fun m0 => [pred t | freeon (sgraph n0 m0) d t]).
Proof.
apply/pfamilyP; split.
  apply/supportP => m0 n0m0.
  apply/rowP => n1.
  rewrite dprojs_out //.
  apply: contra n0m0.
  rewrite FnextE; exact: mem_VgraphD1_Vnext.
move=> m0 m0n0; by rewrite inE (freeon_dprojs _ _ (sgraph n0)).
Qed.

Definition comb_V d n0 f := comb d f (sgraph n0).

Lemma comb_dprojs_V d i t : t ``_ i = d ``_ i -> comb_V d i (dprojs_V d i t) = t.
Proof.
move=> H0.
rewrite /comb_V /dprojs_V comb_dprojs // => n1.
case/boolP: (i == n1) => [/eqP <-|in1]; [by left | right].
move: (cover_Vgraph_part_vnode Hconnected i) => Hcover.
have : n1 \in cover (Vgraph_part_vnode H i) :\ i by rewrite Hcover !inE eq_sym in1.
rewrite in_setD1 eq_sym in1 /=.
case/bigcupP => /= s /imsetP[m1 Hm1 ->{s} Hn1]; by exists m1.
Qed.

Lemma comb_dprojs_V_not_in_partition d n0 t n1 : (forall m0, n1 \notin sgraph n0 m0) ->
  (comb_V d n0 (dprojs_V d n0 t)) ``_ n1 = d ``_ n1.
Proof.
move=> H0; rewrite /comb_V /dprojs_V comb_dprojs_not_in_partition //.
apply/forallP => m0; by rewrite H0.
Qed.

Lemma comb_V_support d (f : {ffun 'I_m -> 'rV_n}) n0 n1 (s : {set 'I_m}) :
  d.-support f \subset s ->
  ~~ [exists m0, (m0 \in s) && (n1 \in 'V(m0, n0))] ->
  (comb_V d n0 f) ``_ n1 = d ``_ n1.
Proof.
move=> H0 H1.
rewrite /comb_V /comb; unlock; rewrite mxE.
case: pickP => // m1 Hm1.
case/boolP : (m1 \in s) => m1s.
  move: H1; rewrite negb_exists => /forallP/(_ m1).
  rewrite m1s /=.
  by case/setD1P : Hm1 => _ ->.
by move/supportP : H0 => /(_ _ m1s) => ->.
Qed.

Lemma checksubsum_dprojs_V d n0 t m0 m1 :
  m1 \in 'F(m0, n0) -> t ``_ n0 = d ``_ n0 ->
  \delta ('V m1) ((dprojs_V d n0 t) m0) = \delta ('V m1) t.
Proof.
move=> Hm1 tn0dn0.
rewrite /dprojs_V /dprojs; unlock; rewrite ffunE. (* NB: really unlock? *)
rewrite checksubsum_dproj // => n2.
rewrite in_setD => /andP[].
rewrite in_setD1 negb_and negbK.
case/boolP : (n2 == n0) => [/eqP -> //|/= n2n0 Hn2 Hn2'].
move: (Fgraph_Vnext_Vgraph Hm1 Hn2' n2n0).
by rewrite (negbTE Hn2).
Qed.

Lemma freeon_comb_dprojs_V d t n0 : freeon (setT :\ n0) d (comb_V d n0 (dprojs_V d n0 t)).
Proof.
rewrite -freeon_all comb_dprojs_V_not_in_partition // => m0; by rewrite in_setD1 eqxx.
Qed.

End dprojs_subgraph.

Section dprojs_subgraph_acyclic.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).
Hypothesis Hconnected : forall a b, connect (tanner_rel H) a b.
Local Notation "''V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "''F(' x ',' y ')'" := (Fgraph H x y).
Local Notation "''V'" := (Vnext H).
Local Notation "''F'" := (Fnext H).

Implicit Types d : 'rV['F_2]_n.

Hypothesis Hacyclic : acyclic (tanner_rel H).

Lemma comb_V_in d (f : {ffun 'I_m -> 'rV_n}) n0 m0 n1 :
  n1 \in 'V(m0, n0) :\ n0 -> (comb_V H d n0 f) ``_ n1 = (f m0) ``_ n1.
Proof.
move=> Hn1; rewrite /comb_V (@comb_in _ _ _ _ f _ _ m0) //.
case: pickP => [m1 Hm1 | ].
  case/boolP : (m0 == m1) => [/eqP -> // | m0m1].
  have {Hm1}Hm1 : n1 \in 'V(m1, n0).
    move: Hm1; rewrite in_setD1; by case/andP.
  move: Hn1; rewrite in_setD1; case/andP => n1n0 Hn1.
  move: (disjoint_Vgraph Hacyclic n1n0 m0m1 Hn1); by rewrite Hm1.
move/(_ m0); by rewrite Hn1.
Qed.

Lemma dprojs_comb_V d n0 (g : 'I_n -> {set 'I_m}) (f : {ffun 'I_m -> 'rV_n}) :
  f \in pfamily d (g n0) (fun i => freeon ('V(i, n0) :\ n0) d) ->
  dprojs_V H d n0 (comb_V H d n0 f) = f.
Proof.
rewrite inE /= => /forallP => /= Hf.
apply/ffunP => /= m0.
apply/rowP => n1.
case/boolP : (n1 \in 'V( m0, n0) :\ n0) => Hn1.
  rewrite dprojs_in //.
  by rewrite (@comb_V_in _ _ _ m0) //.
rewrite dprojs_out //.
move: (Hf m0).
case: ifP => [_ | _ /eqP -> //].
rewrite inE.
by move/freeon_notin => ->.
Qed.

Local Open Scope summary_scope.
Local Open Scope R_scope.

Lemma rmul_rsum_commute0 d n0 (B : finType) (t : 'rV[B]_n)
  (W : forall m, 'rV_m -> 'rV_m -> R) (* channel *)
  (F : 'I_m -> 'rV_n -> R)
  (HF : forall m1 m0 (t' : 'rV_n), m1 \in 'F(m0, n0) -> t' ``_ n0 = d ``_ n0 -> F m1 ((dprojs_V H d n0 t') m0) = F m1 t') :
  (\rprod_(m0 in 'F n0) \rsum_(t' # 'V(m0, n0) :\ n0 , d)
    W _ (t # 'V(m0, n0) :\ n0) (t' # 'V(m0, n0) :\ n0) * (\rprod_(m1 in 'F(m0, n0)) F m1 t') =
  \rsum_(t' # setT :\ n0 , d) \rprod_(m0 in 'F n0)
    W _ (t # 'V(m0, n0) :\ n0) (t' # 'V(m0, n0) :\ n0) * (\rprod_(m1 in 'F(m0, n0)) F m1 t'))%R.
Proof.
rewrite (big_distr_big_dep d [pred x in 'F n0] (fun i => freeon ('V(i, n0) :\ n0) d)) [LHS]/=.
rewrite (reindex_onto (dprojs_V H d n0) (comb_V H d n0)); last first.
  rewrite /= => f Hf; by apply (@dprojs_comb_V d n0 (fun n => 'F n)).
rewrite [LHS]/=.
apply/esym/eq_big.
- move=> /= t'.
  case Hlhs : (freeon _ _ t').
    apply/esym.
    rewrite comb_dprojs_V => //; last first.
      by rewrite (freeon_notin Hlhs) // !inE eqxx.
    by rewrite eqxx andbT pfamily_dprojs_V.
  apply/esym/negbTE.
  move/negbT : Hlhs; apply contra.
  case/andP => _ /eqP <-.
  by rewrite freeon_comb_dprojs_V.
- move=> /= t' Ht'.
  apply eq_bigr => m0 Hm0.
  congr (_ * _)%R.
  + by rewrite /dprojs_V sub_vec_dprojs.
  + apply eq_bigr => m1 Hm1.
    by rewrite HF // -(freeon_notin Ht') //= !inE eqxx.
Qed.

End dprojs_subgraph_acyclic.

Section dprojs_subsubgraph.

Variables (m n : nat).
Variable H : 'M['F_2]_(m, n).
Local Notation "'`V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "'`F(' x ',' y ')'" := (Fgraph H x y).
Local Notation "''V'" := (Vnext H).
Local Notation "'`F'" := (Fnext H).

Implicit Types d : 'rV['F_2]_n.

Definition ssgraph m0 n0 n1 :=
  [set n2 | (n1 \in 'V m0 :\ n0) && [exists m1, (m1 \in `F n1 :\ m0) && (n2 \in `V(m1, n1))]].

(* family of projections; for each n1 : 'I_n, returns a projection on ssgraph m0 n0 n1 *)
Definition dprojs_V2 d m0 n0 t : {ffun 'I_n -> 'rV_n} := dprojs d (ssgraph m0 n0) t.

Definition comb_V2 d m0 n0 (f : {ffun 'I_n -> 'rV_n}) := comb d f (ssgraph m0 n0).

Lemma sub_vec_dprojs_V2 d m0 n0 t n1 m1 : n1 \in 'V m0 :\ n0 -> m1 \in `F n1 :\ m0 ->
  (dprojs_V2 d m0 n0 t) n1 # `V(m1, n1) :\ n1 = t # `V(m1, n1) :\ n1.
Proof.
move=> Hn1 Hm1; rewrite /dprojs_V2 sub_vec_dprojs //.
apply/subsetP => n2 Hn2.
rewrite inE /ssgraph Hn1 /=; apply/existsP; exists m1; rewrite Hm1.
by move: Hn2; rewrite in_setD1 => /andP[].
Qed.

Lemma checksubsum_dprojs_V2 d m0 n0 (t' t : 'rV_n) n1 m1 m2
  (Hn1 : n1 \in 'V m0 :\ n0) (Hm1 : m1 \in `F n1 :\ m0) (Hm2 : m2 \in `F(m1, n1)) :
  dprojs_V2 d m0 n0 t \in pfamily t' ('V m0 :\ n0)
    (fun n2 => [pred t'' | (dprojs_V H d n2 t'' \in pfamily d (`F n2 :\ m0)
                             (fun m2 => freeon (`V(m2, n2) :\ n2) d)) &&
                           (comb_V H d n2 (dprojs_V H d n2 t'') == t'')]) ->
  \delta ('V m2) ((dprojs_V H d n1 ((dprojs_V2 d m0 n0 t) n1)) m1) =
  \delta ('V m2) t.
Proof.
move=> H0; rewrite /checksubsum; congr (_ == _).
apply eq_bigr => n2 n2m2.
rewrite /dprojs_V /dprojs_V2.
case/boolP : (n2 \in `V( m1, n1) :\ n1) => [Hn2|].
  rewrite dprojs_in // dprojs_in //inE /ssgraph Hn1 /=.
  apply/existsP; exists m1; rewrite Hm1.
  by case/setD1P : Hn2.
move=> Hn2; rewrite dprojs_out //; move: Hn2.
rewrite in_setD1 negb_and negbK.
case/boolP : (n2 == n1) => [/eqP ?|/=]; last first.
  by move/(Fgraph_Vnext_Vgraph Hm2 n2m2) => ->.
subst n2 => /=.
case/pfamilyP : H0 => H0 /(_ _ Hn1).
rewrite inE => /andP[_].
move/eqP/rowP/(_ n1).
rewrite comb_dprojs_V_not_in_partition; last first.
  by move=> m3; rewrite in_setD1 eqxx.
rewrite /dprojs_V2 dprojs_in // inE Hn1 /=.
apply/existsP; exists m1; by rewrite Hm1 /= root_in_Vgraph.
Qed.

End dprojs_subsubgraph.

Section dprojs_subsubgraph_acyclic.

Variables (m n : nat).
Variable H : 'M['F_2]_(m, n).
Local Notation "'`V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "'`F(' x ',' y ')'" := (Fgraph H x y).
Local Notation "''V'" := (Vnext H).
Local Notation "'`F'" := (Fnext H).

Implicit Types d : 'rV['F_2]_n.

Hypothesis Hacyclic : acyclic (tanner_rel H).

Lemma comb_dprojs_V2_in_partition d t m0 n0 n1 :
  (exists n2, n1 \in ssgraph H m0 n0 n2) ->
  (comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t)) ``_ n1 = t ``_ n1.
Proof.
case=> n2 Hn2.
have [n2' Hn2'] : exists n2', [pick a | n1 \in ssgraph H m0 n0 a] = Some n2'.
  case: pickP Hn2 => [x Hx _ | /(_ n2) -> //]; by exists x.
rewrite (@comb_in _ _ _ _ _ _ _ n2') //.
rewrite dprojs_in; first by done.
case: pickP Hn2'.
  by move=> x hx [<-].
move=> _ ?.
by exfalso.
Qed.

Lemma comb_dprojs_V2_not_in_subgraph d t n0 m0 (m0n0 : n0 \in 'V m0) n1 :
  n1 \notin `V(m0, n0) -> (comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t)) ``_ n1 = d ``_ n1.
Proof.
move=> Hn1.
rewrite /comb_V2 comb_out //.
case: pickP => [ n2 | // ].
rewrite inE => /andP[Hn2 H0].
suff : n1 \in `V(m0, n0) by rewrite (negbTE Hn1).
case/existsP : H0 => [m1 /andP[H0 H1]].
by apply: (@Vgraph_inclusion _ _ _ Hacyclic n2 m0 n0 m1).
Qed.

Lemma comb_dprojs_V2_Vnext d t n0 m0 (m0n0 : n0 \in 'V m0) :
  (comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t)) ``_ n0 = d ``_ n0.
Proof.
rewrite /comb_V2 comb_out //.
case: pickP => [ n2 | // ].
rewrite inE => /andP[Hn2 /existsP[m1 /andP[Hm1]]].
move/(notin_Vgraph Hacyclic) : m0n0.
by move/(_ _ _ Hn2 Hm1) => /negbTE => ->.
Qed.

Lemma freeon_trans d m0 n0 (m0n0 : n0 \in 'V m0) d' t (Ht : freeon ('V m0 :\ n0) d d') :
  freeon (`V(m0, n0) :\ n0) d t ->
  freeon (`V(m0, n0) :\ n0) d' t.
Proof.
move=> Hlhs2.
apply/forallP => /= n1.
rewrite in_setC in_setD1 negb_and negbK.
apply/implyP => /orP[/eqP ->{n1}|].
  rewrite -(freeon_notin Hlhs2) ?in_setD1 ?eqxx //.
  by rewrite (freeon_notin Ht) // !inE eqxx.
move=> Hn1.
rewrite -(freeon_notin Hlhs2) ?in_setD1 ?(negbTE Hn1) ?andbF //.
rewrite (freeon_notin Ht) //.
apply: contra Hn1 => Hn1.
move/Fnext_Vnext_Vgraph : m0n0.
move/subsetP/(_ _ Hn1).
rewrite in_setD1.
by case/andP.
Qed.

Lemma comb_V2_freeon d m0 n0 (m0n0 : n0 \in 'V m0) t' t (Ht : freeon ('V m0 :\ n0) d t') :
  comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t) = t ->
  freeon (`V(m0, n0) :\ n0) t' t.
Proof.
move=> <-.
apply: (freeon_trans m0n0 Ht).
apply/forallP => /= n1.
rewrite in_setC in_setD1 negb_and negbK.
apply/implyP => /orP[/eqP ->{n1}|].
  by rewrite comb_dprojs_V2_Vnext // (freeon_notin Ht) // !inE eqxx.
move=> Hn1.
by rewrite comb_dprojs_V2_not_in_subgraph.
Qed.

Hypothesis Hconnected : forall a b, connect (tanner_rel H) a b.

Lemma dprojs_V2_pfamily d m0 n0 (m0n0 : n0 \in 'V m0) t d'
  (d'td : dproj d' ('V m0 :\ n0) t = d) (d't : freeon (`V(m0, n0) :\ n0) d' t) :
  dprojs_V2 H d m0 n0 t \in pfamily d ('V m0 :\ n0)
    (fun n1 => [pred t0 | (dprojs_V H d n1 t0
      \in pfamily d (`F n1 :\ m0) (fun m1 => freeon (`V(m1, n1) :\ n1) d)) &&
        (comb_V H d n1 (dprojs_V H d n1 t0) == t0)]).
Proof.
apply/pfamilyP; split.
  apply/supportP => n1.
  rewrite 2!inE /= negb_and negbK.
  case/orP => [ /eqP ->{n1}| m0n1].
    apply/rowP => n2 /=.
    by rewrite /dprojs_V2 dprojs_out // inE /ssgraph 2!inE eqxx.
  apply/rowP => n2 /=.
  by rewrite /dprojs_V2 dprojs_out // inE /ssgraph in_setD1 (negbTE m0n1) andbF.
move=> /= n1 Hn1.
rewrite {1}/in_mem /=.
apply/andP; split.
  apply/familyP => /= m1.
  rewrite {1}/in_mem /=.
  rewrite inE /= in_set1 /=.
  case: ifPn.
    case/andP => m1m0 m1n1.
    apply/forallP => n2.
    apply/implyP => Hn2.
    rewrite in_setC in Hn2.
    by rewrite /dprojs_V2 dprojs_out.
  rewrite negb_and negbK.
  case/orP => [ | m1n1 /=].
    move/eqP => -> {m1} /=.
    rewrite /dprojs_V /dprojs_V2.
    apply/eqP/rowP => n2.
    case/boolP : (n2 \in `V( m0, n1) :\ n1) => K; last by rewrite dprojs_out.
    rewrite dprojs_in //.
    case/boolP : (n2 \in ssgraph H m0 n0 n1) => L; last first.
      by rewrite dprojs_out.
    rewrite dprojs_in //.
    move: L; rewrite inE => /andP[L].
    case/existsP => m1 /andP[Hm1 n2m1n1].
    rewrite -d'td.
    case/boolP : (n2 \in 'V m0 :\ n0) => n2m0n0; first by rewrite dproj_in.
    rewrite dproj_out // (freeon_notin d't) //.
    rewrite in_setD1 negb_and negbK.
    rewrite /= in_setD1 negb_and negbK in n2m0n0.
    case/orP : n2m0n0 => [->// | n2m0].
    suff : n2 \notin `V(m0, n0) by move => ->; rewrite orbC.
    apply/negP.
    by apply: disjoint_Vgraph2 n2m1n1 n2m0.
  apply/eqP/rowP => n2.
  rewrite dprojs_out //.
  apply/negP.
  rewrite /= in_setD1.
  case/andP => Hn2' Hn2.
  move/negP : Hn2'; apply.
  rewrite Vgraph_set1 in Hn2.
    by rewrite in_set1 in Hn2.
  by rewrite -FnextE.
rewrite comb_dprojs_V //.
case/boolP: [exists m1, (m1 \in `F n1 :\ m0) && (n1 \in `V( m1, n1))] => X.
  rewrite /dprojs_V2 dprojs_in //; last by rewrite inE /ssgraph Hn1 X.
  by rewrite -d'td dproj_in.
by rewrite /dprojs_V2 dprojs_out // inE /ssgraph Hn1.
Qed.

Lemma comb_dprojs_V2 d m0 n0 (m0n0 : n0 \in 'V m0) d' t
  (d'td : dproj d' ('V m0 :\ n0) t = d) (d't : freeon (`V(m0, n0) :\ n0) d' t) :
  comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t) == t.
Proof.
apply/eqP/rowP => n1.
case/boolP : (n1 == n0) => [/eqP ?|n1n0].
  subst n1.
  rewrite comb_dprojs_V2_Vnext // -d'td dproj_out ?in_setD1 ?eqxx //.
  move/rowP : d'td => /(_ n0).
  by rewrite (freeon_notin d't) // in_setD1 eqxx.
case/boolP : [exists n2, n1 \in ssgraph H m0 n0 n2] => [/existsP[n2 Hn2]|].
  rewrite comb_dprojs_V2_in_partition //; by exists n2.
rewrite negb_exists => H0.
rewrite comb_out; last first.
  case: pickP => // => x.
  by move/forallP : H0 => /(_ x) /negbTE ->.
rewrite -d'td.
case/boolP : (n1 \in 'V m0 :\ n0) => K.
  by rewrite dproj_in.
rewrite dproj_out //.
move/forallP: d't => /(_ n1).
rewrite in_setC in_setD1 n1n0 /=.
have -> : n1 \notin `V(m0, n0).
  apply/negP => n1m0n0.
  rewrite in_setD1 negb_and negbK (negbTE n1n0) orFb in K.
  case: (Vgraph_decompose m0n0 n1m0n0 n1n0 K) => n2 [] Hn2 [m1 [H0' H1']].
  move/forallP in H0.
  move: (H0 n2) => /=; rewrite /ssgraph Hn2 /= inE.
  by rewrite negb_exists => /forallP/(_ m1); rewrite H0' /= H1'.
by rewrite implyTb => /eqP.
Qed.

Hypothesis tannerH_simple : simple (tanner_rel H).

Lemma comb_dprojs_V2_Vnext_dangling d m0 n0 t n1 (n1m0 : n1 \in 'V m0) :
  ~~ [exists m1, (m1 \in `F n1 :\ m0)] ->
  (comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t)) ``_ n1 = d ``_ n1.
Proof.
move=> tmp.
rewrite /comb_V2 /dprojs_V2.
rewrite /comb; unlock; rewrite mxE. (* xxx *)
case: pickP => //.
move=> n1'; rewrite inE => /andP[Hn1' /existsP[m1' Hm1']].
case/boolP : (n1 \in ssgraph H m0 n0 n1') => [|L]; last first.
  by rewrite dprojs_out.
rewrite dprojs_in; last first.
  rewrite /ssgraph Hn1' /= inE.
  apply/existsP; exists m1'; by rewrite Hm1'.
rewrite /ssgraph Hn1' /=.
case/andP: Hm1' => Hm1'.
rewrite 3!inE; case/orP => [/eqP ?|].
  subst n1'.
  move=> abs.
  rewrite inE in abs.
  exfalso.
  move/negP : tmp; apply.
  case/existsP : abs => m1 /andP[abs _].
  apply/existsP; by exists m1.
rewrite inE.
case/andP => n1'm1' /connectP [] /= p.
case/shortenP => p' Hp' Hun p'p Hlast.
exfalso.
apply (@Hacyclic [:: inl m0, inr n1', inl m1' & p'] isT).
apply: uniq_path_ucycle_extend_1 => //.
- by rewrite /= -VnextE; move: Hn1'; rewrite in_setD1 => /andP[].
- rewrite cat_path Hp' /= andbT -Hlast.
  rewrite exceptE /= andbT -VnextE n1m0 /= eq_sym.
  rewrite (path_except_neq _ Hp') // Hlast.
  destruct p' => //=; by rewrite mem_last.
- rewrite -(cat1s (inl m1')) catA cat_uniq Hun /= andbT orbF.
  rewrite inE /= negb_or.
  apply/andP; split.
    apply/eqP; case => ?; subst m1'.
    by rewrite in_setD1 eqxx in Hm1'.
  apply/negP => Hx.
  case/splitPr : Hx => p1 p2 in Hp' Hun p'p Hlast.
  rewrite last_cat /= in Hlast.
  apply (@Hacyclic [:: inl m0, inr n1', inl m1' & p1] isT).
  apply: uniq_path_ucycle_extend_1 => //.
  + by rewrite /= -VnextE; move: Hn1'; rewrite in_setD1 => /andP[].
  + rewrite -(cat1s (inl m0)) catA cat_path in Hp'; by case/andP : Hp'.
  + rewrite -(cat1s (inl m1')) -(cat1s (inl m0)) 2!catA cat_uniq in Hun; by case/andP : Hun.
Qed.

Lemma dproj_prop d m0 n0 d' t (d'd : freeon ('V m0 :\ n0) d' d)
  (Hpfamily : dprojs_V2 H d m0 n0 t
            \in pfamily d ('V m0 :\ n0)
                  (fun n1 => [pred t0 |
                   (dprojs_V H d n1 t0
                      \in pfamily d (`F n1 :\ m0)
                            (fun m1 => freeon (`V(m1, n1) :\ n1) d)) &&
                   (comb_V H d n1 (dprojs_V H d n1 t0) == t0)]))
  (Ht : comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t) = t) :
  dproj d' ('V m0 :\ n0) t == d.
Proof.
apply/eqP/rowP => n1.
case/boolP : (n1 \in 'V m0 :\ n0) => K; last first.
  by rewrite dproj_out // (freeon_notin d'd).
rewrite dproj_in //.
move: K.
rewrite /= in_setD1.
case/andP => n1n0 Hn1.
case/pfamilyP : Hpfamily => _ /(_ n1).
rewrite inE in_set1 n1n0 /= => /(_ Hn1).
rewrite {1}/in_mem /=.
case/andP => /pfamilyP[Hlhs11 Hlhs12].
rewrite /comb_V /dprojs_V /dprojs_V2.
move/eqP/(congr1 (fun x : 'rV_n => x ``_ n1)).
rewrite /comb; unlock => /=.
rewrite mxE.
case: pickP => [m1 Hm1 | _].
  by rewrite in_setD1 eqxx in Hm1.
case/boolP : (n1 \in ssgraph H m0 n0 n1) => [L|L].
  by rewrite dprojs_in.
rewrite dprojs_out //.
move: L.
rewrite /ssgraph inE negb_and in_setD1 Hn1 andbT negbK (negbTE n1n0) orFb.
move=> tmp _.
rewrite -{}Ht comb_dprojs_V2_Vnext_dangling //.
apply: contra tmp => /existsP[m1 Hm1].
apply/existsP; exists m1; rewrite Hm1 /=; exact: root_in_Vgraph.
Qed.

Lemma dprojs_V2_in d m0 n0 t n1 (Hn1 : n1 \in 'V m0 :\ n0)
  (Ht : comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t) = t) :
  ((dprojs_V2 H d m0 n0 t) n1) ``_ n1 = t ``_ n1.
Proof.
case/boolP : [exists m1, (m1 \in `F n1 :\ m0)] => [/existsP[m1 K]|K].
  rewrite /dprojs_V2 dprojs_in // inE /ssgraph Hn1 /=.
  by apply/existsP; exists m1; rewrite K root_in_Vgraph.
rewrite dprojs_out /=; last first.
  rewrite inE /ssgraph Hn1 /=.
  apply: contra K => /existsP[x /andP[Hx _]].
  by apply/existsP; exists x.
rewrite -Ht.
rewrite /comb_V2 /dprojs_V2 /= /comb; unlock; rewrite mxE. (* xxx *)
case: pickP => // n3.
rewrite inE => /andP[Hn3 /existsP[m1 /andP[Hm1 Hn1'']]].
rewrite negb_exists in K.
suff n31 : n3 = n1.
  move/forallP : K => /(_ m1).
  by rewrite -{1}n31 Hm1.
move: Hn1''.
rewrite inE in_set1 /= => /orP[/eqP //|].
rewrite 2!inE.
case/andP => m1n3 /connectP [] /= p.
case/shortenP => p' Hp' Hun pp' Hlast.
exfalso.
apply (@Hacyclic [:: inl m0, inr n3, inl m1 & p'] isT).
apply: uniq_path_ucycle_extend_1 => //.
- by rewrite /= -VnextE; move: Hn3; rewrite in_setD1 => /andP[].
- rewrite cat_path Hp' /= andbT -Hlast exceptE /= andbT -VnextE.
  move: Hn1; rewrite in_setD1 => /andP[_ -> /=].
  rewrite eq_sym (path_except_neq _ Hp') // Hlast.
  destruct p' => //=; by rewrite mem_last.
- rewrite -(cat1s (inl m1)) catA cat_uniq Hun /= andbT orbF.
  rewrite inE negb_or.
  apply/andP; split.
    apply/eqP; case => ?; subst m1.
    by rewrite in_setD1 eqxx in Hm1.
  apply/negP => Hx.
  case/splitPr : Hx => p1 p2 in Hp' Hun pp' Hlast.
  rewrite last_cat /= in Hlast.
  apply (@Hacyclic [:: inl m0, inr n3, inl m1 & p1] isT).
  apply: uniq_path_ucycle_extend_1 => //.
  + by rewrite /= -VnextE; move: Hn3; rewrite in_setD1 => /andP[].
  + rewrite -(cat1s (inl m0)) catA cat_path last_cat /= in Hp'; by case/andP : Hp'.
  + rewrite -(cat1s (inl m1)) -(cat1s (inl m0)) 2!catA cat_uniq in Hun; by case/andP : Hun.
Qed.

Local Open Scope channel_scope.
Local Open Scope proba_scope.

Lemma rprod_rsum_commute d (B : finType) (x : 'rV_n) (W: `Ch_1('F_2, B)) m0 n0 (m0n0 : n0 \in 'V m0) :
  let pr n1 t := (dprojs_V H d n1 t \in pfamily d (`F n1 :\ m0)
                   (fun m1 => freeon (`V(m1, n1) :\ n1) d)) &&
                 (comb_V H d n1 (dprojs_V H d n1 t) == t) in
  let g := dprojs_V2 H d m0 n0 in
  let g' := comb_V2 H d m0 n0 in
  (\rprod_(n1 in 'V m0 :\ n0)
    \rsum_(t | pr n1 t)
      (W (t ``_ n1) (x ``_ n1) *
         \rprod_(m1 in `F n1 :\ m0)
           W ``(x # `V(m1, n1) :\ n1 | ((dprojs_V H d n1 t) m1) # `V(m1, n1) :\ n1) *
           (\rprod_(m2 in `F(m1, n1)) INR (\delta ('V m2) ((dprojs_V H d n1 t) m1)))) =
  \rsum_(t | (g t \in pfamily d ('V m0 :\ n0) pr) && (g' (g t) == t))
    \rprod_(n1 in 'V m0 :\ n0)
       W ((g t n1) ``_ n1) (x ``_ n1) *
         (\rprod_(m1 in `F n1 :\ m0)
           W ``(x # `V(m1, n1) :\ n1 | ((dprojs_V H d n1 (g t n1)) m1) # `V(m1, n1) :\ n1) *
         (\rprod_(m2 in `F(m1, n1)) INR (\delta ('V m2) ((dprojs_V H d n1 (g t n1)) m1)))))%R.
Proof.
move=> pr g g'.
rewrite (big_distr_big_dep d) /=.
rewrite (reindex_onto (dprojs_V2 H d m0 n0) (comb_V2 H d m0 n0)) //.
move=> /= t' Ht'.
rewrite /dprojs_V2 /comb_V2.
apply/ffunP => /= n1.
apply/rowP => n2.
case/boolP : (n2 \in ssgraph H m0 n0 n1).
  rewrite inE; case/andP => Hn1 /existsP [] m1 Hm1.
  rewrite dprojs_in => /=; last first.
    rewrite /ssgraph Hn1 /= inE.
    apply/existsP; exists m1; by rewrite Hm1.
  move H0 : [pick a | n2 \in ssgraph H m0 n0 a] => [n1'|]; last first.
    case: pickP H0 => //.
    move/(_ n1); rewrite inE Hn1 /= => /negbT; rewrite negb_exists => /forallP/(_ m1).
    by rewrite Hm1.
  have ? : n1' = n1.
    case: pickP H0 => // x0.
    rewrite inE => /andP[Hn1' H0].
    move: H0 => /existsP[m1' /andP[Hm1' Hn2']].
    case/andP : Hm1 => Hm1 Hn2 [<-].
    by rewrite (Vgraph_id Hacyclic m0n0 Hn1 Hn1' Hm1 Hm1' Hn2 Hn2').
  subst n1'.
  by rewrite (@comb_in _ _ d _ t' (ssgraph H m0 n0) _ n1).
rewrite inE negb_and.
case/orP => [Hn1|].
  rewrite dprojs_out /=; last by rewrite inE negb_and Hn1.
  case/pfamilyP : Ht' => Ht' _.
  move/supportP : Ht'.
  by move/(_ n1 Hn1) => ->.
move=> tmp.
case/boolP : (n1 \in 'V m0 :\ n0) => Hn1; last first.
  rewrite dprojs_out //; last by rewrite inE /ssgraph (negbTE Hn1).
  case/pfamilyP : (Ht').
  by move/supportP => /(_ _ Hn1) ->.
case/pfamilyP : (Ht') => _ /(_ _ Hn1).
rewrite {1}/in_mem /=.
case/andP => H1 /eqP <-.
rewrite dprojs_out //; last by rewrite inE /ssgraph Hn1.
rewrite (comb_V_support _ tmp) //; by case/pfamilyP : H1.
Qed.

End dprojs_subsubgraph_acyclic.


(* ----------------------------------------------------------------- *)
(*                   Mainly classical Base module                    *)
(* ----------------------------------------------------------------- *)

From Coq Require Export RelationClasses.

From mathcomp Require Export ssreflect ssrfun ssrbool.
From mathcomp Require Export eqtype fintype ssrnat seq tuple.

Set Implicit Arguments.
Unset Strict Implicit.
Generalizable All Variables.

Axiom proof_irrelevance: forall (P: Prop) (p1 p2: P), p1 = p2.

(*

Property setoid_refl `(Setoid U): forall x, x == x.
Proof. reflexivity. Qed.
Property setoid_sym `(Setoid U): forall x y, x == y -> y == x.
Proof. symmetry. auto. Qed.
Property setoid_trans `(Setoid U): forall x y z, x == y -> y == z -> x == z.
Proof. etransitivity; eauto. Qed.

#[export]
Hint Immediate setoid_refl setoid_sym setoid_trans: core.

Axiom proof_irrelevance: forall P: Prop, forall pf pf': P, pf = pf'.

(* Setoid for leibniz equality *)

Class UsualSetoid (U:Type) := {}.

Instance usual_sum `(UsualSetoid U) `(UsualSetoid V): UsualSetoid (U + V). Qed.
Instance usual_prod `(UsualSetoid U) `(UsualSetoid V): UsualSetoid (U * V). Qed.

Instance usual_nat: UsualSetoid nat. Qed.

Instance usual_sig `(UsualSetoid U) (P: U -> Prop): UsualSetoid (sig P). Qed.

Program Instance setoid_usual `(UsualSetoid U): Setoid U := {
  equiv := eq
}.

Property usualeq_spec: forall `(UsualSetoid U) (x y: U), (x == y) = (x = y).
Proof. reflexivity. Qed.

(* Sig type - TODO: Migrate to ssreflect *)

Definition mkSig `(x: U) {P: U -> Prop} (pf: P x): {x | P x} :=
  exist P x pf.
Definition get `(pf: {x: U | P x}): U :=
  proj1_sig pf.
Definition getPr `(pf: {x: U | P x}): P (get pf) :=
  proj2_sig pf.

Property sig_eq_iff: forall U P (x y: { t: U | P t }),
  x = y <-> get x = get y.
Proof. split.
  - move=> ->. reflexivity.
  - case: x y=> [xi xp] [yi yp]. simpl.
    move: xp yp => + + E. rewrite E => xp yp.
    f_equal. apply: proof_irrelevance.
Qed.

(* Function type considered normal setoid *)

Program Instance setoid_function U `(Setoid V): Setoid (U -> V) := {
  equiv := fun f g => forall u, f u == g u }.
Next Obligation. split; red; eauto. Qed.
Add Parametric Morphism U `(Setoid V): (fun (f: U -> V) (x: U) => f x)
  with signature equiv ==> eq ==> equiv as apply_mor.
Proof. auto. Qed.

#[export]
Hint Unfold setoid_usual setoid_function: core.
#[export]
Hint Resolve usualeq_spec sig_eq_iff: core.

(* Aid on unique existence *)
Lemma unique_by_uniqueness: forall U (P: U -> Prop) u,
  P u -> uniqueness P -> unique P u.
Proof. firstorder. Qed.

(* ----------------------------------------------------------------- *)
(*                          More on Logics                           *)
(* ----------------------------------------------------------------- *)

Lemma is_true_fold: forall p: bool, (p = true) = p.
Proof. reflexivity. Qed.

Instance trans_gt : Transitive gt := flip_Transitive _.

*)


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export csubst.

Lemma cover_vars_can_test {o} :
  forall test (a b c : @NTerm o) sub,
    cover_vars (mk_can_test test a b c) sub
    <=> cover_vars a sub
        # cover_vars b sub
        # cover_vars c sub.
Proof.
  sp; repeat (rw @cover_vars_eq); simpl.
  repeat (rw remove_nvars_nil_l).
  rw app_nil_r.
  repeat (rw subvars_app_l); sp.
Qed.

Lemma cover_vars_isinl {o} :
  forall (a b c : @NTerm o) sub,
    cover_vars (mk_isinl a b c) sub
    <=> cover_vars a sub
        # cover_vars b sub
        # cover_vars c sub.
Proof.
  introv; rw @cover_vars_can_test; sp.
Qed.

Lemma cover_vars_isinr {o} :
  forall (a b c : @NTerm o) sub,
    cover_vars (mk_isinr a b c) sub
    <=> cover_vars a sub
        # cover_vars b sub
        # cover_vars c sub.
Proof.
  introv; rw @cover_vars_can_test; sp.
Qed.

Lemma cover_vars_isaxiom {o} :
  forall (a b c : @NTerm o) sub,
    cover_vars (mk_isaxiom a b c) sub
    <=> cover_vars a sub
        # cover_vars b sub
        # cover_vars c sub.
Proof.
  introv; rw @cover_vars_can_test; sp.
Qed.

Lemma lsubstc_mk_isinl_ex {o} :
  forall t1 t2 t3 sub,
  forall w  : wf_term (@mk_isinl o t1 t2 t3),
  forall c  : cover_vars (mk_isinl t1 t2 t3) sub,
  {w1 : wf_term t1
   & {w2 : wf_term t2
   & {w3 : wf_term t3
   & {c1 : cover_vars t1 sub
   & {c2 : cover_vars t2 sub
   & {c3 : cover_vars t3 sub
      & lsubstc (mk_isinl t1 t2 t3) w sub c
           = mkc_isinl (lsubstc t1 w1 sub c1)
                        (lsubstc t2 w2 sub c2)
                        (lsubstc t3 w3 sub c3)}}}}}}.
Proof.
  introv.
  dup w as w'.
  apply @wf_isinl_iff in w'; repnd.
  dup c as c'.
  apply @cover_vars_isinl in c'; repnd.
  pose proof (lsubstc_mk_can_test CanIsinl t1 t2 t3 sub w'0 w'1 w' w c'0 c'1 c' c) as h.
  inversion h as [e]; clear h; allsimpl.
  exists w'0 w'1 w' c'0 c'1 c'.
  apply cterm_eq; simpl; auto.
Qed.

Lemma lsubstc_mk_isinr_ex {o} :
  forall t1 t2 t3 sub,
  forall w  : wf_term (@mk_isinr o t1 t2 t3),
  forall c  : cover_vars (mk_isinr t1 t2 t3) sub,
  {w1 : wf_term t1
   & {w2 : wf_term t2
   & {w3 : wf_term t3
   & {c1 : cover_vars t1 sub
   & {c2 : cover_vars t2 sub
   & {c3 : cover_vars t3 sub
      & lsubstc (mk_isinr t1 t2 t3) w sub c
           = mkc_isinr (lsubstc t1 w1 sub c1)
                        (lsubstc t2 w2 sub c2)
                        (lsubstc t3 w3 sub c3)}}}}}}.
Proof.
  introv.
  dup w as w'.
  apply @wf_isinr_iff in w'; repnd.
  dup c as c'.
  apply @cover_vars_isinr in c'; repnd.
  pose proof (lsubstc_mk_can_test CanIsinr t1 t2 t3 sub w'0 w'1 w' w c'0 c'1 c' c) as h.
  inversion h as [e]; clear h; allsimpl.
  exists w'0 w'1 w' c'0 c'1 c'.
  apply cterm_eq; simpl; auto.
Qed.

(* There is another Lemma lsubstc_mk_isaxiom_ex  in subst_per.v
   but it isn't the one we need for lsubst_tac  ??  *)
Lemma lsubstc_mk_isaxiom_ex2 {o} :
  forall t1 t2 t3 sub,
  forall w  : wf_term (@mk_isaxiom o t1 t2 t3),
  forall c  : cover_vars (mk_isaxiom t1 t2 t3) sub,
  {w1 : wf_term t1
   & {w2 : wf_term t2
   & {w3 : wf_term t3
   & {c1 : cover_vars t1 sub
   & {c2 : cover_vars t2 sub
   & {c3 : cover_vars t3 sub
      & lsubstc (mk_isaxiom t1 t2 t3) w sub c
           = mkc_isaxiom (lsubstc t1 w1 sub c1)
                        (lsubstc t2 w2 sub c2)
                        (lsubstc t3 w3 sub c3)}}}}}}.
Proof.
  introv.
  dup w as w'.
  apply @wf_isaxiom in w'; repnd.
  dup c as c'.
  apply @cover_vars_isaxiom in c'; repnd.
  pose proof (lsubstc_mk_can_test CanIsaxiom t1 t2 t3 sub w'0 w'1 w' w c'0 c'1 c' c) as h.
  inversion h as [e]; clear h; allsimpl.
  exists w'0 w'1 w' c'0 c'1 c'.
  apply cterm_eq; simpl; auto.
Qed.


(*
coq-bytestring library. Copy pasted to
avoid the dependency.
http://coq.io/opam/coq-bytestring.0.9.0.html

*)

Require Coq.Strings.String.
Require Import Coq.NArith.NArith.
Require Import Coq.micromega.Lia.

Set Primitive Projections.
Set Default Proof Using "Type".

(** bytes *)

Definition byte_parse (b : Byte.byte) : Byte.byte := b.
Definition byte_print (b : Byte.byte) : Byte.byte := b.

Delimit Scope byte_scope with byte.
String Notation Byte.byte byte_parse byte_print : byte_scope.

Bind Scope byte_scope with Byte.byte.

Definition byte_cmp (a b : Byte.byte) : comparison :=
  N.compare (Byte.to_N a) (Byte.to_N b).

(** bytestrings *)
Module Bytestring.
  Inductive t : Set :=
  | EmptyString
  | String (_ : Byte.byte) (_ : t).

  Fixpoint print (b : t) : list Byte.byte :=
    match b with
    | EmptyString => nil
    | String b bs => b :: print bs
    end.

  Fixpoint parse (b : list Byte.byte) : t :=
    match b with
    | nil => EmptyString
    | List.cons b bs => String b (parse bs)
    end.

  Lemma print_parse_inv:
    forall x : Bytestring.t, Bytestring.parse (Bytestring.print x) = x.
  Proof.
    induction x; simpl; intros; auto.
    f_equal; auto.
  Qed.
End Bytestring.

Definition bs := Bytestring.t.

Declare Scope bs_scope.
Delimit Scope bs_scope with bs.
Bind Scope bs_scope with bs.

String Notation Bytestring.t Bytestring.parse Bytestring.print : bs_scope.

Import Bytestring.

Fixpoint append (x y : bs) : bs :=
  match x with
  | Bytestring.EmptyString => y
  | Bytestring.String x xs => Bytestring.String x (append xs y)
  end.

Notation "x ++ y" := (append x y) : bs_scope.

Fixpoint to_string (b : bs) : String.string :=
  match b with
  | EmptyString => String.EmptyString
  | String x xs => String.String (Ascii.ascii_of_byte x) (to_string xs)
  end.

Fixpoint of_string (b : String.string) : bs :=
  match b with
  | String.EmptyString => ""
  | String.String x xs => String (Ascii.byte_of_ascii x) (of_string xs)
  end%bs.

Fixpoint rev (acc s : bs) : bs :=
  match s with
  | EmptyString => acc
  | String s ss => rev (String s acc) ss
  end.

Fixpoint prefix (s1 s2 : bs) {struct s1} : bool :=
  match s1 with
  | EmptyString => true
  | String x xs =>
    match s2 with
    | EmptyString => false
    | String y ys =>
      if Byte.eqb x y then prefix xs ys
      else false
    end
  end%bs.

Fixpoint index (n : nat) (s1 s2 : bs) {struct s2} : option nat :=
  match s2 with
  | EmptyString =>
      match n with
      | 0 => match s1 with
             | "" => Some 0
             | String _ _ => None
             end
      | S _ => None
      end
  | String _ s2' =>
      match n with
      | 0 =>
          if prefix s1 s2
          then Some 0
          else match index 0 s1 s2' with
               | Some n0 => Some (S n0)
               | None => None
               end
      | S n' => match index n' s1 s2' with
                | Some n0 => Some (S n0)
                | None => None
                end
      end
  end%bs.

Fixpoint length (l : bs) : nat :=
  match l with
  | EmptyString => 0
  | String _ l => S (length l)
  end.

Local Fixpoint contains (start: nat) (keys: list bs) (fullname: bs) :bool :=
  match keys with
  | List.cons kh ktl =>
    match index start kh fullname with
    | Some n => contains (n + length kh) ktl fullname
    | None => false
    end
  | List.nil => true
  end.

Fixpoint eqb (a b : bs) : bool :=
  match a , b with
  | EmptyString , EmptyString => true
  | String x xs , String y ys =>
    if Byte.eqb x y then eqb xs ys else false
  | _ , _ => false
  end.

(** comparison *)
Require Import Coq.Structures.OrderedType.

Lemma to_N_inj : forall x y, Byte.to_N x = Byte.to_N y <-> x = y.
Proof.
  split.
  2: destruct 1; reflexivity.
  intros.
  assert (Some x = Some y).
  { do 2 rewrite <- Byte.of_to_N.
    destruct H. reflexivity. }
  injection H0. auto.
Qed.

Module OT_byte <: OrderedType.OrderedType with Definition t := Byte.byte.
  Definition t := Byte.byte.
  Definition eq := fun l r => byte_cmp l r = Eq.
  Definition lt := fun l r => byte_cmp l r = Lt.
  Theorem eq_refl : forall x : t, eq x x.
  Proof.
    intros; apply N.compare_refl.
  Qed.
  Theorem eq_sym : forall x y : t, eq x y -> eq y x.
  Proof.
    intros. eapply N.compare_eq in H. red. unfold byte_cmp.
    destruct H. apply eq_refl.
  Qed.
  Theorem eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof.
    intros. eapply N.compare_eq in H. eapply N.compare_eq in H0.
    red. unfold byte_cmp.
    destruct H. destruct H0. apply eq_refl.
  Qed.
  Theorem lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    unfold lt, byte_cmp.
    intros.
    rewrite N.compare_lt_iff in H.
    rewrite N.compare_lt_iff in H0.
    rewrite N.compare_lt_iff.
    etransitivity; eassumption.
  Qed.
  Theorem lt_not_eq : forall x y : t, lt x y -> not (eq x y).
  Proof.
    unfold lt, eq, byte_cmp; intros.
    rewrite N.compare_lt_iff in H.
    rewrite N.compare_eq_iff.
    lia.
  Qed.
  Definition compare (x y : t) : OrderedType.Compare lt eq x y.
    refine  (
    match byte_cmp x y as X return byte_cmp x y = X -> OrderedType.Compare lt eq x y  with
    | Eq => fun pf => OrderedType.EQ pf
    | Lt => fun pf => OrderedType.LT pf
    | Gt => fun pf => OrderedType.GT _
    end (Logic.eq_refl)).
    unfold lt, byte_cmp.
    rewrite N.compare_antisym.
    apply CompOpp_iff. apply pf.
  Defined.

  Definition eq_dec : forall x y : t, {eq x y} + {not (eq x y)}.
  refine (fun x y =>
      match byte_cmp x y as Z return byte_cmp x y = Z -> _ with
      | Eq => fun pf => left pf
      | _ => fun _ => right _
      end Logic.eq_refl).
  unfold eq. congruence.
  unfold eq. congruence.
  Defined.

End OT_byte.

Fixpoint bs_cmp (xs ys : bs) : comparison :=
  match xs , ys with
  | Bytestring.EmptyString , Bytestring.EmptyString => Eq
  | Bytestring.EmptyString , _ => Lt
  | _ , Bytestring.EmptyString => Gt
  | Bytestring.String x xs , Bytestring.String y ys =>
    match byte_cmp x y with
    | Eq => bs_cmp xs ys
    | x => x
    end
  end%bs.

Lemma byte_cmp_refl : forall a, byte_cmp a a = Eq.
Proof.
  intros. unfold byte_cmp.
  eapply N.compare_refl.
Defined.

Theorem byte_cmp_spec : forall x y, CompareSpec (x = y) (OT_byte.lt x y) (OT_byte.lt y x) (byte_cmp x y).
Proof.
  intros. unfold byte_cmp.
  unfold OT_byte.lt, byte_cmp.
  destruct (N.compare_spec (Byte.to_N x) (Byte.to_N y)); constructor; auto.
  apply to_N_inj. assumption.
Qed.

Module OT_bs <: OrderedType.OrderedType with Definition t := bs.
  Definition t := bs.
  Definition eq := @eq bs.
  Definition lt := fun l r => bs_cmp l r = Lt.

  Theorem lm : forall x y, CompareSpec (x = y) (lt x y) (lt y x) (bs_cmp x y).
  Proof.
    induction x; destruct y; simpl.
    - constructor; reflexivity.
    - constructor. reflexivity.
    - constructor. reflexivity.
    - unfold lt; simpl.
      destruct (byte_cmp_spec b b0); simpl.
      + subst. destruct (IHx y); constructor; eauto.
        congruence.
        destruct (byte_cmp_spec b0 b0); try congruence.
        red in H0. rewrite OT_byte.eq_refl in H0. congruence.
      + constructor; auto.
      + red in H. rewrite H. constructor; auto.
  Qed.

  Definition compare (x y : t) : OrderedType.Compare lt eq x y.
    refine  (
    match bs_cmp x y as X return bs_cmp x y = X -> OrderedType.Compare lt eq x y  with
    | Eq => fun pf => OrderedType.EQ _
    | Lt => fun pf => OrderedType.LT pf
    | Gt => fun pf => OrderedType.GT _
    end (Logic.eq_refl)).
    generalize (lm x y). rewrite pf. inversion 1; auto.
    generalize (lm x y). rewrite pf. inversion 1; auto.
  Defined.

  Theorem eq_refl : forall x : t, eq x x.
  Proof.
    reflexivity.
  Qed.
  Theorem eq_sym : forall x y : t, eq x y -> eq y x.
  Proof.
    eapply eq_sym.
  Qed.
  Theorem eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof.
    eapply eq_trans.
  Qed.
  Theorem lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    unfold lt.
    induction x; destruct y; simpl; try congruence.
    - destruct z; congruence.
    - destruct (byte_cmp_spec b b0); subst.
      + destruct z; auto.
        destruct (byte_cmp b0 b); auto.
        eauto.
      + destruct z; auto.
        red in H.
        destruct (byte_cmp b0 b1) eqn:?.
        * generalize (byte_cmp_spec b0 b1).
          rewrite Heqc. inversion 1.
          subst. rewrite H. auto.
        * generalize (OT_byte.lt_trans _ _ _ H Heqc). unfold OT_byte.lt.
          intro X; rewrite X. auto.
        * congruence.
      + congruence.
  Qed.
  Theorem lt_not_eq : forall x y : t, lt x y -> not (eq x y).
  Proof.
    unfold lt, eq.
    intros. intro. subst.
    induction y; simpl in *; try congruence.
    rewrite byte_cmp_refl in *. auto.
  Qed.

  Definition eq_dec : forall x y : t, {eq x y} + {not (eq x y)}.
  refine (fun x y =>
      match bs_cmp x y as Z return CompareSpec _ _ _ Z -> _ with
      | Eq => fun pf => left _
      | _ => fun _ => right _
      end (lm x y)).
  - inversion pf. apply H.
  - apply lt_not_eq. inversion c. auto.
  - inversion c. apply lt_not_eq in H.
    unfold eq in *. congruence.
  Defined.

End OT_bs.


(*  Copyright 2004 INRIA  *)
(*  $Id: zenon.v 11996 2009-03-20 01:22:58Z letouzey $  *)

Require Export Classical.

Lemma zenon_nottrue :
  (~True -> False).
Proof. tauto. Qed.

Lemma zenon_noteq : forall (T : Type) (t : T),
  ((t <> t) -> False).
Proof. tauto. Qed.

Lemma zenon_and : forall P Q : Prop,
  (P -> Q -> False) -> (P /\ Q -> False).
Proof. tauto. Qed.

Lemma zenon_or : forall P Q : Prop,
  (P -> False) -> (Q -> False) -> (P \/ Q -> False).
Proof. tauto. Qed.

Lemma zenon_imply : forall P Q : Prop,
  (~P -> False) -> (Q -> False) -> ((P -> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_equiv : forall P Q : Prop,
  (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notand : forall P Q : Prop,
  (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notor : forall P Q : Prop,
  (~P -> ~Q -> False) -> (~(P \/ Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notimply : forall P Q : Prop,
  (P -> ~Q -> False) -> (~(P -> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_notequiv : forall P Q : Prop,
  (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False).
Proof. tauto. Qed.

Lemma zenon_ex : forall (T : Type) (P : T -> Prop),
  (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False).
Proof. firstorder. Qed.

Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T),
  ((P t) -> False) -> ((forall x : T, (P x)) -> False).
Proof. firstorder. Qed.

Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T),
  (~(P t) -> False) -> (~(exists x : T, (P x)) -> False).
Proof. firstorder. Qed.

Lemma zenon_notall : forall (T : Type) (P : T -> Prop),
  (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed.

Lemma zenon_equal_base : forall (T : Type) (f : T), f = f.
Proof. auto. Qed.

Lemma zenon_equal_step :
  forall (S T : Type) (fa fb : S -> T) (a b : S),
  (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)).
Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed.

Lemma zenon_pnotp : forall P Q : Prop,
  (P = Q) -> (P -> ~Q -> False).
Proof. intros P Q Ha. rewrite Ha. auto. Qed.

Lemma zenon_notequal : forall (T : Type) (a b : T),
  (a = b) -> (a <> b -> False).
Proof. auto. Qed.

Ltac zenon_intro id :=
  intro id || let nid := fresh in (intro nid; clear nid)
.

Definition zenon_and_s := fun P Q a b => zenon_and P Q b a.
Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a.
Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a.
Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a.
Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a.
Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a.
Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a.
Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a.
Definition zenon_ex_s := fun T P a b => zenon_ex T P b a.
Definition zenon_notall_s := fun T P a b => zenon_notall T P b a.

Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b.
Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.


From Undecidability.L.Datatypes Require Import LProd LOptions LBool.
From Undecidability.L Require Import Tactics.LTactics.
From Complexity.L Require Import Datatypes.LBinNums Functions.BinNums Functions.BinNumsCompare.

Definition iterupN {X} i max x f :=
  fst (@N.peano_rect (fun _ => X*N)%type (x,i%N) (fun _ '(x,i) => (f i x,N.succ i)) (max-i)).

Lemma iterupN_eq {X} i max {x:X} f :
  iterupN i max x f = if (i <? max)%N then iterupN (N.succ i) max (f i x) f else x.
Proof.
  revert x f.
  revert i.
  refine (@N.left_induction' _ _ max _ _).
  all:intros n H.  2:intros IH. all:intros x f.
  -unfold iterupN.
   edestruct (N.ltb_spec0 n max). exfalso;Lia.lia.
   rewrite (proj2 (N.sub_0_le _ _)). 2:Lia.lia. reflexivity.
  -(* Todo:generalize over internal state*)
Admitted.

Lemma iterupN_geq {X} i max {x:X} f :
  (i >= max)%N -> iterupN i max x f = x.
Proof.
  intros. rewrite iterupN_eq. destruct (N.ltb_spec0 i max). all:easy.
Qed.

Lemma iterupN_lt {X} i max {x:X} f :
  (i < max)%N -> iterupN i max x f = iterupN (N.succ i) max (f i x) f.
Proof.
  intros H. rewrite iterupN_eq. destruct (N.ltb_spec0 i max). all:easy.
Qed.

(* Instance term_iterupN X `{H:encodable X} : *)
(*   computableTime' (iterupN (X:=X)) (fun i (_:unit) => *)
(*                                      (5,fun max (_:unit) => *)
(*                                           (1,fun x (_:unit) => *)
(*                                                (1,fun f (fT: _ -> unit -> (nat * (_ -> unit -> (nat *unit)))) => (cnst (i,x),tt))))). *)
(* Proof. *)
(*   pose (s := rho (λ F i max x f, (!!(extT N.ltb) i max) (λ _ , F (!!(extT N.succ) i) max (f i x) f) (λ _ , x) I)). *)
(*   cbv [convert TH minus] in s. *)

(*   exists s. unfold s. Intern.recRem P. *)
(*   eapply computesTimeExpStart. now Lproc. *)
(*   eexists. *)
(*   eapply computesTimeExpStep. 2:now Lsimpl. reflexivity. now Lproc. *)
(*   intros i iExt iT iExts. cbn in iExts. subst iExt. *)

(*   eexists. *)
(*   eapply computesTimeExpStep. *)
(*   2:{Intern.recStepUnnamed. now Lsimpl. } *)
(*   reflexivity. now Lproc. *)
(*   intros max yExt yT yExts. cbn in yExts. subst yExt. *)
(*   cbn [fst snd]. *)

(*   remember ((max - i)%N) as d eqn:eqd. *)
(*   revert i max eqd. *)
(*   induction d using N.peano_rect. *)
(*   all:intros i max eqd. *)
(*   all:eexists. *)
(*   all:eapply computesTimeExpStep. *)
(*   2,6:now Intern.recStepUnnamed; Lsimpl. *)
(*   1,4:reflexivity. *)
(*   1,3:Lproc. *)

(*   all:intros x xExt xT xExts. *)
(*   all:hnf in xExts; subst xExt. *)
(*   all:cbn [fst snd]. *)

(*   all:eexists. *)
(*   all:eapply computesTimeExpStep. *)
(*   2,6:now Intern.recStepUnnamed; Lsimpl. *)
(*   1,4:reflexivity. *)
(*   1,3:Lproc. *)

(*   all:intros f fExt fT fExts. *)
(*   all:change fExt with (@extT _ _ f _  (Build_computableTime' fExts)). *)
(*   2: apply f_equal with (f:=N.pred) in eqd;rewrite N.pred_succ,<- N.sub_succ_r in eqd. *)
(*   all:eexists;split. *)
(*   all:cbn [fst snd]. *)
(*   1,2:assert (N.ltb i max = false) by (apply N.ltb_ge;Lia.lia). *)
(*   1,3:eapply le_evalLe_proper;[ | reflexivity..| ]. *)
(*   2:{ Intern.recStepUnnamed. Lsimpl. Intern.extractCorrectCrush_new. congruence. } *)
(*   {rewrite H2. cbn[fst snd]. ring_simplify. admit. } *)
(*   2:{ Intern.recStepUnnamed. Lsimpl. Intern.extractCorrectCrush_new. } *)
(*   2:{ rewrite H2. rewrite iterupN_geq. easy.  Lia.lia. } *)
(*   2:{ destruct (N.ltb_spec0 i max). *)
(*       -rewrite iterupN_lt. all:easy. *)
(*       -rewrite iterupN_geq. all:easy. *)
(*   } *)
(*   recRel_prettify2. *)
(*   all:cbn [fst snd]. *)
(*     :unfold iterupN. repeat Intern.cstep. *)
(*   2,3:hnf. *)
(*   {rewrite } *)
(*   intros. *)
(*   destruct (NIntern.rexStepInit P. .ltb_spec0 i max). *)
(*   rewrite iterupN_lt. 2:easy. *)
(*   reflexivity. *)
(*   rewrite iterupN_geq. all:easy. *)
(*   Unshelve. all:now try constructor;try exact _;try eauto;try exact 0. *)
(* Qed. *)

Import HOAS_Notations.
Import N.
#[export]
Instance term_iterupN X `{H:encodable X} :
  computable (iterupN (X:=X)).
Proof.
  pose (s := rho [L_HOAS λ F i max x f, (!!(ext N.ltb) i max) (λ _ , F (!!(ext N.succ) i) max (f i x) f) (λ _ , x) !!I]).
  cbv [convert TH minus] in s.

  exists s. unfold s. Intern.recRem P.
  eapply computesExpStart. now Lproc.
  eexists.
  eapply computesExpStep. now Lreflexivity. now Lproc.
  intros i iExt iExts. cbn in iExts. subst iExt.

  eexists.
  eapply computesExpStep. Intern.recStepNew P. now Lsimpl. now Lproc.
  intros max yExt yExts. cbn in yExts. subst yExt.

  remember ((max - i)%N) as d eqn:eqd.
  revert i max eqd.
  induction d using N.peano_rect.
  all:intros i max eqd.
  all:eexists.
  all:split.
  1,3:now Intern.recStepNew P;Intern.extractCorrectCrush.

  all:eapply computesTyArr;[Lproc| intros x xExt xExts].
  all:change xExt with (@ext _ _ x (Build_computable xExts)).
  all:eexists;split.
  1,3:Intern.extractCorrectCrush.
  all:intros.

  all:eapply computesTyArr;[Lproc| intros f fExt fExts].
  all:change fExt with (@ext _ _ f (Build_computable fExts)).
  2:  apply f_equal with (f:=N.pred) in eqd;rewrite N.pred_succ,<- N.sub_succ_r in eqd.
  all:eexists;split.
  1,2:assert (N.ltb i max = false) by (apply N.ltb_ge;Lia.lia).
  1:{Intern.extractCorrectCrush. congruence. }
  {rewrite H3. rewrite iterupN_geq. 2:Lia.lia. reflexivity. }
  {Intern.extractCorrectCrush. }
  intros.
  destruct (N.ltb_spec0 i max).
  rewrite iterupN_lt. 2:easy.
  reflexivity.
  rewrite iterupN_geq. all:easy.
  Unshelve. all:now try constructor;try exact _;try eauto;try exact 0.
Qed.