(* 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 determinant.
Set Implicit Arguments.
Unset Strict Implicit.
#[export] Hint Resolve cart_def not_and_or or_not_and: geo.
Parameter vec_directeur : PP -> DR -> Prop.

Axiom
  vec_directeur_def :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    vec_directeur (vec A B) (droite C D) -> det (vec A B) (vec C D) = 0.

Axiom
  vec_directeur_def2 :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    det (vec A B) (vec C D) = 0 -> vec_directeur (vec A B) (droite C D).

Lemma vec_directeur_trivial :
 forall A B : PO, A <> B -> vec_directeur (vec A B) (droite A B).
intros.
apply vec_directeur_def2; auto.
apply determinant_colinearite with 1; auto.
Ringvec.
Qed.

Lemma existence_vec_directeur :
 forall A B : PO,
 A <> B ->
 exists C : PO, (exists D : PO, vec_directeur (vec C D) (droite A B)).
intros.
exists A; exists B.
apply vec_directeur_trivial; auto.
Qed.

Lemma vec_directeur_permute :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 vec_directeur (vec A B) (droite C D) -> vec_directeur (vec C D) (droite A B).
intros.
apply vec_directeur_def2; auto.
rewrite determinant_antisymetrique.
rewrite vec_directeur_def; auto.
ring.
Qed.

Lemma paralleles_vec_directeur :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 paralleles (droite A B) (droite C D) -> vec_directeur (vec A B) (droite C D).
intros.
apply vec_directeur_def2; auto.
elim paralleles_vecteur with (A := C) (B := D) (C := A) (D := B);
 [ intros k H3; try clear paralleles_vecteur; try exact H3
 | auto
 | auto
 | auto with geo ].
apply determinant_colinearite with k; auto.
Qed.
#[export] Hint Resolve vec_directeur_def vec_directeur_def2 cartvec_def: geo.
#[export] Hint Immediate vec_directeur_permute: geo.

Lemma vec_directeur_paralleles :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 vec_directeur (vec A B) (droite C D) -> paralleles (droite A B) (droite C D).
intros.
elim determinant_nul_colinearite with (A := C) (B := D) (C := A) (D := B);
 [ intros k H4; try clear determinant_nul_colinearite; try exact H4
 | auto
 | auto with geo ].
apply colineaires_paralleles with k; auto.
Qed.
#[export] Hint Resolve vec_directeur_paralleles paralleles_vec_directeur: geo.

Lemma vec_directeur_calcul :
 forall (A B C D : PO) (x y x0 y0 a b : R),
 A <> B ->
 C <> D ->
 x = abscisse D ->
 y = ordonnee D ->
 x0 = abscisse C ->
 y0 = ordonnee C ->
 a = absvec (vec A B) ->
 b = ordvec (vec A B) ->
 vec_directeur (vec A B) (droite C D) ->
 b * (x + - x0) + - (a * (y + - y0)) = 0.
intros A B C D x y x0 y0 a b H H0 H1 H2 H3 H4 H5 H6 H7; try assumption.
cut
 (vec C D =
  add_PP (mult_PP (x + - x0) (vec O I)) (mult_PP (y + - y0) (vec O J)));
 intros.
2: apply composantes_vecAB; eauto with geo.
cut (vec A B = add_PP (mult_PP a (vec O I)) (mult_PP b (vec O J)));
 [ intros | auto with geo ].
RReplace 0 (-0).
rewrite <- (vec_directeur_def (A:=A) (B:=B) (C:=C) (D:=D)); auto.
rewrite
 (determinant_def (A:=A) (B:=B) (C:=C) (D:=D) (x:=a) (y:=b) (x':=
    x + - x0) (y':=y + - y0)); auto.
ring.
Qed.

Lemma equation_droite_parallele :
 forall (A B C D : PO) (x y x0 y0 a b : R),
 A <> B ->
 C <> D ->
 x = abscisse D ->
 y = ordonnee D ->
 x0 = abscisse C ->
 y0 = ordonnee C ->
 a = absvec (vec A B) ->
 b = ordvec (vec A B) ->
 paralleles (droite A B) (droite C D) ->
 b * (x + - x0) + - (a * (y + - y0)) = 0.
intros.
apply vec_directeur_calcul with (1 := H) (2 := H0); auto with geo.
Qed.

Lemma alignes_equation_cartesienne :
 forall (A B M : PO) (x y : R),
 x = abscisse M ->
 y = ordonnee M ->
 A <> B ->
 alignes A B M ->
 exists a : R,
   (exists b : R,
      (exists c : R, a * x + (b * y + c) = 0 /\ ~ (a = 0 /\ b = 0))).
intros A B M x y H20 H30 H0 H1; try assumption.
cut (vec O M = add_PP (mult_PP x (vec O I)) (mult_PP y (vec O J)));
 [ intros H | auto with geo ].
elim composantes_vecteur with (O := O) (I := I) (J := J) (M := A) (N := B);
 [ intros a H2; elim H2; [ intros b H3; try clear H2; try exact H3 ]
 | auto with geo ].
elim existence_coordonnees with (O := O) (I := I) (J := J) (M := A);
 [ intros x0 H2; elim H2; [ intros y0 H4; try clear H2; try exact H4 ]
 | auto with geo ].
cut
 (vec A M =
  add_PP (mult_PP (x + - x0) (vec O I)) (mult_PP (y + - y0) (vec O J)));
 intros.
2: apply composantes_vecAB; eauto with geo.
exists (- b); exists a; exists (b * x0 + - (a * y0)).
split; [ try assumption | idtac ].
rewrite <- (alignement_determinant (A:=A) (B:=B) (M:=M)); auto.
rewrite
 (determinant_def (A:=A) (B:=B) (C:=A) (D:=M) (x:=a) (y:=b) (x':=
    x + - x0) (y':=y + - y0)); auto.
ring.
contrapose H0.
applatit_and.
apply vecteur_nul_conf.
rewrite H3.
RReplace b (- - b).
rewrite H6; rewrite H7; Ringvec.
Qed.

Lemma equation_cartesienne_alignes :
 forall (M : PO) (x y a b c : R),
 x = abscisse M ->
 y = ordonnee M ->
 ~ (a = 0 /\ b = 0) ->
 a * x + (b * y + c) = 0 ->
 exists A : _, (exists B : _, A <> B /\ alignes A B M).
intros M x y a b c H20 H30 H0 H1; try assumption.
cut (vec O M = add_PP (mult_PP x (vec O I)) (mult_PP y (vec O J)));
 [ intros H | auto with geo ].
cut (a <> 0 \/ b <> 0); intros.
elim H2; intros.
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := - c / a) (b := 0);
 [ intros A H4; try clear existence_representant_comb_lin_vecteur;
    try exact H4 ].
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := - b + - c / a) (b := a);
 [ intros B H6; try clear existence_representant_comb_lin_vecteur;
    try exact H6 ].
exists A; exists B.
cut (vec A B = add_PP (mult_PP (- b) (vec O I)) (mult_PP a (vec O J)));
 intros.
cut (A <> B); intros.
split; [ try assumption | idtac ].
apply determinant_nul_alignement; auto.
cut (vec A M = add_PP (mult_PP (x + c / a) (vec O I)) (mult_PP y (vec O J)));
 intros.
rewrite
 (determinant_def (A:=A) (B:=B) (C:=A) (D:=M) (x:=- b) (y:=a) (x':=
    x + c / a) (y':=y)); auto.
RReplace 0 (-0).
rewrite <- H1; auto.
RReplace (- b * y + - (a * (x + c / a))) (- (b * y + a * (x + c / a))).
unfold Rdiv in |- *.
RReplace (a * (x + c * / a)) (a * x + c * (a * / a)).
RReplace (a * / a) 1.
ring.
RReplace (x + c / a) (x + - (- c / a)).
RReplace y (y + -0).
apply composantes_vecAB; eauto with geo.
unfold Rdiv in |- *.
ring.
contrapose H3.
rewrite H7 in H4.
elim
 unicite_coordonnees
  with
    (O := O)
    (I := I)
    (J := J)
    (M := B)
    (x := - b + - c / a)
    (y := a)
    (x' := - c / a)
    (y' := 0);
 [ intros H9 H10; try clear unicite_coordonnees; try exact H10
 | auto with geo
 | auto
 | auto ].
RReplace (- b) (- b + - c / a + - (- c / a)).
pattern a at 3 in |- *.
RReplace a (a + -0).
apply composantes_vecAB; eauto with geo.
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := 0) (b := - c / b);
 [ intros A H4; try clear existence_representant_comb_lin_vecteur;
    try exact H4 ].
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := - b) (b := a + - c / b);
 [ intros B H6; try clear existence_representant_comb_lin_vecteur;
    try exact H6 ].
exists A; exists B.
cut (vec A B = add_PP (mult_PP (- b) (vec O I)) (mult_PP a (vec O J)));
 intros.
cut (A <> B); intros.
split; [ try assumption | idtac ].
apply determinant_nul_alignement; auto.
cut (vec A M = add_PP (mult_PP x (vec O I)) (mult_PP (y + c / b) (vec O J)));
 intros.
rewrite
 (determinant_def (A:=A) (B:=B) (C:=A) (D:=M) (x:=- b) (y:=a) (x':=x)
    (y':=y + c / b)); auto.
RReplace 0 (-0).
rewrite <- H1; auto.
RReplace (- b * (y + c / b) + - (a * x)) (- (b * (y + c / b) + a * x)).
unfold Rdiv in |- *.
RReplace (b * (y + c * / b)) (b * y + c * (b * / b)).
RReplace (b * / b) 1.
ring.
RReplace (y + c / b) (y + - (- c / b)).
RReplace x (x + -0).
apply composantes_vecAB; eauto with geo.
unfold Rdiv in |- *.
ring.
contrapose H3.
rewrite H7 in H4.
elim
 unicite_coordonnees
  with
    (O := O)
    (I := I)
    (J := J)
    (M := B)
    (x := - b)
    (y := a + - c / b)
    (x' := 0)
    (y' := - c / b);
 [ intros H9 H10; try clear unicite_coordonnees; try exact H10
 | auto with geo
 | auto
 | auto ].
RReplace 0 (-0).
rewrite <- H9; ring.
RReplace (- b) (- b + -0).
RReplace a (a + - c / b + - (- c / b)).
apply composantes_vecAB; eauto with geo.
apply not_and_or; auto.
Qed.
Parameter vec_normal : PP -> DR -> Prop.

Axiom
  vec_normal_def :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    vec_normal (vec A B) (droite C D) -> orthogonal (vec A B) (vec C D).

Axiom
  vec_normal_def2 :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    orthogonal (vec A B) (vec C D) -> vec_normal (vec A B) (droite C D).
Require Export angles_droites.
#[export] Hint Resolve vec_normal_def vec_normal_def2: geo.

Lemma existence_vec_normal :
 forall A B : PO,
 A <> B -> exists C : PO, (exists D : PO, vec_normal (vec C D) (droite A B)).
intros.
soit_orthogonal A B D.
exists A; exists D; auto with geo.
Qed.

Lemma vec_normal_permute :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 vec_normal (vec A B) (droite C D) -> vec_normal (vec C D) (droite A B).
intros.
eauto with geo.
Qed.
#[export] Hint Immediate vec_normal_permute: geo.

Lemma vec_normal_directeur_orthogonaux :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 vec_normal (vec C D) (droite A B) ->
 vec_directeur (vec E F) (droite A B) -> orthogonal (vec C D) (vec E F).
intros.
apply vec_normal_def; auto.
elim determinant_nul_colinearite with (A := A) (B := B) (C := E) (D := F);
 [ intros k H4; try clear determinant_nul_colinearite; try exact H4
 | auto
 | auto with geo ].
apply vec_normal_def2; auto.
apply ortho_sym.
rewrite H4; eauto with geo.
Qed.

Lemma vec_normal_orthogonal_directeur :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 vec_normal (vec C D) (droite A B) ->
 orthogonal (vec C D) (vec E F) -> vec_directeur (vec E F) (droite A B).
intros.
apply paralleles_vec_directeur; auto.
elim
 orthogonal_colineaires
  with (A := C) (B := D) (C := A) (D := B) (E := E) (F := F);
 [ intros k H4; try clear orthogonal_colineaires; try exact H4
 | auto
 | auto
 | auto with geo
 | auto with geo ].
apply colineaires_paralleles with k; auto.
Qed.

Lemma vec_directeur_orthogonal_normal :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 vec_directeur (vec E F) (droite A B) ->
 orthogonal (vec C D) (vec E F) -> vec_normal (vec C D) (droite A B).
intros.
apply vec_normal_def2; auto.
apply ortho_sym.
elim determinant_nul_colinearite with (A := E) (B := F) (C := A) (D := B);
 [ intros k H4; try clear determinant_nul_colinearite; try exact H4
 | auto
 | auto with geo ].
rewrite H4; auto with geo.
Qed.

Lemma paralleles_l_vec_normal :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 paralleles (droite A B) (droite E F) ->
 vec_normal (vec A B) (droite C D) -> vec_normal (vec E F) (droite C D).
intros.
elim paralleles_vecteur with (A := E) (B := F) (C := A) (D := B);
 [ intros k H4; try clear paralleles_vecteur | auto | auto | auto with geo ].
apply vec_normal_def2; auto.
rewrite H4; eauto with geo.
Qed.

Lemma vec_normal_paralleles_l :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 vec_normal (vec A B) (droite C D) ->
 vec_normal (vec E F) (droite C D) -> paralleles (droite A B) (droite E F).
intros.
elim
 orthogonal_colineaires
  with (A := C) (B := D) (C := E) (D := F) (E := A) (F := B);
 [ intros k H4; try clear orthogonal_colineaires; try exact H4
 | auto
 | auto
 | auto with geo
 | auto with geo ].
apply colineaires_paralleles with k; auto.
Qed.

Lemma vec_normal_paralleles_r :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 vec_normal (vec A B) (droite C D) ->
 vec_normal (vec A B) (droite E F) -> paralleles (droite C D) (droite E F).
intros.
elim
 orthogonal_colineaires
  with (A := A) (B := B) (C := E) (D := F) (E := C) (F := D);
 [ intros k H4; try clear orthogonal_colineaires; try exact H4
 | auto
 | auto
 | auto with geo
 | auto with geo ].
apply colineaires_paralleles with k; auto.
Qed.

Lemma paralleles_r_vec_normal :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 paralleles (droite C D) (droite E F) ->
 vec_normal (vec A B) (droite C D) -> vec_normal (vec A B) (droite E F).
intros.
elim paralleles_vecteur with (A := E) (B := F) (C := C) (D := D);
 [ intros k H4; try clear paralleles_vecteur | auto | auto | auto with geo ].
apply vec_normal_def2; auto.
apply ortho_sym.
rewrite H4; eauto with geo.
Qed.

Lemma vec_normal_calcul :
 forall (A B C D : PO) (x y x0 y0 a b : R),
 A <> B ->
 C <> D ->
 x = abscisse D ->
 y = ordonnee D ->
 x0 = abscisse C ->
 y0 = ordonnee C ->
 a = absvec (vec A B) ->
 b = ordvec (vec A B) ->
 vec_normal (vec A B) (droite C D) -> a * (x + - x0) + b * (y + - y0) = 0.
intros A B C D x y x0 y0 a b H H0 H1 H2 H3 H4 H5 H6 H7; try assumption.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 [ intros M H10 ].
elim existence_representant_vecteur with (A := O) (B := C) (C := D);
 [ intros N H20 ].
cut
 (vec C D =
  add_PP (mult_PP (x + - x0) (vec O I)) (mult_PP (y + - y0) (vec O J)));
 intros.
2: apply composantes_vecAB; eauto with geo.
cut (vec A B = add_PP (mult_PP a (vec O I)) (mult_PP b (vec O J)));
 [ intros | auto with geo ].
replace 0 with (scalaire (vec A B) (vec C D)); auto with geo.
rewrite <- H10; rewrite <- H20.
rewrite
 (scalaire_coordonnees (O:=O) (I:=I) (J:=J) (M:=M) (N:=N) (x:=a) (y:=b)
    (x':=x + - x0) (y':=y + - y0)); auto with geo.
rewrite H10; auto.
rewrite H20; auto.
Qed.

Lemma equation_droite_orthogonal :
 forall (A B C D : PO) (x y x0 y0 a b : R),
 A <> B ->
 C <> D ->
 x = abscisse D ->
 y = ordonnee D ->
 x0 = abscisse C ->
 y0 = ordonnee C ->
 a = absvec (vec A B) ->
 b = ordvec (vec A B) ->
 orthogonal (vec A B) (vec C D) -> a * (x + - x0) + b * (y + - y0) = 0.
intros.
apply vec_normal_calcul with (1 := H) (2 := H0); auto with geo.
Qed.

Lemma orthogonal_equation_cartesienne :
 forall (A B M : PO) (x y : R),
 x = abscisse M ->
 y = ordonnee M ->
 A <> B ->
 orthogonal (vec A B) (vec A M) ->
 exists a : R,
   (exists b : R,
      (exists c : R, a * x + (b * y + c) = 0 /\ ~ (a = 0 /\ b = 0))).
intros A B M x y H20 H30 H0 H1; try assumption.
cut (vec O M = add_PP (mult_PP x (vec O I)) (mult_PP y (vec O J)));
 [ intros H | auto with geo ].
elim composantes_vecteur with (O := O) (I := I) (J := J) (M := A) (N := B);
 [ intros a H2; elim H2; [ intros b H3; try clear H2; try exact H3 ]
 | auto with geo ].
elim existence_coordonnees with (O := O) (I := I) (J := J) (M := A);
 [ intros x0 H2; elim H2; [ intros y0 H4; try clear H2; try exact H4 ]
 | auto with geo ].
cut
 (vec A M =
  add_PP (mult_PP (x + - x0) (vec O I)) (mult_PP (y + - y0) (vec O J)));
 intros.
2: apply composantes_vecAB; eauto with geo.
exists a; exists b; exists (- (a * x0) + - (b * y0)).
split; [ try assumption | idtac ].
discrimine A M.
cut (x = x0 /\ y = y0); intros.
applatit_and.
rewrite H7; rewrite H8; ring.
rewrite H5 in H4.
apply unicite_composantes_vecteur with (2 := H) (3 := H4); auto with geo.
RReplace (a * x + (b * y + (- (a * x0) + - (b * y0))))
 (a * (x + - x0) + b * (y + - y0)).
apply vec_normal_calcul with (1 := H0) (2 := H5); eauto with geo.
contrapose H0.
applatit_and.
apply vecteur_nul_conf.
rewrite H3.
RReplace b (- - b).
rewrite H6; rewrite H7; Ringvec.
Qed.

Lemma equation_cartesienne_orthogonal :
 forall (M : PO) (x y a b c : R),
 x = abscisse M ->
 y = ordonnee M ->
 ~ (a = 0 /\ b = 0) ->
 a * x + (b * y + c) = 0 ->
 exists A : _, (exists B : _, A <> B /\ orthogonal (vec A B) (vec A M)).
intros M x y a b c H20 H30 H0 H1; try assumption.
cut (vec O M = add_PP (mult_PP x (vec O I)) (mult_PP y (vec O J)));
 [ intros H | auto with geo ].
cut (a <> 0 \/ b <> 0); intros.
elim H2; intros.
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := - c / a) (b := 0);
 [ intros A H4; try clear existence_representant_comb_lin_vecteur;
    try exact H4 ].
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := a + - c / a) (b := b);
 [ intros B H6; try clear existence_representant_comb_lin_vecteur;
    try exact H6 ].
exists A; exists B.
cut (vec A B = add_PP (mult_PP a (vec O I)) (mult_PP b (vec O J))); intros.
cut (A <> B); intros.
split; [ try assumption | idtac ].
cut (scalaire (vec A B) (vec A M) = 0); auto with geo.
cut (vec A M = add_PP (mult_PP (x + c / a) (vec O I)) (mult_PP y (vec O J)));
 intros.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 [ intros N H21 ].
elim existence_representant_vecteur with (A := O) (B := A) (C := M);
 [ intros P H22 ].
rewrite <- H21; rewrite <- H22.
rewrite
 (scalaire_coordonnees (O:=O) (I:=I) (J:=J) (M:=N) (N:=P) (x:=a) (y:=b)
    (x':=x + c / a) (y':=y)); auto with geo.
rewrite <- H1; auto.
unfold Rdiv in |- *.
RReplace (a * (x + c * / a)) (a * x + c * (a * / a)).
RReplace (a * / a) 1.
ring.
rewrite H21; auto.
rewrite H22; auto.
RReplace (x + c / a) (x + - (- c / a)).
RReplace y (y + -0).
apply composantes_vecAB; eauto with geo.
unfold Rdiv in |- *.
ring.
contrapose H3.
rewrite H7 in H4.
RReplace a (a + - c / a + - (- c / a)).
cut (a + - c / a = - c / a); intros.
rewrite H8.
unfold Rdiv in |- *.
ring.
elim
 unicite_coordonnees
  with
    (O := O)
    (I := I)
    (J := J)
    (M := B)
    (x := a + - c / a)
    (y := b)
    (x' := - c / a)
    (y' := 0);
 [ intros H9 H10; try clear unicite_coordonnees; try exact H9
 | auto with geo
 | auto
 | auto ].
RReplace b (b + -0).
RReplace a (a + - c / a + - (- c / a)).
apply composantes_vecAB; eauto with geo.
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := 0) (b := - c / b);
 [ intros A H4; try clear existence_representant_comb_lin_vecteur;
    try exact H4 ].
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := a) (b := b + - c / b);
 [ intros B H6; try clear existence_representant_comb_lin_vecteur;
    try exact H6 ].
exists A; exists B.
cut (vec A B = add_PP (mult_PP a (vec O I)) (mult_PP b (vec O J))); intros.
cut (A <> B); intros.
split; [ try assumption | idtac ].
cut (scalaire (vec A B) (vec A M) = 0); auto with geo.
cut (vec A M = add_PP (mult_PP x (vec O I)) (mult_PP (y + c / b) (vec O J)));
 intros.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 [ intros N H21 ].
elim existence_representant_vecteur with (A := O) (B := A) (C := M);
 [ intros P H22 ].
rewrite <- H21; rewrite <- H22.
rewrite
 (scalaire_coordonnees (O:=O) (I:=I) (J:=J) (M:=N) (N:=P) (x:=a) (y:=b)
    (x':=x) (y':=y + c / b)); auto with geo.
rewrite <- H1; auto.
unfold Rdiv in |- *.
RReplace (b * (y + c * / b)) (b * y + c * (b * / b)).
RReplace (b * / b) 1.
ring.
rewrite H21; auto.
rewrite H22; auto.
RReplace (y + c / b) (y + - (- c / b)).
RReplace x (x + -0).
apply composantes_vecAB; eauto with geo.
unfold Rdiv in |- *.
ring.
contrapose H3.
rewrite H7 in H4.
RReplace b (b + - c / b + - (- c / b)).
cut (b + - c / b = - c / b); intros.
rewrite H8.
unfold Rdiv in |- *.
ring.
elim
 unicite_coordonnees
  with
    (O := O)
    (I := I)
    (J := J)
    (M := B)
    (x := a)
    (y := b + - c / b)
    (x' := 0)
    (y' := - c / b);
 [ intros H9 H10; try clear unicite_coordonnees; try exact H10
 | auto with geo
 | auto
 | auto ].
RReplace a (a + -0).
RReplace b (b + - c / b + - (- c / b)).
apply composantes_vecAB; eauto with geo.
apply not_and_or; auto.
Qed.


Set warnings "-notation-overridden,-parsing".
Require Import Framework_common.
Require Import Framework_SOS.
Require Import multi_k.
From Coq Require Import BinNat.
From Coq Require Import omega.Omega.
From Coq Require Import Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Bool.Bool.

Lemma star_stuck_stops:
forall s conf,
 <<s>> ==>* conf -> conf = <<s>>.
 Proof.
 intros.
 inversion H. reflexivity. subst.
 inversion H0.
 Qed.

Lemma star_implies_k:
forall conf conf',
  conf ==>* conf'
  ->
  exists k,
    conf ==>[k] conf'.
Proof.
intros.
induction H.
 - exists 0. apply zero_steps_rev. reflexivity.
 - inversion IHmulti.
   exists (S x0).
   apply multikstep with y.
    + assumption.
    + assumption.
Qed.

Lemma k_implies_star:
forall conf conf' k,
  conf ==>[k] conf'
  ->
  conf ==>* conf'.
Proof.
intros.
induction H.
- apply multirefl.
- apply multistep with y.
  + assumption.
  + assumption.
Qed.

Lemma k_equiv_star:
forall conf conf',
  conf ==>* conf'
  <->
  exists k,
    conf ==>[k] conf'.
Proof.
intros. split.
- apply star_implies_k.
- intros.
  inversion H.
  apply k_implies_star with x. assumption.
Qed.

(*determinism-----------------------------*)
Lemma one_step_fin_deterministic:
forall s s' conf,
  conf ==> <<s>> ->
  conf ==> <<s'>> ->
  s = s'.
Proof.
intros.
inversion H; subst.
 - inversion H0. subst. reflexivity.
 - inversion H0. subst. reflexivity.
Qed.

Theorem conf_eq_rn_rev:
  forall S s s',
  <<S,s>> = <<S,s'>> -> s = s'.
Proof.
intros.
inversion H.
reflexivity.
Qed.

Theorem state_statement_eq:
forall S S' s s',
<<S, s>> = <<S', s'>>
-> S = S' /\ s = s'.
Proof.
intros.
inversion H.
split.
reflexivity. reflexivity.
Qed.

Theorem one_step_deterministic:
forall conf' conf'' conf,
  conf ==> conf' ->
  conf ==> conf'' ->
  conf' = conf''.
Proof.
intros c c1 c2 Hc1 Hc2.
generalize dependent c1.
induction Hc1; intros c2 Hc2.
 - (*SKIP*) inversion Hc2. reflexivity.
 - (*ASS*) inversion Hc2. subst. reflexivity.
 - (*COMPI*)inversion Hc2; subst.
    + assert (<<S1', st'>> = <<S1'0, st'0>>).
      {
        rewrite <- (IHHc1 <<S1'0, st'0>>).
        reflexivity. assumption.
      }
      inversion H. subst. reflexivity.
    + assert (<<S1', st'>> = << st'0>>).
      {
        rewrite <- (IHHc1 << st'0>>).
        reflexivity. assumption.
      }inversion H.
 - (*COMPII*)inversion Hc2; subst.
    + assert (<<S1', st'0>> = << st'>>).
      {
        rewrite <- (IHHc1 << S1', st'0>>).
        reflexivity. assumption.
      } inversion H.
    + assert (<< st'0>> = << st'>>).
      {
        rewrite <- (IHHc1 <<  st'0>>).
        reflexivity. assumption.
      } inversion H. subst. reflexivity.
- (*IF TRUE*) inversion Hc2; subst.
    + reflexivity.
    + rewrite H5 in H. inversion H.
- (*IF FALSE*) inversion Hc2; subst.
    + rewrite H5 in H. inversion H.
    + reflexivity.
- (*WHILE*)  inversion Hc2; subst.
    reflexivity.
Qed.

Lemma final_state:
forall s s',
<<s>> = <<s'>>
-> s = s'.
Proof.
intros.
inversion H.
reflexivity.
Qed.
(*
Lemma multikstep_deterministic:
forall s s' conf k,
  conf ==>[k] <<s>> ->
  conf ==>[k] <<s'>> ->
  s = s'.
Proof.
intros.
induction k.
- (*0*)
  apply zero_steps in H.
  apply zero_steps in H0.
  inversion H0. subst.
  apply final_state. assumption.
- (*s k*)
  inversion H; subst. inversion H0; subst.
  assert (y0 = y).
  { apply one_step_deterministic.
  }

Lemma multistep_deterministic:
forall s s' conf,
  conf ==>* <<s>> ->
  conf ==>* <<s'>> ->
  s = s'.
Proof.
intros.
apply star_implies_k in H.
apply star_implies_k in H0.

generalize dependent s'.
induction conf. (*; intros; inversion H0; subst.*)
-  intros. inversion H0; subst. inversion H; subst.

inversion H; subst.
- inversion H0. reflexivity. subst.
  apply star_stuck_stops in H0.
   inversion H0. reflexivity.
- apply star_implies_k in H. apply star_implies_k in H0.
  inversion H. inversion H0.
  induction x.
  induction x0.
  apply zero_steps in H3.
  apply zero_steps in H4.
  subst. apply final_state. assumption.
 induction conf; subst.
  inversion H1.
inversion s'; subst.

Qed.
*)


Require Import rt.util.all.
Require Import rt.model.jitter.task rt.model.jitter.job rt.model.jitter.schedule
               rt.model.jitter.task_arrival rt.model.jitter.interference
               rt.model.jitter.priority rt.model.jitter.platform.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module PlatformFP.

  Import Job SporadicTaskset ScheduleOfSporadicTaskWithJitter SporadicTaskset
         SporadicTaskArrival Interference Priority Platform.

  Section Lemmas.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.
    Variable job_jitter: Job -> time.

    (* Assume any job arrival sequence... *)
    Context {arr_seq: arrival_sequence Job}.

    (* Consider any schedule. *)
    Context {num_cpus: nat}.
    Variable sched: schedule num_cpus arr_seq.

    (* Assume all jobs have valid parameters, ...*)
    Hypothesis H_valid_job_parameters:
      forall (j: JobIn arr_seq),
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    Section JobInvariantAsTaskInvariant.

      (* Assume any work-conserving priority-based scheduler. *)
      Variable higher_eq_priority: FP_policy sporadic_task.
      Hypothesis H_work_conserving: work_conserving job_cost job_jitter sched.
      Hypothesis H_enforces_JLDP_policy:
        enforces_FP_policy job_cost job_task job_jitter sched higher_eq_priority.

      (* Consider task set ts. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume the task set has no duplicates, ... *)
      Hypothesis H_ts_is_a_set: uniq ts.
      (* ... and all jobs come from the taskset. *)
      Hypothesis H_all_jobs_from_taskset:
        forall (j: JobIn arr_seq), job_task j \in ts.

      (* Suppose that jobs are sequential, ...*)
      Hypothesis H_sequential_jobs: sequential_jobs sched.
      (* ... jobs only execute after the jitter, ... *)
      Hypothesis H_jobs_execute_after_jitter:
        jobs_execute_after_jitter job_jitter sched.
      (* ... and jobs do not execute after completion. *)
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.

      (* Assume that the schedule satisfies the sporadic task model ...*)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period arr_seq job_task.

      (* Consider a valid task tsk, ...*)
      Variable tsk: sporadic_task.
      Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

      (*... whose job j ... *)
      Variable j: JobIn arr_seq.
      Variable H_job_of_tsk: job_task j = tsk.

      (*... is backlogged at time t <= job_arrival j + task_period tsk. *)
      Variable t: time.
      Hypothesis H_j_backlogged: backlogged job_cost job_jitter sched j t.
      Hypothesis H_t_before_period: t < job_arrival j + task_period tsk.

      Let can_interfere_with_tsk := fp_can_interfere_with higher_eq_priority tsk.

      (* Assume that any jobs of higher-priority tasks complete by their period. *)
      Hypothesis H_all_previous_jobs_completed :
        forall (j_other: JobIn arr_seq) tsk_other,
          job_task j_other = tsk_other ->
          can_interfere_with_tsk tsk_other ->
          completed job_cost sched j_other (job_arrival j_other + task_period tsk_other).

      (* Assume that any jobs of tsk prior to j complete by their period. *)
      Hypothesis H_all_previous_jobs_of_tsk_completed :
        forall j0 : JobIn arr_seq,
          job_task j0 = tsk ->
          job_arrival j0 < job_arrival j ->
          completed job_cost sched j0 (job_arrival j0 + task_period tsk).

      Definition scheduled_task_with_higher_eq_priority (tsk tsk_other: sporadic_task) :=
        task_is_scheduled job_task sched tsk_other t &&
        can_interfere_with_tsk tsk_other.

      (* Then, there can be at most one pending job of higher-priority tasks at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_interfering_tasks :
          forall j1 j2,
            pending job_cost job_jitter sched j1 t ->
            pending job_cost job_jitter sched j2 t ->
            job_task j1 = job_task j2 ->
            can_interfere_with_tsk (job_task j1) ->
            j1 = j2.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO, H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV.
        intros j1 j2 PENDING1 PENDING2 SAMEtsk INTERF.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
        destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
        {
          specialize (SPO j1 j2 DIFF SAMEtsk BEFORE1).
          assert (LEt: job_arrival j1 + task_period (job_task j1) <= t).
          {
            apply leq_trans with (n := job_arrival j2); first by done.
            by apply leq_trans with (n := job_arrival j2 + job_jitter j2); first by apply leq_addr.
          }
          exploit (PREV j1 (job_task j1)); [by done | by apply INTERF | intros COMP1].
          apply NOTCOMP1.
          by apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1)).
        }
        {
          apply ltnW in BEFORE2.
          exploit (SPO j2 j1); [by red; ins; subst j2 | by rewrite SAMEtsk | by done | intro SPO'].
          assert (LEt: job_arrival j2 + task_period (job_task j2) <= t).
          {
            apply leq_trans with (n := job_arrival j1); first by done.
            by apply leq_trans with (n := job_arrival j1 + job_jitter j1); first by apply leq_addr.
          }
          exploit (PREV j2 (job_task j2));
            [by done | by rewrite -SAMEtsk | intro COMP2 ].
          apply NOTCOMP2.
          by apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2)).
        }
      Qed.

      (* Also, there can be at most one pending job of tsk at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_tsk :
          forall j',
            pending job_cost job_jitter sched j' t ->
            job_task j' = tsk ->
            j' = j.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO,
               H_valid_task into PARAMS,
               H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV,
               H_j_backlogged into BACK, H_job_of_tsk into JOBtsk.
        intros j' PENDING' SAMEtsk.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: BACK PENDING' => /andP [/andP [ARRIVED /negP NOTCOMP] NOTSCHED]
                               /andP [ARRIVED' /negP NOTCOMP'].
        destruct (leqP (job_arrival j') (job_arrival j)) as [BEFORE | BEFORE'].
        {
          exploit (SPO j' j DIFF); [by rewrite JOBtsk | by done | intro SPO'].
          assert (LEt: job_arrival j' + task_period tsk <= t).
          {
            apply leq_trans with (n := job_arrival j); first by rewrite -SAMEtsk.
            by apply leq_trans with (n := job_arrival j + job_jitter j); first by apply leq_addr.
          }
          apply NOTCOMP'.
          apply completion_monotonic with (t0 := job_arrival j' + task_period tsk); [by done | by done |].
          apply PREVtsk; first by done.
          apply leq_trans with (n := job_arrival j' + task_period tsk); last by rewrite -SAMEtsk.
          rewrite -addn1; apply leq_add; first by done.
          by unfold is_valid_sporadic_task in *; des.
        }
        {
          unfold jitter_has_passed, actual_arrival in *.
          rewrite leqNgt in ARRIVED'; move: ARRIVED' => /negP BUG; apply BUG.
          apply leq_trans with (n := job_arrival j'); last by apply leq_addr.
          apply leq_trans with (n := job_arrival j + task_period tsk); first by done.
          by rewrite -JOBtsk; apply SPO;
            [by red; ins; subst j' | by rewrite SAMEtsk | by apply ltnW].
        }
      Qed.

      (* Therefore, all processors are busy with tasks other than tsk. *)
      Lemma platform_fp_cpus_busy_with_interfering_tasks :
        count (scheduled_task_with_higher_eq_priority tsk) ts = num_cpus.
      Proof.
        have UNIQ := platform_fp_no_multiple_jobs_of_interfering_tasks.
        have UNIQ' := platform_fp_no_multiple_jobs_of_tsk.
        rename H_all_jobs_from_taskset into FROMTS,
               H_sequential_jobs into SEQUENTIAL,
               H_work_conserving into WORK,
               H_enforces_JLDP_policy into PRIO,
               H_j_backlogged into BACK,
               H_job_of_tsk into JOBtsk,
               H_sporadic_tasks into SPO,
               H_valid_job_parameters into JOBPARAMS,
               H_valid_task into TASKPARAMS,
               H_all_previous_jobs_completed into PREV,
               H_completed_jobs_dont_execute into COMP,
               H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_jobs_execute_after_jitter into JITTER.
        apply work_conserving_eq_work_conserving_count in WORK.
        unfold valid_sporadic_job, valid_realtime_job,
               enforces_FP_policy, enforces_JLDP_policy, FP_to_JLDP,
               task_precedence_constraints, completed_jobs_dont_execute,
               sporadic_task_model, is_valid_sporadic_task,
               jobs_of_same_task_dont_execute_in_parallel,
               sequential_jobs,
               can_interfere_with_tsk in *.
        apply/eqP; rewrite eqn_leq; apply/andP; split.
        {
          apply leq_trans with (n := count (fun x => task_is_scheduled job_task sched x t) ts);
            first by apply sub_count; red; move => x /andP [SCHED _].
          unfold task_is_scheduled.
          apply count_exists; first by done.
          {
            intros cpu x1 x2 SCHED1 SCHED2.
            destruct (sched cpu t); last by done.
            move: SCHED1 SCHED2 => /eqP SCHED1 /eqP SCHED2.
            by rewrite -SCHED1 -SCHED2.
          }
        }
        {
          rewrite -(WORK j t) // -count_predT.
          apply leq_trans with (n := count (fun j: JobIn arr_seq =>
            scheduled_task_with_higher_eq_priority tsk (job_task j)) (jobs_scheduled_at sched t));
            last first.
          {
            rewrite -count_map.
            apply leq_trans with (n := count predT [seq x <- (map (fun (j: JobIn arr_seq) => job_task j) (jobs_scheduled_at sched t)) | scheduled_task_with_higher_eq_priority tsk x]);
              first  by rewrite count_filter; apply sub_count; red; ins.
            apply leq_trans with (n := count predT [seq x <- ts | scheduled_task_with_higher_eq_priority tsk x]);
              last by rewrite count_predT size_filter.
            apply count_sub_uniqr;
              last first.
            {
              red; intros tsk' IN'.
              rewrite mem_filter in IN'; move: IN' => /andP [SCHED IN'].
              rewrite mem_filter; apply/andP; split; first by done.
              by move: IN' => /mapP [j' _] ->; apply FROMTS.
            }
            {
              rewrite filter_map.
              rewrite map_inj_in_uniq; first by apply filter_uniq, scheduled_jobs_uniq.
              red; intros j1 j2 SCHED1 SCHED2 SAMEtsk.
              rewrite 2!mem_filter in SCHED1 SCHED2.
              move: SCHED1 SCHED2 => /andP [/andP [_ HP1] SCHED1] /andP [/andP [_ HP2] SCHED2].
              rewrite 2!mem_scheduled_jobs_eq_scheduled in SCHED1 SCHED2.
              apply scheduled_implies_pending with (job_cost0 := job_cost)
                      (job_jitter0 := job_jitter) in SCHED1; try (by done).
              apply scheduled_implies_pending with (job_cost0 := job_cost)
                      (job_jitter0 := job_jitter) in SCHED2; try (by done).
              by apply UNIQ.
            }
          }
          {
            apply sub_in_count; intros j' SCHED' _.
            rewrite mem_scheduled_jobs_eq_scheduled in SCHED'.
            apply/andP; split.
            {
              move: SCHED' => /existsP [cpu /eqP SCHED'].
              by apply/existsP; exists cpu; rewrite /task_scheduled_on SCHED' eq_refl.
            }
            apply/andP; split; first by rewrite -JOBtsk; apply PRIO with (t := t).
            {
              apply/eqP; red; intro SAMEtsk.
              generalize SCHED'; intro PENDING'.
              apply scheduled_implies_pending with (job_cost0 := job_cost)
                    (job_jitter0 := job_jitter) in PENDING'; try (by done).
              specialize (UNIQ' j' PENDING' SAMEtsk); subst j'.
              by move: BACK => /andP [_ NOTSCHED]; rewrite SCHED' in NOTSCHED.
            }
          }
        }
      Qed.

    End JobInvariantAsTaskInvariant.

  End Lemmas.

End PlatformFP.


Require Import List ZArith Uint63 String OrderedType OrderedTypeEx FMapAVL.
Require Import FMapFacts.
Require Import Lia  Wellfounded  PArray.
Import ListNotations.

Require Import bfs.

(* We are going to generated huge lists of integers, for which  *)
(* the default length function provided in the list module is   *)
(* inadequate.  We reimplement a length function that computes  *)
(* in a tail recursive fashion, and produced a number of        *)
(* type Z.                                                      *)
Definition tlength {A : Type}(l : list A) :=
  (fix f (l : list A) (acc : Z) : Z :=
     match l with nil => acc | _ :: tl => f tl (acc + 1)%Z end) l 0%Z.

(* Preparatory work to use the predefined module for AVL        *)
(* tables.                                                      *)

Module int_as_OT <: UsualOrderedType.

Definition t := int.

Definition lt (x y : t) := (to_Z x < to_Z y)%Z.

Definition eq := @Logic.eq t.

Definition eq_refl := @Logic.eq_refl t.

Definition eq_sym := @Logic.eq_sym t.

Definition eq_trans := @Logic.eq_trans t.

Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof.
intros x y z; apply Z.lt_trans.
Qed.

Lemma lt_not_eq : forall x y : t, lt x y -> x <> y.
Proof.
intros x y xlty xy.
rewrite xy in xlty.
now apply Z.lt_irrefl in xlty.
Qed.

Lemma compare_eq (x y : int) :
   (to_Z x ?= to_Z y)%Z = Eq -> eq x y.
Proof.
intros cmp; apply Z.compare_eq in cmp.
now rewrite <- (of_to_Z x), <- (of_to_Z y), cmp.
Qed.

Lemma compare_lt (x y : int) :
  (to_Z x ?= to_Z y)%Z = Lt -> lt x y.
Proof.
now rewrite Z.compare_lt_iff.
Qed.

Lemma compare_gt (x y : int) :
  (to_Z x ?= to_Z y)%Z = Gt -> lt y x.
Proof.
now rewrite Z.compare_gt_iff.
Qed.

Definition compare (x y : t) : OrderedType.Compare lt eq x y.
destruct (to_Z x ?= to_Z y)%Z eqn:cmp.
- apply OrderedType.EQ.
  now apply compare_eq.
- apply OrderedType.LT.
  now apply compare_lt.
- apply OrderedType.GT.
  now apply compare_gt.
Defined.

Lemma eq_Z_to_eq_int (x y : t) : to_Z x = to_Z y -> x = y.
Proof.
now intros cmp; rewrite <- (of_to_Z x), <- (of_to_Z y), cmp.
Qed.

Lemma not_eq_Z_to_not_eq_int (x y : t) : to_Z x <> to_Z y -> x <> y.
Proof.
now intros cmp xeqy; case cmp; rewrite xeqy.
Qed.

Lemma eq_dec : forall x y : t, {x = y}+{x <> y}.
Proof.
intros x y; case (Z.eq_dec (to_Z x) (to_Z y)); intros cmp.
- left.
  now apply eq_Z_to_eq_int.
- right.
  now apply not_eq_Z_to_not_eq_int.
Defined.

End int_as_OT.

Module intmap := FMapAVL.Make int_as_OT.
Module facts := FMapFacts.OrdProperties intmap.

Arguments intmap.find _ (_)%uint63 _.
Arguments intmap.add _ (_)%uint63 _ _.

(* Preparatory work to use the bfs and bfs_aux functions        *)
Definition empty : intmap.t int := intmap.empty _.

Definition bfs_find : intmap.t int -> int -> option int :=
  fun m k => intmap.find k m.

Definition bfs_add : intmap.t int -> int -> int -> intmap.t int :=
  fun m k v => intmap.add k v m.

(* The following code is taken from Laurent Thery : puzzle_cube repository *)

Open Scope uint63_scope.

(* The number of bits for the board *)
Definition size_board := 4.
Definition nsize_board := 4%nat.
Definition size_board2 := size_board * size_board.

(* The number of bits for the position *)
Definition size_position := 4.
Definition size_board2_position := size_board2 + size_position.

(* Tne number of bits for the cube *)
Definition size_cube := 6.
Definition size_all := size_cube + size_board2_position.

Definition mask_all := (1 << size_all) -1.

Definition mask_board := (1 << size_board2) -1.
Definition clean_board := mask_all lxor mask_board.
Definition get_board s := (s land mask_board).
Definition set_board s i := (s land clean_board) lor i.

Fixpoint mk_string n s :=
  match n with 0 => ""%string | S n1 => append s (mk_string n1 s) end.

Fixpoint print_line s n :=
  match n with
  | 0 => ""%string
  | S n1 => if (is_zero (s land 1)) then
              append " "%string (print_line (s >> 1) n1)
            else
              append "X"%string (print_line (s >> 1) n1)
    end.

Definition string_return := "
"%string.

Fixpoint print_board_rec s n :=
  match n with
  | 0 => ""%string
  | S n1 => append "|"%string
             (append (append (print_line s nsize_board) "|"%string)
                     (append string_return
                        (print_board_rec (s >> size_board) n1)))
    end.

Definition print_board b :=
  append string_return (print_board_rec b nsize_board).

Definition mask_position := (((1 << size_position) - 1) << size_board2).
Definition clean_position := mask_all lxor mask_position.
Definition get_position s := (s land mask_position) >> size_board2.
Definition get_positionX s :=
  (get_position s) land ((1 << (size_position / 2)) - 1).
Definition get_positionY s := (get_position s) >> (size_position / 2).
Definition set_position s i := (s land clean_position) lor (i << size_board2).
Definition set_positionXY s x y :=
  set_position s ((y << (size_position / 2)) lor x).

(* Lazyness : only till 9  *)
Definition print_one_position p :=
 if p =? 0 then "0"%string else
 if p =? 1 then "1"%string else
 if p =? 2 then "2"%string else
 if p =? 3 then "3"%string else
 if p =? 4 then "4"%string else
 if p =? 5 then "5"%string else
 if p =? 6 then "6"%string else
 if p =? 7 then "7"%string else
 if p =? 8 then "8"%string else
 if p =? 9 then "9"%string else "?"%string.

Definition print_position p :=
  append (print_one_position (p land ((1 << (size_position / 2)) - 1)))
  (append ", " (print_one_position (p >> (size_position / 2)))).

Definition mask_cube := (((1 << size_cube) - 1) << size_board2_position).
Definition clean_cube := mask_all lxor mask_cube.
Definition get_cube s := (s land mask_cube) >> size_board2_position.
Definition set_cube s i := (s land clean_cube) lor (i << size_board2_position).

(* Cube
       ---
       |4|
     -------
     |2|1|5|
     -------
       |3|
       ---
       |6|
       ---
*)

(* Definition d1 := 1 << 5. *)
Definition get_d1 c := (c >> 5) land 1.
(* Definition d2 := 1 << 4. *)
Definition get_d2 c := (c >> 4) land 1.
(* Definition d3 := 1 << 3. *)
Definition get_d3 c := (c >> 3) land 1.
(* Definition d4 := 1 << 2. *)
Definition get_d4 c := (c >> 2) land 1.
(* Definition d5 := 1 << 1. *)
Definition get_d5 c := (c >> 1) land 1.
(* Definition d6 := 1. *)
Definition get_d6 c := c land 1.
Definition mk_cube v1 v2 v3 v4 v5 v6 :=
  (((((((v1 << 1 lor v2) << 1) lor v3) << 1) lor v4) << 1) lor v5) << 1 lor v6.

Definition print_cube c :=
  let f x := if is_zero x then "O"%string else "X"%string in
  let res1 := append "         "%string
                (append (f (get_d4 c)) string_return) in
  let res2 := append "        "%string
                (append
                  (append (f (get_d2 c))(append (f (get_d1 c)) (f (get_d5 c))))
                   string_return) in
   let res3 := append "         "%string
                (append (f (get_d3 c)) string_return) in
   let res4 := append "         "%string
                (append (f (get_d6 c)) string_return) in
   let res5 := string_return in
   append (append (append (append (append
      string_return res1) res2) res3) res4) res5.

(* Rol Up
       ---
       |6|
     -------
     |2|4|5|
     -------
       |1|
       ---
       |3|
       ---

*)

Definition roll_up c :=
  mk_cube (get_d4 c) (get_d2 c) (get_d1 c) (get_d6 c) (get_d5 c) (get_d3 c).

(* Down
       ---
       |1|
     -------
     |2|3|5|
     -------
       |6|
       ---
       |4|
       ---
*)

Definition roll_down c :=
  mk_cube (get_d3 c) (get_d2 c) (get_d6 c) (get_d1 c) (get_d5 c) (get_d4 c).

(* Right
       ---
       |4|
     -------
     |1|5|6|
     -------
       |3|
       ---
       |2|
       ---
*)

Definition roll_right c :=
  mk_cube (get_d5 c) (get_d1 c) (get_d3 c) (get_d4 c) (get_d6 c) (get_d2 c).

(* Left
       ---
       |4|
     -------
     |6|2|1|
     -------
       |3|
       ---
       |5|
       ---
*)

Definition roll_left c :=
  mk_cube (get_d2 c) (get_d6 c) (get_d3 c) (get_d4 c) (get_d1 c) (get_d5 c).

Fixpoint in_state s1 l :=
  match l with
  | nil => false
  | s2 :: l1 => if s2 <=? s1 then (s1 =? s2) else in_state s1 l1
  end.

Fixpoint add_state s1 l :=
  match l with
  | nil => s1 :: nil
  | s2 :: l1 => if s2 <=? s1 then
                  if (s1 =? s2) then l else s1 :: l1
                  else s2 :: add_state s1 l1
  end.

Definition swap_state s :=
  let c := get_cube s in
  let b := get_board s in
  let p := get_position s in
  let d1 := get_d1 c in
  let v := (b >> p) land 1 in
  let s1 := set_cube s
    (mk_cube v (get_d2 c) (get_d3 c) (get_d4 c) (get_d5 c) (get_d6 c)) in
  let b1 := if (v =? d1) then b else
              if is_zero v then b lor (1 << p) else b lxor (1 << p) in
  set_board s1 b1.

Definition s0 := set_cube (set_positionXY 0 1 2) ((1 << size_cube) - 1).

Definition one_step s vls :=
  let px := get_positionX s in
  let py := get_positionY s in
  let c := get_cube s in
  let (r1,vls1) := if is_zero px then (nil, vls) else
      let c1 := roll_left c in
      let s1 := swap_state (set_cube (set_positionXY s (px - 1) py) c1) in
      if in_state s1 vls then (nil, vls) else
      (s1 :: nil, add_state s1 vls) in
  let (r2,vls2) := if px =? (size_board - 1) then (r1, vls1) else
      let c1 := roll_right c in
      let s1 := swap_state (set_cube (set_positionXY s (px + 1) py) c1) in
      if in_state s1 vls1 then (r1, vls1) else
      (s1 :: r1, add_state s1 vls1) in
  let (r3,vls3) := if is_zero py then (r2, vls2) else
      let c1 := roll_up c in
      let s1 := swap_state (set_cube (set_positionXY s px (py - 1)) c1) in
      if in_state s1 vls2 then (r2, vls2) else
      (s1 :: r2, add_state s1 vls2) in
  let (r4,vls4) := if py =? (size_board - 1) then (r3, vls3) else
      let c1 := roll_down c in
      let s1 := swap_state (set_cube (set_positionXY s px (py + 1)) c1) in
      if in_state s1 vls3 then (r3, vls3) else
      (s1 :: r3, add_state s1 vls3) in
  (r4, vls4).

(* The specific functions to compute the effect of one move.    *)
Definition state_up s : option int :=
  let py := get_positionY s in
  if py =? 0 then None
  else
    let px := get_positionX s in
    let s1 := set_positionXY s px (py - 1) in
    let c := get_cube s in
    let c1 := roll_up c in
    let s2 := set_cube s1 c1 in
     Some (swap_state s2).

Definition state_down s : option int :=
  let py := get_positionY s in
  if py =? size_board - 1 then None
  else
    let px := get_positionX s in
    let s1 := set_positionXY s px (py + 1) in
    let c := get_cube s in
    let c1 := roll_down c in
    let s2 := set_cube s1 c1 in
     Some (swap_state s2).

Definition state_left s : option int :=
  let px := get_positionX s in
  if px =? 0 then None
  else
    let py := get_positionY s in
    let s1 := set_positionXY s (px - 1) py in
    let c := get_cube s in
    let c1 := roll_left c in
    let s2 := set_cube s1 c1 in
     Some (swap_state s2).

Definition state_right s : option int :=
  let px := get_positionX s in
  if px =? size_board - 1 then None
  else
    let py := get_positionY s in
    let s1 := set_positionXY s (px + 1) py in
    let c := get_cube s in
    let c1 := roll_right c in
    let s2 := set_cube s1 c1 in
     Some (swap_state s2).

(* The specific function to compute the reverse step of each    *)
(* move.                                                        *)

Definition pre_state_up s : list (int * int):=
match state_up s with
| None => nil
| Some s1 =>
  match state_down s1 with
  | None => nil
  | Some s2 =>
    match state_up s2 with
    | None => nil
    | Some s3 => [(s3, 3)]
    end
  end
end.

Definition pre_state_right s :=
match state_right s with
| None => nil
| Some s1 =>
  match state_left s1 with
  | None => nil
  | Some s2 =>
    match state_right s2 with
    | None => nil
    | Some s3 => [(s3, 4)]
    end
  end
end.

Definition pre_state_down s :=
match state_down s with
| None => nil
| Some s1 =>
  match state_up s1 with
  | None => nil
  | Some s2 =>
    match state_down s2 with
    | None => nil
    | Some s3 => [(s3, 1)]
    end
  end
end.

Definition pre_state_left s :=
match state_left s with
| None => nil
| Some s1 =>
  match state_right s1 with
  | None => nil
  | Some s2 =>
    match state_left s2 with
    | None => nil
    | Some s3 => [(s3, 2)]
    end
  end
end.

Definition reverse_steps (s : int) : list (int * int) :=
  pre_state_left s ++ pre_state_down s ++ pre_state_right s ++ pre_state_up s.

Definition full_cube := mk_cube 1 1 1 1 1 1.

Definition final_states :=
  List.concat
   (map (fun nx =>
         map (fun ny =>
           set_cube (set_positionXY 0 (of_Z (Z.of_nat nx))(of_Z (Z.of_nat ny)))
               full_cube)
               (seq 0 (Z.to_nat (to_Z size_board))))
               (seq 0 (Z.to_nat (to_Z size_board)))).

Definition print_state s :=
    append (print_cube (get_cube s))
    (append (print_position (get_position s)) (print_board (get_board s))).

(* As a complement to print_state, a procedure to output the game ID as used in
  the original game by S. Tatham. The relevant function is  print_game_ID, and
  is only relevant for starting positions. *)
Fixpoint int_to_bit_list (bit_count : nat) (n : int) :=
  match bit_count with
  | 0 => nil
  | S p => (if (n land 1) =? 1 then true else false) :: int_to_bit_list p (n >> 1)
  end.

Definition int_smaller_than_16_to_digit (n : int) :=
  if n =?  0 then "0"%string else
  if n =?  1 then "1"%string else
  if n =?  2 then "2"%string else
  if n =?  3 then "3"%string else
  if n =?  4 then "4"%string else
  if n =?  5 then "5"%string else
  if n =?  6 then "6"%string else
  if n =?  7 then "7"%string else
  if n =?  8 then "8"%string else
  if n =?  9 then "9"%string else
  if n =?  10 then "A"%string else
  if n =?  11 then "B"%string else
  if n =?  12 then "C"%string else
  if n =?  13 then "D"%string else
  if n =?  14 then "E"%string else
  "F"%string.

Definition four_bit_list_to_hexa (l : list bool) :=
  let n := fold_right (fun (b : bool) (v : int) => (if b then 1 else 0) + 2 * v)
               0 l in
    int_smaller_than_16_to_digit n.

Definition int_smaller_than_20_to_decimal (n : int) :=
  if n <? 10 then int_smaller_than_16_to_digit n else
   (int_smaller_than_16_to_digit (n / 10) ++
    int_smaller_than_16_to_digit (n mod 10))%string.

Definition bits_to_hexa (s : int) := four_bit_list_to_hexa (rev (int_to_bit_list 4 s)).

Definition print_game_ID (s : int) :=
  ("c4x4:" ++ bits_to_hexa (s land 15) ++ bits_to_hexa ((s >> 4) land 15) ++
     bits_to_hexa ((s >> 8) land 15) ++ bits_to_hexa ((s >>  12) land 15) ++
   "," ++ int_smaller_than_20_to_decimal (get_cube s))%string.

(* The big computation of full bread first seach, where the     *)
(* number of iterations is limited by fuel.                     *)
(* - the result should be understood as follows:                *)
(*  * when the result is inl(t, k), t is the final table and k  *)
(*    is the minimal number of rounds to obtain it.             *)
(*  * when the result is inr(l, t), l is the current list of    *)
(*    positions that are predecessors of position that were     *)
(*    introduced at the last round,                             *)
(*    t is the table containing all positions that have already *)
(*    been processed.                                           *)
(*    When the result has the inr form, the list may have       *)
(*    duplicates and elements already present in t.             *)
(*    when the result has the inf form, the number of rounds    *)
(*    is 2 + the round number of the round index where the last *)
(*    element was added to table.                               *)
Definition cube_explore (n : nat) :
  intmap.t int * nat + list (int * int) * intmap.t int :=
  bfs _ _ _ bfs_find bfs_add reverse_steps n
    (map (fun i => (i, 0)) final_states) empty 0.

Definition make_solution_generic {T : Type} (find : T -> int -> option int) (x : int)
   (table : T) : list (int * int) :=
  (fix mkp (x : int)(fuel : nat) {struct fuel} : list (int * int) :=
    match fuel with
      0 => nil
    | S p =>
      match find table x with
      | None => nil
      | Some move =>
        if move =? 1 then
           match state_up x with
           | Some x' => (1, x') :: mkp x' p
           | None => nil
           end
        else if move =? 2 then
           match state_right x with
           | Some x' => (2, x') :: mkp x' p
           | None => nil
           end
        else if move =? 3 then
           match state_down x with
           | Some x' => (3, x') :: mkp x' p
           | None => nil
           end
        else if move =? 4 then
           match state_left x with
           | Some x' => (4, x') :: mkp x' p
           | None => nil
           end
        else nil
      end
    end) x 20%nat.

Definition play (state : int) (move : int) : option int :=
  if move =? 1 then state_up state else
  if move =? 2 then state_right state else
  if move =? 3 then state_down state else
  if move =? 4 then state_left state else
  None.

Definition make_solution (x : int) (table : intmap.t int) : list (int * int) :=
  make_solution_generic bfs_find x table.

Definition make_solution' (x : int) (table : intmap.t int) : list int :=
  match
    make_path _ _ _ bfs_find table (fun s => PrimInt63.eqb (get_cube s) 63)
    play x 20 with
    Some l => l
  | None => nil
  end.

Definition new_ones (l : list (int * int)) (table : intmap.t int) :
   list (int * int)
   :=
  filter (fun p =>
            match bfs_find table (fst p) with Some _ => false | _ => true end)
       l.

Definition starting_positions (l : list (int * int)) : list (int * int) :=
   filter (fun p => andb (PrimInt63.eqb (get_cube (fst p)) 0)
                         (PrimInt63.eqb
                           ((get_board (fst p) >> get_position (fst p)) land 1)
                                0)) l.

Definition result3 := cube_explore 3.
Definition positions3 := match result3 with inl(t, _) => t | inr(_, t) => t end.

Definition short := intmap.Raw.enumeration.

Definition esize_more {T : Type} (e : intmap.Raw.enumeration T)
  (cont : short T -> int -> int)
  (acc : int) : int :=
  match e with
     intmap.Raw.End _ => 0
  | intmap.Raw.More k v t e' => (cont (intmap.Raw.cons t e') (1 + acc))
  end.

Fixpoint size_cont {T : Type} (t : intmap.Raw.tree T)
         (cont : int -> int) (acc : int) : int :=
  match t with
  | intmap.Raw.Leaf _ => cont acc
  | intmap.Raw.Node l1 x1 d1 r1 _ =>
    size_cont l1 (size_cont r1 cont) (1 + acc)
  end.

Definition size {T : Type} (table : intmap.t T) :=
   size_cont (intmap.this table) (fun x => x) 0.

Definition combine' (position move : int) :=
  (position << 3) lor (move land (1 << 4 - 1)).

Fixpoint table_to_array_cont (t : intmap.Raw.tree int)
  (cont : int -> array int -> array int) (rank : int) (a : array int) :=
  match t with
  | intmap.Raw.Leaf _ => cont rank a
  | intmap.Raw.Node l1 x1 d1 r1 _ =>
    table_to_array_cont l1
       (fun r a => table_to_array_cont r1 cont (r + 1) a.[r <- combine' x1 d1])
       rank a
  end.

Definition table_to_array (table : intmap.t int) (array_size : int) :=
   table_to_array_cont (intmap.this table)
         (fun r a => a) 0 (PArray.make array_size 0).

Definition extractkey (i : int) := i / 8.

Definition initial_gap := 2 ^ 21.

Definition array3 := table_to_array positions3.

Time Definition array3' := Eval compute in array3.

Definition result20 := cube_explore 20.

Definition all_positions := match result20 with inl(t, _) => t | _ => empty end.

Definition big_array_size :=
  Eval vm_compute in (22 * 21 * 20 * 19 * 18 * 17 * 16) / 720.

Definition big_array := table_to_array all_positions big_array_size.

(* Function to find values in the array, to replace the access that we
  had in FMapAVL.  This uses a fuel, which could be based on the log
  of the array size.  *)
Fixpoint lookup (a : array int) (x : int) (gap : int)
  (position : int) (n : nat) :=
match n with
| 0 => None
| S p =>
  let current := a.[position] in
  if x =? extractkey current then
     Some (current mod 8)
  else if x <? extractkey current then
     lookup a x (gap / 2) (position - (gap / 2)) p
  else
     if position + gap / 2 <? PArray.length a then
       lookup a x (gap / 2) (position + (gap / 2)) p
     else
       lookup a x (gap / 2) position p
end.

Definition lookup_fuel :=
  Eval vm_compute in
  Z.to_nat (Z.log2_up (to_Z big_array_size)).

Definition array_find (table : array int) (x : int) :=
  lookup table x (1 << 20) (1 << 20) lookup_fuel.

Definition make_solution_array := make_solution_generic array_find.

Definition make_solution_array'
   (x : int) (table : array int) : option (list int) :=
  make_path _ _ _ array_find table (fun s => PrimInt63.eqb (get_cube s) 63)
    play x 20.

Definition max_card := Z.to_nat wB.

Definition map_order (t1 t2 : intmap.t int) :=
  (max_card - intmap.cardinal t1 < max_card - intmap.cardinal t2)%nat.

Definition map_order_wf : well_founded map_order :=
   wf_inverse_image (intmap.t int) nat lt
     (fun t => (max_card - intmap.cardinal t)%nat) lt_wf.

Lemma size_list_max bound : (0 < bound)%Z ->
  forall l, Sorted Z.lt l -> (forall x, In x l -> (0 <= x < bound)%Z) ->
   Datatypes.length l <= Z.to_nat bound.
Proof.
intros boundgt0 l sortl allbounds.
enough (main : Datatypes.length l <= Z.to_nat (bound - hd bound l)).
  assert (subbounds : (0 <= hd bound l <= bound)%Z).
   destruct l as [ | a l'].
     simpl; lia.
   assert (ain : In a (a :: l')) by (simpl; tauto).
   assert (tmp := allbounds a ain); simpl; lia.
   apply Nat.le_trans with (1 := main).
   rewrite <- Z2Nat.inj_le; lia.
revert sortl allbounds.
induction l as [ | a l Ih].
  intros _ _; simpl.
  now rewrite Z.sub_diag; simpl.
simpl.
destruct l as [ | b l'].
  simpl; intros _ inbounds.
  assert (altbound : (1 <= bound - a)%Z).
    destruct (inbounds a); auto; lia.
  replace 1%nat with (Z.to_nat 1) by easy.
  rewrite <- Z2Nat.inj_le; try lia.
intros sortabl' inbouds.
assert (inbounds' : forall x, In x (b :: l') -> (0 <= x < bound)%Z).
  now intros x xin; apply inbouds; right.
assert (altb : (a < b)%Z).
  inversion sortabl' as [ | dum1 dum2 sbl' cmp].
  now inversion cmp.
assert (bin : (0 <= b < bound)%Z) by (apply inbouds; simpl; tauto).
assert (tonatab : (bound - a = bound - b + (b - a))%Z) by ring.
rewrite tonatab.
rewrite Z2Nat.inj_add; try lia.
transitivity  (S ( Z.to_nat (bound - b))).
  rewrite <- Nat.succ_le_mono.
  apply Ih; auto.
  now inversion sortabl'.
lia.
Qed.

(* TODO : remove this lemma if useless. *)

Lemma add_list_length_le (l1 l2 : list Z) :
  Sorted Z.lt l1 -> Sorted Z.lt l2 ->
  (forall x, In x l1 -> In x l2) ->
  Datatypes.length l1 <= Datatypes.length l2.
Proof.
revert l2; induction l1 as [ | a l1 Ih]; intros [ | b l2]; simpl;
  auto with arith.
intros _ _ abs; case (abs a); tauto.
case (Z.eq_dec a b).
  intros abq; rewrite abq; intros sl1 sl2 incmp.
  rewrite <- Nat.succ_le_mono; apply Ih.
  now inversion sl1.
  now inversion sl2.
intros x inl1.
assert (xnb : x <> b).
  assert (tmp : Forall (Z.lt b) l1).
  apply Sorted_extends; auto.
  exact Z.lt_trans.
  revert tmp; rewrite Forall_forall; intros tmp.
  assert (tmp' := tmp x inl1); lia.
  assert (inl2 : (b = x \/ In x l1)) by now right.
  apply incmp in inl2; destruct inl2 as [xb | it]; auto.
  now case xnb; rewrite xb.
intros anb sl1 sl2 sub12; assert (blta : (b < a)%Z).
  assert (cases : (a < b \/ b < a)%Z) by lia.
  destruct cases; auto.
  assert (tmp: Forall (Z.lt a) (b :: l2)).
    assert (sabl2 : Sorted Z.lt (a :: b :: l2)).
      constructor; auto.
    apply Sorted_extends; auto.
    exact Z.lt_trans.
  revert tmp; rewrite Forall_forall; intros tmp.
  enough (a < a)%Z by lia.
  apply tmp.
  now simpl; apply sub12; left.
rewrite <- Nat.succ_le_mono.
apply Ih.
    now inversion sl1.
  now inversion sl2.
intros x inl1.
assert (xinl2 :  a = x \/ In x l1) by tauto.
apply sub12 in xinl2; destruct xinl2 as [bx | ?]; auto.
apply Sorted_extends in sl1;[ | exact Z.lt_trans].
rewrite Forall_forall in sl1; apply sl1 in inl1.
lia.
Qed.

Lemma add_list_length_lt (l1 l2 : list Z) y :
  Sorted Z.lt l1 -> Sorted Z.lt l2 ->
  (forall x, In x l1 -> In x l2) ->
  In y l2 -> ~ In y l1 -> Datatypes.length l1 < Datatypes.length l2.
Proof.
intros sl1; revert l2.
induction sl1 as [ | a l1 sl1 Ih hdrel]; intros [ | b l2]; simpl; auto with arith.
    tauto.
  intros _ abs; case (abs a); intuition auto.
intros sl2 subl1l2 yin2 ynin1.
assert (sl1' : Sorted Z.lt (a :: l1)) by now constructor.
destruct (Z.eq_dec a b) as [abq | nab].
  assert (yin2' : In y l2).
    destruct yin2 as [byq | ?]; auto.
    now case ynin1; left; rewrite abq, byq.
  assert (yin1' : ~In y l1).
    now intros ctr; case ynin1; right.
  rewrite <- Nat.succ_lt_mono.
  apply Ih; auto.
    now inversion sl2.
  intros x xin1.
  assert (tmp : a = x \/ In x l1) by now right.
  apply subl1l2 in tmp; destruct tmp as [bxq | ?]; auto.
  enough (a < x)%Z by lia.
  apply Sorted_extends in sl1';[ | exact Z.lt_trans].
  rewrite Forall_forall in sl1'; apply sl1' in xin1; lia.
assert (blta : (b < a)%Z).
  assert (cases : (a < b \/ b < a)%Z) by lia.
  destruct cases; auto.
  assert (tmp: Forall (Z.lt a) (b :: l2)).
    assert (sabl2 : Sorted Z.lt (a :: b :: l2)).
      constructor; auto.
    apply Sorted_extends; auto.
    exact Z.lt_trans.
  revert tmp; rewrite Forall_forall; intros tmp.
  enough (a < a)%Z by lia.
  apply tmp.
  now simpl; apply subl1l2; left.
  rewrite <- Nat.succ_lt_mono.
  destruct yin2 as [byq | yinl2].
  assert (hyple : forall x, In x (a :: l1) -> In x l2).
    intros x; simpl; intros xinl1; assert (xinl1' := xinl1).
    apply subl1l2 in xinl1; destruct xinl1; auto.
    destruct xinl1' as [ | xinl1']; try congruence.
    assert (sl12 := sl1').
    apply Sorted_extends in sl1';[ | exact Z.lt_trans].
    rewrite Forall_forall in sl1'; apply sl1' in xinl1'; lia.
  now apply add_list_length_le in hyple; auto; inversion sl2.
apply Ih;[ now inversion sl2 | |auto | tauto].
intros x xinl1.
assert (xinl2 : a = x \/ In x l1) by tauto.
apply subl1l2 in xinl2; destruct xinl2 as [bx | ?]; auto.
apply Sorted_extends in sl1';[ | exact Z.lt_trans].
rewrite Forall_forall in sl1'.
apply sl1' in xinl1.
lia.
Qed.

Lemma Sorted_map [A B : Type] (f : A -> B) (Ra : A -> A -> Prop)
  [Rb : B -> B -> Prop] l :
  Sorted Ra l ->
  (forall x y, In x l -> In y l -> Ra x y -> Rb (f x) (f y)) ->
  Sorted Rb (map f l).
Proof.
induction 1 as [ | x l ls Ih cmpx].
  intros; constructor.
intros monot; simpl; constructor.
  apply Ih.
  intros u v uin vin; apply monot; simpl; tauto.
destruct l as [ | b l]; simpl; auto.
constructor.
apply monot; simpl; try tauto.
now inversion cmpx.
Qed.

Lemma add_decrease :
  forall map s v, bfs_find map s = None -> map_order (bfs_add map s v) map.
Proof.
intros m s v snin.
unfold map_order.
enough (intmap.cardinal m < intmap.cardinal (bfs_add m s v)).
  enough (bnd : forall (m' : intmap.t int), intmap.cardinal m' <= max_card).
    assert (tmp1 := bnd m).
    assert (tmp2 := bnd (bfs_add m s v)).
    lia.
  intros m'; rewrite intmap.cardinal_1.
  (*TODO : complain about the need for this pattern command. *)
  pattern (Datatypes.length (intmap.elements m')).
  rewrite <- (map_length (fun p => to_Z (fst p)) (intmap.elements m')).
  apply size_list_max.
        easy.
      apply (Sorted_map (fun p => to_Z (fst p)) (intmap.lt_key (elt := int))).
      now apply intmap.elements_3.
    now auto.
  intros x; simpl.
  rewrite in_map_iff; intros [y [to_Zy _]]; rewrite <- to_Zy.
  now apply to_Z_bounded.

enough (eqlistA (facts.O.eqke (elt:= int)) (intmap.elements (bfs_add m s v))
          (facts.elements_lt (s, v) m ++ (s, v) :: facts.elements_ge (s, v) m)).
  apply eqlistA_length in H.
  rewrite app_length in H; simpl in H; rewrite Nat.add_succ_r in H.
  rewrite <- app_length in H; rewrite <-facts.elements_split in H.
  rewrite !intmap.cardinal_1.
  (* TODO : complain that " rewrite H " does not work here. *)
  assert (circ : forall a b : nat, a = S b -> b < a) by (intros; lia).
  apply (circ _ _ H).
  apply facts.elements_Add.
  rewrite facts.P.F.in_find_iff.
  now unfold bfs_find in snin; rewrite snin.
 unfold facts.P.Add; reflexivity.
 Qed.

Lemma  map_order_trans :
  forall map2 map1 map3, map_order map1 map2 -> map_order map2 map3 ->
   map_order map1 map3.
Proof.
now intros map2 map1 map3; unfold map_order; apply Nat.lt_trans.
Qed.

Definition cube_explore' (v : unit) : intmap.t int * nat :=
  match bfs' _ _ _ bfs_find bfs_add reverse_steps map_order map_order_wf
    add_decrease map_order_trans
    (map (fun i => (i, 0)) final_states) empty 0 with
  | inl r => r
  | inr (_, r) => (r, 0%nat)
  end.

(* Definition big_array' := Eval vm_compute in big_array. *)


Require Import propInv2.
Require Import verif_cond_5.
Require Import extra5.
Local Open Scope Z.

Theorem proof2_5: (startnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1) /\ cond5 ->
 (inv hands1 dryer1 ctrlState2 ctrlTimer2 timer1).

Proof.
intros.
split.
unfold propInv2.
inversion_clear H.
inversion_clear H1.
inversion_clear H2.
inversion_clear H3.
inversion_clear H4.
inversion_clear H5.
intros.
(*analysis of cases i<timer1 and i=timer1*)
elim Zle_lt_or_eq with i timer1.
intros.
apply startnewloop_to_propInv.
assumption.
split.
apply H5.
inversion_clear H0.
auto with zarith.
assumption.
(*analysis of case i=timer1*)
intros.
rewrite H8 in H7.
inversion_clear H7.
rewrite H2 in H10.
elimtype False.
contradict H10.
discriminate.
inversion_clear H5.
assumption.
apply extra5.
split.
inversion_clear H.
inversion_clear H0.
split.
apply H.
assumption.
apply H.
Qed.


From Undecidability Require Import TM.SBTM.
Require Import PeanoNat Lia List ssreflect ssrbool ssrfun.
Import ListNotations SBTMNotations.

Set Default Goal Selector "!".

Lemma oiter_None {X : Type} (f : X -> option X) k : Nat.iter k (obind f) None = None.
Proof. elim: k; [done | by move=> /= ? ->]. Qed.

Lemma steps_plus {M} k1 k2 {x} :
  steps M (k1 + k2) x = obind (fun y => steps M k2 y) (steps M k1 x).
Proof.
  rewrite /steps Nat.add_comm /Nat.iter nat_rect_plus /= -!/(Nat.iter _ _ _).
  move: (Nat.iter k1 _ (Some x)) => [y|] /=; first done.
  apply: oiter_None.
Qed.

Lemma steps_None_mono {M x} k2 k1 : steps M k1 x = None -> k1 <= k2 -> steps M k2 x = None.
Proof.
  elim: k2 k1 x.
  { move=> [|k1]; [done|lia]. }
  move=> k2 IH [|k1] x + ?; first done.
  rewrite (steps_plus 1 k1) (steps_plus 1 k2).
  move: (steps M 1 x) => [y|]; last done.
  move=> /IH. apply. lia.
Qed.

Lemma steps_sync {M k1 x k2 y} :
  steps M (S k1) x = None -> steps M (S k2) x = Some y -> steps M k1 y = None.
Proof.
  elim: k1 k2 x.
  { move=> k2 x. rewrite (steps_plus 1 k2). by move=> ->. }
  move=> k1 IH k2 x.
  rewrite (steps_plus 1 (S k1)) (steps_plus 1 k2).
  move: (steps M 1 x) => [z|]; last done.
  move: k2 => [|k2].
  { by move=> /= <- [<-]. }
  move=> /IH H /H /(steps_None_mono (S k1)). apply. lia.
Qed.

(* two lists are almost_eq if they differ only in trailing false symbols *)
Inductive almost_eq : list bool -> list bool -> Prop :=
  | almost_eq_cons a l1 l2 : almost_eq l1 l2 -> almost_eq (a :: l1) (a :: l2)
  | almost_eq_false n1 n2 : almost_eq (repeat false n1) (repeat false n2).

Inductive almost_eq_tape : tape -> tape -> Prop :=
  | almost_eq_tape_intro a ls1 rs1 ls2 rs2 :
      almost_eq ls1 ls2 -> almost_eq rs1 rs2 ->
      almost_eq_tape (ls1, a, rs1) (ls2, a, rs2).

Lemma almost_eq_tape_step_Some M q q1 q2 t1 t'1 t2 t'2 :
  almost_eq_tape t1 t2 ->
  step M (q, t1) = Some (q1, t'1) ->
  step M (q, t2) = Some (q2, t'2) ->
  q1 = q2 /\ almost_eq_tape t'1 t'2.
Proof.
  have ? := almost_eq_false 0 0.
  have ? := almost_eq_false 0 _.
  have ? := almost_eq_false _ 0.
  case=> a ???? [] => [????|n1 n2] [].
  - move=> ????. rewrite /step /=. case: (trans' M _); last done.
    move=> [[? ?] []] [] <- <- [] <- <- /=; by do ? constructor.
  - move=> n'1 n'2. rewrite /step /=. case: (trans' M _); last done.
    move=> [[? ?] []] [] <- <- [] <- <- /=; first by do ? constructor.
    move: n'1 n'2 => [|?] [|?] /=; by do ? constructor.
  - move=> ????. rewrite /step /=. case: (trans' M _); last done.
    move=> [[? ?] []] [] <- <- [] <- <- /=; last by do ? constructor.
    move: n1 n2 => [|?] [|?] /=; by do ? constructor.
  - move=> n'1 n'2. rewrite /step /=. case: (trans' M _); last done.
    move=> [[? ?] []] [] <- <- [] <- <- /=.
    + move: n1 n2 => [|?] [|?] /=; by do ? constructor.
    + move: n'1 n'2 => [|?] [|?] /=; by do ? constructor.
Qed.

Lemma almost_eq_tape_step_None M q t1 t2 :
  almost_eq_tape t1 t2 ->
  step M (q, t1) = None ->
  step M (q, t2) = None.
Proof.
  case=> a ???? [] => [????|n1 n2] [] >.
  all: rewrite /step /=.
  all: case: (trans' M _); last done.
  all: by move=> [[? ?] ?].
Qed.

Lemma almost_eq_refl l : almost_eq l l.
Proof.
  elim: l => >.
  - by apply: (almost_eq_false 0 0).
  - by apply: almost_eq_cons.
Qed.

Lemma almost_eq_sym l1 l2 : almost_eq l1 l2 -> almost_eq l2 l1.
Proof. elim=> *; by constructor. Qed.

Lemma almost_eq_tape_sym t1 t2 : almost_eq_tape t1 t2 -> almost_eq_tape t2 t1.
Proof. move=> [] > /almost_eq_sym ? /almost_eq_sym ?. by constructor. Qed.

Lemma almost_eq_tape_steps_None {M k q t1 t2} :
  almost_eq_tape t1 t2 ->
  (steps M k (q, t1) = None <-> steps M k (q, t2) = None).
Proof.
  elim: k q t1 t2; first done.
  move=> k IH q t1 t2. rewrite !(steps_plus 1 k) /=.
  case E1: (step M (q, t1)) => [[q2 t'1]|];
    case E2: (step M (q, t2)) => [[q'2 t'2]|].
  - move: E1 E2 => /almost_eq_tape_step_Some /[apply] /[apply].
    move=> [<- /IH]. by apply.
  - move=> /almost_eq_tape_sym Ht2t1.
    by move: E2 Ht2t1 E1 => /almost_eq_tape_step_None /[apply] ->.
  - move=> Ht1t2.
    by move: E1 Ht1t2 E2 => /almost_eq_tape_step_None /[apply] ->.
  - done.
Qed.

Fixpoint seq_Vector (n : nat) : Vector.t (Fin.t n) n :=
  match n return Vector.t (Fin.t n) n with
  | 0 => Vector.nil (Fin.t 0)
  | S n' => Vector.cons (Fin.t (S n')) (Fin.F1) n' (Vector.map (Fin.R 1) (seq_Vector n'))
  end.

Lemma seq_Vector_spec {n} (q : Fin.t n) :
  VectorDef.nth (seq_Vector n) q = q.
Proof.
  elim: q; first done.
  move=> {}n q IH /=.
  by rewrite (Vector.nth_map _ _ q q erefl) IH.
Qed.

(* build transition table from transition function *)
Definition construct_trans {n : nat}
  (f : (Fin.t n) * bool -> option ((Fin.t n) * bool * direction)) :
  Vector.t (
    (option ((Fin.t n) * bool * direction)) *
    (option ((Fin.t n) * bool * direction))) n :=
  Vector.map (fun q => (f (q, true), f (q, false))) (seq_Vector n).

Lemma construct_trans_spec {n : nat}
  (f : (Fin.t n) * bool -> option ((Fin.t n) * bool * direction)) :
  forall x, trans' (Build_SBTM n (construct_trans f)) x = f x.
Proof.
  move=> /= [q a]. rewrite /trans' /construct_trans /=.
  rewrite (Vector.nth_map _ _ q q erefl) seq_Vector_spec.
  by case: a.
Qed.


From Common Require Export Literal Primitive.

(* Inductive type : Set :=
| Int | Bool | Unit
| Tuple (tpe1 tpe2: type)
| Fnt (args: list type) (rettpe: type)
| Sum (ltpe rtpe : type). *)

(* Record arg : Set := {name: nat;tpe: type}. *)

Inductive term : Set :=
| Var (n: nat)
| Const (l: literal)
| Let (x: nat) (t rest : term)
(* | Let (x: arg) (t rest : term) *)
(* | LetRec (funs: list fnt) (rest : term) *)
| LetRec (f: fnt) (rest : term)
| App (f t : term)
| In
| Out (t: term)
(* | Halt (t: term) *)
| Ite (cond thent elset: term)
| BinaryOp (op: binary_primitives) (t1 t2: term)
| UnaryOp (op: unary_primitives) (t: term)
| Match (scrut: term) (lcase: nat * term) (rcase: nat * term)
(* | NewRef (tpe: type) (t: term)
| UpdateRef (ref t: term)
| ReadRef (ref: term) *)
with
  fnt : Set := Fnt (fname: nat) (arg: nat) (body: term).
  (* fnt : Set := Fnt (fname: nat) (args: list arg) (rettpe: type) (body: term). *)

Fixpoint next_free (t : term) : nat :=
  match t with
  | Var n => S n
  | Const _ => 0
  | Let x t r => max (next_free t) (max (next_free r) (S x))
  | LetRec (Fnt n a b) r =>
      max (S n) (max (S a) (max (next_free b) (next_free r)))
  | App f t => max (next_free f) (next_free t)
  | In => 0
  | Out t => next_free t
  | Ite c t e => max (next_free c) (max (next_free t) (next_free e))
  | BinaryOp _ t1 t2 => max (next_free t1) (next_free t2)
  | UnaryOp _ t => next_free t
  | Match s (ln, lt) (rn, rt) =>
      max (next_free s) (max (S ln) (max (next_free lt) (max (S rn) (next_free rt))))
  end.

Fixpoint size t : nat :=
  match t with
  | Var _ => 1
  | Const _ => 1
  | Let _ t r => 1 + size t + size r
  | LetRec (Fnt _ _ b) r => 1 + size b + size r
  | App f t => 1 + size f + size t
  | In => 1
  | Out t => 1 + size t
  | Ite c t e => 1 + size c + size t + size e
  | BinaryOp _ t1 t2 => 1 + size t1 + size t2
  | UnaryOp _ t => 1 + size t
  | Match s (_, lt) (_, rt) => 1 + size s + size lt + size rt
  end.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
From prelude Require Export strings.
From prelude Require Import relations.
From Coq Require Import Ascii.

Class Pretty A := pretty : A → string.
Definition pretty_N_char (x : N) : ascii :=
  match x with
  | 0 => "0" | 1 => "1" | 2 => "2" | 3 => "3" | 4 => "4"
  | 5 => "5" | 6 => "6" | 7 => "7" | 8 => "8" | _ => "9"
  end%char%N.
Fixpoint pretty_N_go_help (x : N) (acc : Acc (<)%N x) (s : string) : string :=
  match decide (0 < x)%N with
  | left H => pretty_N_go_help (x `div` 10)%N
     (Acc_inv acc (N.div_lt x 10 H eq_refl))
     (String (pretty_N_char (x `mod` 10)) s)
  | right _ => s
  end.
Definition pretty_N_go (x : N) : string → string :=
  pretty_N_go_help x (wf_guard 32 N.lt_wf_0 x).
Lemma pretty_N_go_0 s : pretty_N_go 0 s = s.
Proof. done. Qed.
Lemma pretty_N_go_help_irrel x acc1 acc2 s :
  pretty_N_go_help x acc1 s = pretty_N_go_help x acc2 s.
Proof.
  revert x acc1 acc2 s; fix 2; intros x [acc1] [acc2] s; simpl.
  destruct (decide (0 < x)%N); auto.
Qed.
Lemma pretty_N_go_step x s :
  (0 < x)%N → pretty_N_go x s
  = pretty_N_go (x `div` 10) (String (pretty_N_char (x `mod` 10)) s).
Proof.
  unfold pretty_N_go; intros; destruct (wf_guard 32 N.lt_wf_0 x).
  unfold pretty_N_go_help; fold pretty_N_go_help.
  by destruct (decide (0 < x)%N); auto using pretty_N_go_help_irrel.
Qed.
Instance pretty_N : Pretty N := λ x, pretty_N_go x ""%string.
Instance pretty_N_inj : Inj (@eq N) (=) pretty.
Proof.
  assert (∀ x y, x < 10 → y < 10 →
    pretty_N_char x =  pretty_N_char y → x = y)%N.
  { compute; intros. by repeat (discriminate || case_match). }
  cut (∀ x y s s', pretty_N_go x s = pretty_N_go y s' →
    String.length s = String.length s' → x = y ∧ s = s').
  { intros help x y ?. eapply help; eauto. }
  assert (∀ x s, ¬String.length (pretty_N_go x s) < String.length s) as help.
  { setoid_rewrite <-Nat.le_ngt.
    intros x; induction (N.lt_wf_0 x) as [x _ IH]; intros s.
    assert (x = 0 ∨ 0 < x)%N as [->|?] by lia; [by rewrite pretty_N_go_0|].
    rewrite pretty_N_go_step by done.
    etrans; [|by eapply IH, N.div_lt]; simpl; lia. }
  intros x; induction (N.lt_wf_0 x) as [x _ IH]; intros y s s'.
  assert ((x = 0 ∨ 0 < x) ∧ (y = 0 ∨ 0 < y))%N as [[->|?] [->|?]] by lia;
    rewrite ?pretty_N_go_0, ?pretty_N_go_step, ?(pretty_N_go_step y) by done.
  { done. }
  { intros -> Hlen; edestruct help; rewrite Hlen; simpl; lia. }
  { intros <- Hlen; edestruct help; rewrite <-Hlen; simpl; lia. }
  intros Hs Hlen; apply IH in Hs; destruct Hs;
    simplify_eq/=; split_and?; auto using N.div_lt_upper_bound with lia.
  rewrite (N.div_mod x 10), (N.div_mod y 10) by done.
  auto using N.mod_lt with f_equal.
Qed.
Instance pretty_Z : Pretty Z := λ x,
  match x with
  | Z0 => "" | Zpos x => pretty (Npos x) | Zneg x => "-" +:+ pretty (Npos x)
  end%string.