Require Import List. Import ListNotations.
Require Import ZArith.
Local Open Scope Z_scope.
Require Import Integers.
Require Import VST.floyd.sublist.
Require Import aes.sbox.
Require Import aes.GF_ops_LL.
Require Import aes.list_utils.

Definition rot8(i: int): int :=
  Int.or (Int.and (Int.shl i (Int.repr 8)) (Int.repr (-1))) (Int.shru i (Int.repr 24)).

Definition rotl1(b: int): int :=
  Int.and (Int.or (Int.shl b (Int.repr 1)) (Int.shr b (Int.repr 7))) (Int.repr 255).

Definition FSb := map Int.repr sbox.
Definition RSb := map Int.repr inv_sbox.

Definition calc_FT0(i: Z): int :=
  (Int.xor (Int.xor (Int.xor
     (times2 (Znth i FSb Int.zero))
     (Int.shl (Znth i FSb Int.zero) (Int.repr 8)))
     (Int.shl (Znth i FSb Int.zero) (Int.repr 16)))
     (Int.shl (Int.and (Int.xor (times2 (Znth i FSb Int.zero)) (Znth i FSb Int.zero))
                       (Int.repr 255))
              (Int.repr 24))).
Definition calc_FT1(i: Z): int := rot8 (calc_FT0 i).
Definition calc_FT2(i: Z): int := rot8 (calc_FT1 i).
Definition calc_FT3(i: Z): int := rot8 (calc_FT2 i).
Definition calc_RT0(i: Z): int :=
  Int.xor (Int.xor (Int.xor
           (mul (Int.repr 14) (Int.repr (Int.unsigned (Znth i RSb Int.zero))))
  (Int.shl (mul (Int.repr  9) (Int.repr (Int.unsigned (Znth i RSb Int.zero)))) (Int.repr  8)))
  (Int.shl (mul (Int.repr 13) (Int.repr (Int.unsigned (Znth i RSb Int.zero)))) (Int.repr 16)))
  (Int.shl (mul (Int.repr 11) (Int.repr (Int.unsigned (Znth i RSb Int.zero)))) (Int.repr 24)).
Definition calc_RT1(i: Z): int := rot8 (calc_RT0 i).
Definition calc_RT2(i: Z): int := rot8 (calc_RT1 i).
Definition calc_RT3(i: Z): int := rot8 (calc_RT2 i).

Global Opaque calc_FT0 calc_FT1 calc_FT2 calc_FT2 calc_RT0 calc_RT1 calc_RT2 calc_RT3.

Definition FT0 := fill_list 256 calc_FT0.
Definition FT1 := fill_list 256 calc_FT1.
Definition FT2 := fill_list 256 calc_FT2.
Definition FT3 := fill_list 256 calc_FT3.
Definition RT0 := fill_list 256 calc_RT0.
Definition RT1 := fill_list 256 calc_RT1.
Definition RT2 := fill_list 256 calc_RT2.
Definition RT3 := fill_list 256 calc_RT3.
Definition RCON := repeat_op_table 10 Int.one times2.

(* If entailer! and go_lower unfold these, they become too slow *)
Global Opaque FSb FT0 FT1 FT2 FT3 RSb RT0 RT1 RT2 RT3 RCON.

(* TODO Can we achieve the same with "Arguments"?
   "Arguments FSb : simpl never." (etc) does not seem to work *)

(* Instead of looking up the S-box values in a predefined list of constants, gen_tables actually
   calculates it using the following function (for i <> 0): *)
Definition calc_FSb_nonzero(i: Z): int :=
  let x := pow3 (255 - log3 (Int.repr i)) in
  (Int.xor (Int.xor (Int.xor (Int.xor        x
                                      (rotl1 x))
                               (rotl1 (rotl1 x)))
                        (rotl1 (rotl1 (rotl1 x))))
        (Int.xor (rotl1 (rotl1 (rotl1 (rotl1 x)))) (Int.repr 99))).

(* the "repeat" and the "Qed." both take ~30s *)
Lemma FSb_equiv: forall i,
  1 <= i < 256 ->
  calc_FSb_nonzero i = Znth i FSb Int.zero.
Proof.
  intros.
  repeat match goal with
  | H : ?b <= i < 256 |- _ =>
    assert (i = b \/ b + 1 <= i < 256) as C by omega;
    destruct C as [C | C];
    [ subst i; vm_compute; reflexivity
    | clear H; rename C into H; simpl in H ]
  end.
  omega.
Qed.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.

Generalizable All Variables.

(* A Groupoid is a category where all morphisms are isomorphisms, and morphism
   equivalence is equivalence of isomorphisms. *)

Program Definition Groupoid (C : Category) : Category := {|
  obj     := @obj C;
  hom     := @Isomorphism C;
  homset  := @iso_setoid C;
  id      := @iso_id C;
  compose := @iso_compose C
|}.


Require Coq.Arith.Compare_dec.

Require Import Coq.Structures.OrderedType.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.FSets.FMapAVL.
Require Import Coq.FSets.FSetAVL.
Require Import Coq.Arith.Peano_dec.
Require Import Omega.

Require Import Aniceto.Map.

Require Coq.FSets.FMapFacts.

Inductive fid := finishid : nat -> fid.

Definition fid_nat r := match r with | finishid n => n end.

Definition fid_first := finishid 0.

Definition fid_next m := finishid (S (fid_nat m)).

Module FID <: UsualOrderedType.
  Definition t := fid.
  Definition eq := @eq fid.
  Definition lt x y := lt (fid_nat x) (fid_nat y).
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.
  Lemma lt_trans: forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    intros.
    unfold lt in *.
    destruct x, y, z.
    simpl in *.
    omega.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> x <> y.
  Proof.
    unfold lt in *.
    intros.
    destruct x, y.
    simpl in *.
    unfold not; intros.
    inversion H0.
    subst.
    apply Lt.lt_irrefl in H.
    inversion H.
  Qed.

  Import Coq.Arith.Compare_dec.
  Lemma compare:
    forall x y, Compare lt Logic.eq x y.
  Proof.
    intros.
    destruct x, y.
    destruct (Nat_as_OT.compare n n0);
    eauto using LT, GT.
    apply EQ.
    unfold Nat_as_OT.eq in *.
    subst.
    intuition.
  Defined.

  Lemma eq_dec : forall x y : t, {x = y} + {x <> y}.
  Proof.
    intros.
    unfold eq.
    destruct x, y.
    destruct (eq_nat_dec n n0).
    - subst; eauto.
    - right.
      unfold not.
      intros.
      contradiction n1.
      inversion H; auto.
  Defined.
End FID.

Module Map_FID := FMapAVL.Make FID.
Module Map_FID_Facts := FMapFacts.Facts Map_FID.
Module Map_FID_Props := FMapFacts.Properties Map_FID.
Module Map_FID_Extra := MapUtil Map_FID.
Module Set_FID := FSetAVL.Make FID.
Definition set_fid := Set_FID.t.
Lemma fid_eq_rw:
  forall (k k':fid), FID.eq k k' <-> k = k'.
Proof.
  intros.
  auto with *.
Qed.

Section NotIn.
  Variable elt:Type.

  Let lt_irrefl:
    forall x : fid, ~ FID.lt x x.
  Proof.
    unfold not; intros.
    apply FID.lt_not_eq in H.
    contradiction H.
    apply FID.eq_refl.
  Qed.

  Let lt_next:
    forall x, FID.lt x (fid_next x).
  Proof.
    intros.
    destruct x.
    unfold fid_next, fid_nat, FID.lt.
    simpl.
    auto.
  Qed.

  Let fid_impl_eq:
    forall k k' : fid, k = k' -> k = k'.
  Proof.
    auto.
  Qed.

  Definition supremum {elt:Type} := @Map_FID_Extra.supremum elt fid_first fid_next FID.lt FID.compare.

  Theorem find_not_in:
    forall (m: Map_FID.t elt),
    ~ Map_FID.In (supremum m) m.
  Proof.
    intros.
    eauto using Map_FID_Extra.find_not_in, FID.lt_trans.
  Qed.

End NotIn.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Require Import List.
Require Import ZArith.
Require Import Zorder.
Require Import ZCAux.
Require Import LucasLehmer.
Require Import Pocklington.
Require Import ZArith Znumtheory Zpow_facts.
Require Import CyclicAxioms Cyclic31 Int31.
From Bignums Require Import DoubleCyclic BigN.
Require Import Pmod.
Require Import Mod_op.
Require Import W.
Require Import Lucas.
Require Export PocklingtonCertificat.
Require Import NEll.
Import CyclicAxioms DoubleType DoubleBase List.

Open Scope Z_scope.

Section test.

Variable w: Type.
Variable w_op: ZnZ.Ops w.
Variable op_spec: ZnZ.Specs w_op.
Variable p: positive.
Variable b: w.

Notation "[| x |]" :=
   (ZnZ.to_Z x)  (at level 0, x at level 99).

Hypothesis b_pos: 0 < [|b|].

Variable m_op: mod_op w.
Variable m_op_spec: mod_spec w_op b m_op.

Open Scope positive_scope.
Open Scope P_scope.

Let pow := m_op.(power_mod).
Let times := m_op.(mul_mod).
Let pred:= m_op.(pred_mod).

(* [fold_pow_mod a [q1,_;...;qn,_]] b = a ^(q1*...*qn) mod b *)
(* invariant a mod N = a *)
Definition fold_pow_mod (a: w) l :=
  fold_left
    (fun a' (qp:positive*positive) =>  pow a' (fst qp))
    l a.

Lemma fold_pow_mod_spec : forall l (a:w),
  ([|a|] < [|b|])%Z -> [|fold_pow_mod a l|] = ([|a|]^(mkProd' l) mod [|b|])%Z.
intros l; unfold fold_pow_mod; elim l; simpl fold_left; simpl mkProd'; auto; clear l.
intros a H; rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith.
case (ZnZ.spec_to_Z a); auto with zarith.
intros (p1, q1) l Rec a H.
case (ZnZ.spec_to_Z a); auto with zarith; intros U1 U2.
rewrite Rec.
rewrite m_op_spec.(power_mod_spec) with (t := [|a|]); auto with zarith.
rewrite <- Zpower_mod.
rewrite times_Zmult; rewrite Zpower_mult; auto with zarith.
apply Z.le_lt_trans with (2 := H); auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite m_op_spec.(power_mod_spec) with (t := [|a|]); auto with zarith.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
rewrite Zmod_small; auto with zarith.
Qed.

Fixpoint all_pow_mod (prod a: w) (l:dec_prime) {struct l}: w*w :=
  match l with
  | nil => (prod,a)
  | (q,_) :: l =>
    let m := pred (fold_pow_mod a l) in
    all_pow_mod (times prod m) (pow a q) l
  end.

Lemma snd_all_pow_mod :
 forall l (prod a :w), ([|a|] < [|b|])%Z ->
   [|snd (all_pow_mod prod a l)|] = ([|a|]^(mkProd' l) mod [|b|])%Z.
intros l; elim l; simpl all_pow_mod; simpl mkProd'; simpl snd; clear l.
intros _ a H; rewrite Zpower_1_r; auto with zarith.
rewrite Zmod_small; auto with zarith.
case (ZnZ.spec_to_Z a); auto with zarith.
intros (p1, q1) l Rec prod a H.
case (ZnZ.spec_to_Z a); auto with zarith; intros U1 U2.
rewrite Rec; auto with zarith.
rewrite m_op_spec.(power_mod_spec) with (t := [|a|]); auto with zarith.
rewrite <- Zpower_mod.
rewrite times_Zmult; rewrite Zpower_mult; auto with zarith.
apply Z.le_lt_trans with (2 := H); auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite m_op_spec.(power_mod_spec) with (t := [|a|]); auto with zarith.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
rewrite Zmod_small; auto with zarith.
Qed.

Lemma fold_aux : forall a N l prod,
  (fold_left
     (fun (r : Z) (k : positive * positive) =>
      r * (a ^(N / fst k) - 1) mod [|b|]) l (prod mod [|b|]) mod [|b|] =
  fold_left
     (fun (r : Z) (k : positive * positive) =>
      r * (a^(N / fst k) - 1)) l prod mod [|b|])%Z.
induction l;simpl;intros.
rewrite Zmod_mod; auto with zarith.
rewrite <- IHl; auto with zarith.
rewrite Zmult_mod; auto with zarith.
rewrite Zmod_mod; auto with zarith.
rewrite <- Zmult_mod; auto with zarith.
Qed.

Lemma fst_all_pow_mod :
 forall l (a:w) (R:positive) (prod A :w),
  [|prod|] = ([|prod|] mod [|b|])%Z ->
  [|A|] = ([|a|]^R mod [|b|])%Z ->
  [|fst (all_pow_mod prod A l)|] =
    ((fold_left
      (fun r (k:positive*positive) =>
        (r * ([|a|] ^ (R* mkProd' l / (fst k)) - 1))) l [|prod|]) mod [|b|])%Z.
intros l; elim l; simpl all_pow_mod; simpl fold_left; simpl fst;
  auto with zarith; clear l.
intros (p1,q1) l Rec; simpl fst.
intros a R prod A H1 H2.
assert (F: (0 <= [|A|] < [|b|])%Z).
rewrite H2.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
assert (F1: ((fun x => x = x mod [|b|])%Z [|fold_pow_mod A l|])).
rewrite Zmod_small; auto.
rewrite fold_pow_mod_spec; auto with zarith.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
assert (F2: ((fun x => x = x mod [|b|])%Z [|pred (fold_pow_mod A l)|])).
rewrite Zmod_small; auto.
rewrite(fun x => m_op_spec.(pred_mod_spec) x [|x|]);
  auto with zarith.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
rewrite (Rec a (R * p1)%positive); auto with zarith.
rewrite(fun x y => m_op_spec.(mul_mod_spec) x y [|x|] [|y|]);
  auto with zarith.
rewrite(fun x => m_op_spec.(pred_mod_spec) x [|x|]);
  auto with zarith.
rewrite fold_pow_mod_spec; auto with zarith.
rewrite H2.
repeat rewrite Zpos_mult.
repeat rewrite times_Zmult.
repeat rewrite <- Zmult_assoc.
apply sym_equal; rewrite <- fold_aux; auto with zarith.
apply sym_equal; rewrite <- fold_aux; auto with zarith.
eq_tac; auto.
match goal with |- context[fold_left ?x  _ _] =>
  apply f_equal2 with (f := fold_left x); auto with zarith
end.
rewrite Zmod_mod; auto with zarith.
rewrite (Zmult_comm R); repeat rewrite <- Zmult_assoc;
 rewrite (Zmult_comm p1); rewrite Z_div_mult; auto with zarith.
repeat rewrite (Zmult_mod [|prod|]);auto with zmisc.
eq_tac; [idtac | eq_tac]; auto.
eq_tac; auto.
rewrite Zmod_mod; auto.
repeat rewrite (fun x => Zminus_mod x 1); auto with zarith.
eq_tac; auto; eq_tac; auto.
rewrite Zmult_comm; rewrite <- Zpower_mod; auto with zmisc.
rewrite Zpower_mult; auto with zarith.
rewrite Zmod_mod; auto with zarith.
rewrite Zmod_small; auto.
rewrite(fun x y => m_op_spec.(mul_mod_spec) x y [|x|] [|y|]);
  auto with zarith.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
rewrite(fun x => m_op_spec.(power_mod_spec) x [|x|]);
  auto with zarith.
apply trans_equal with ([|A|] ^ p1 mod [|b|])%Z; auto.
rewrite H2.
rewrite Zpos_mult_morphism; rewrite Zpower_mult; auto with zarith.
rewrite <- Zpower_mod; auto with zarith.
rewrite Zmod_small; auto.
Qed.

Fixpoint pow_mod_pred (a:w) (l:dec_prime) {struct l} : w :=
  match l with
  | nil => a
  | (q, p)::l =>
    if (p ?= 1) then pow_mod_pred a l
    else
      let a' := iter_pos _ (fun x => pow x q) a (Pos.pred p) in
      pow_mod_pred a' l
  end.

Lemma iter_pow_mod_spec : forall q p a, [|a|] = ([|a|] mod [|b|])%Z ->
  ([|iter_pos _ (fun x => pow x q) a p|] = [|a|]^q^p mod [|b|])%Z.
intros q1 p1; elim p1; simpl iter_pos; clear p1.
intros p1 Rec a Ha.
rewrite(fun x => m_op_spec.(power_mod_spec) x [|x|]);
  auto with zarith.
repeat rewrite Rec; auto with zarith.
match goal with |- (Zpower_pos ?X ?Y mod ?Z = _)%Z =>
  apply trans_equal with (X ^ Y mod Z)%Z; auto
end.
repeat rewrite <- Zpower_mod; auto with zmisc.
repeat rewrite <- Zpower_mult; auto with zmisc.
repeat rewrite <- Zpower_mod; auto with zmisc.
repeat rewrite <- Zpower_mult; auto with zarith zmisc.
eq_tac; auto.
eq_tac; auto.
rewrite Zpos_xI.
assert (tmp: forall x, (2 * x = x + x)%Z); auto with zarith; rewrite tmp;
  clear tmp.
repeat rewrite Zpower_exp; auto with zarith.
rewrite Zpower_1_r; try ring; auto with misc.
rewrite Zmod_mod; auto with zarith.
rewrite Rec; auto with zmisc.
rewrite Zmod_mod; auto with zarith.
rewrite Rec; auto with zmisc.
rewrite Zmod_mod; auto with zarith.
intros p1 Rec a Ha.
repeat rewrite Rec; auto with zarith.
repeat rewrite <- Zpower_mod; auto with zmisc.
repeat rewrite <- Zpower_mult; auto with zmisc.
eq_tac; auto.
eq_tac; auto.
rewrite Zpos_xO.
assert (tmp: forall x, (2 * x = x + x)%Z); auto with zarith; rewrite tmp;
  clear tmp.
repeat rewrite Zpower_exp; auto with zarith.
rewrite Zmod_mod; auto with zarith.
intros a Ha; rewrite Zpower_1_r; auto with zarith.
rewrite(fun x => m_op_spec.(power_mod_spec) x [|x|]);
  auto with zarith.
Qed.

Lemma pow_mod_pred_spec : forall l a,
  ([|a|] = [|a|] mod [|b|] ->
  [|pow_mod_pred a l|] = [|a|]^(mkProd_pred l) mod [|b|])%Z.
intros l; elim l; simpl pow_mod_pred; simpl mkProd_pred; clear l.
intros; rewrite Zpower_1_r; auto with zarith.
intros (p1,q1) l Rec a H; simpl snd; simpl fst.
case (q1 ?= 1)%P; auto with zarith.
rewrite Rec; auto.
rewrite iter_pow_mod_spec; auto with zarith.
rewrite times_Zmult; rewrite pow_Zpower.
rewrite <- Zpower_mod; auto with zarith.
rewrite Zpower_mult; auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite iter_pow_mod_spec; auto with zarith.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
Qed.

End test.

Require Import Bits.

Definition test_pock N a dec sqrt :=
  if (2 ?< N) then
    let Nm1 := Pos.pred N in
    let F1 := mkProd dec in
    match (Nm1 / F1)%P with
    | (Npos R1, N0) =>
      if is_odd R1 then
        if is_even F1 then
          if (1 ?< a) then
            let (s,r') := (R1 / (xO F1))%P in
            match r' with
            | Npos r =>
              if (a ?< N) then
              let op := cmk_op (Peano.pred (nat_of_P (get_height 31 (plength N)))) in
              let wN := znz_of_Z op (Zpos N) in
              let wa := znz_of_Z op (Zpos a) in
              let w1 := znz_of_Z op 1 in
              let mod_op := make_mod_op op wN in
              let pow := mod_op.(power_mod) in
              let ttimes := mod_op.(mul_mod) in
              let pred:= mod_op.(pred_mod) in
              let gcd:= ZnZ.gcd in
              let A := pow_mod_pred _ mod_op (pow wa R1) dec in
              match all_pow_mod _ mod_op w1 A dec with
              | (p, aNm1) =>
                match ZnZ.to_Z aNm1 with
                  (Zpos xH) =>
                   match ZnZ.to_Z (gcd p wN) with
                   (Zpos xH) =>
                    if check_s_r s r sqrt then
		      (N ?< (times ((times ((xO F1)+r+1) F1) + r) F1) + 1)
                    else false
                   | _ => false
                   end
                 | _ => false
                end
              end else false
            | _ => false
            end
	  else false
        else false
      else false
    | _=> false
    end
  else false.

Lemma test_pock_correct : forall N a dec sqrt,
   (forall k, In k dec -> prime (Zpos (fst k))) ->
   test_pock N a dec sqrt = true ->
   prime N.
unfold test_pock;intros N a dec sqrt H.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If1; auto
end.
2: intros; discriminate.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
generalize (div_eucl_spec (Pos.pred N) (mkProd dec));
 destruct ((Pos.pred N) / (mkProd dec))%P as (R1,n).
simpl fst; simpl snd; intros (H1, H2).
destruct R1 as [ |R1].
intros; discriminate.
destruct n.
2: intros; discriminate.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If2; auto
end.
assert (If0: Zodd R1).
apply is_odd_Zodd; auto.
clear If2; rename If0 into If2.
2: intros; discriminate.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If3; auto
end.
assert (If0: Zeven (mkProd dec)).
apply is_even_Zeven; auto.
clear If3; rename If0 into If3.
2: intros; discriminate.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If4; auto
end.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
2: intros; discriminate.
generalize (div_eucl_spec R1 (xO (mkProd dec)));
 destruct ((R1 / xO (mkProd dec))%P) as (s,r'); simpl fst;
 simpl snd; intros (H3, H4).
destruct r' as [ |r].
intros; discriminate.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If5; auto
end.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
2: intros; discriminate.
set (bb := Peano.pred (nat_of_P (get_height 31 (plength N)))).
set (w_op := cmk_op bb).
assert (op_spec: ZnZ.Specs w_op).
unfold bb, w_op; apply cmk_spec; auto.
assert (F0: N < DoubleType.base (ZnZ.digits w_op)).
  apply Z.lt_le_trans with (1 := plength_correct N).
  unfold w_op, DoubleType.base.
  rewrite cmk_op_digits.
  apply Zpower_le_monotone; split; auto with zarith.
  generalize (get_height_correct 31 (plength N)); unfold bb.
  set (p := plength N).
  replace (Z_of_nat (Peano.pred (nat_of_P (get_height 31 p)))) with
       ((Zpos (get_height 31 p) - 1) ); auto with zarith.
  rewrite pred_of_minus; rewrite inj_minus1; auto with zarith.
  rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto with zarith.
  generalize (lt_O_nat_of_P (get_height 31 p)); auto with zarith.
assert (F1: ZnZ.to_Z (ZnZ.of_Z N) = N).
rewrite ZnZ.of_Z_correct; auto with zarith.
assert (F2: 1 < ZnZ.to_Z (ZnZ.of_Z N)).
rewrite F1; auto with zarith.
assert (F3: 0 < ZnZ.to_Z (ZnZ.of_Z N)); auto with zarith.
assert (F4: ZnZ.to_Z (ZnZ.of_Z a) = a).
rewrite ZnZ.of_Z_correct; auto with zarith.
assert (F5: ZnZ.to_Z (ZnZ.of_Z 1) = 1).
rewrite ZnZ.of_Z_correct; auto with zarith.
assert (F6: N - 1 = (R1 * mkProd_pred dec)%positive * mkProd' dec).
rewrite Zpos_mult.
rewrite <- Zmult_assoc; rewrite mkProd_pred_mkProd; auto with zarith.
simpl in H1; rewrite Zpos_mult in H1; rewrite <- H1; rewrite Ppred_Zminus;
  auto with zarith.
assert (m_spec: mod_spec w_op (znz_of_Z w_op N)
                  (make_mod_op w_op (znz_of_Z w_op N))).
apply make_mod_spec; auto with zarith.
match goal with |- context[all_pow_mod ?x ?y ?z ?t ?u] =>
  generalize (fst_all_pow_mod x w_op op_spec _ F3 _ m_spec
               u (znz_of_Z w_op a) (R1*mkProd_pred dec) z t);
  generalize (snd_all_pow_mod x w_op op_spec _ F3 _ m_spec u z t);
  fold bb w_op;
  case (all_pow_mod x y z t u); simpl fst; simpl snd
end.
intros prod aNm1; intros H5 H6.
case_eq (ZnZ.to_Z aNm1).
intros; discriminate.
2: intros; discriminate.
intros p; case p; clear p.
intros; discriminate.
intros; discriminate.
intros If6.
case_eq (ZnZ.to_Z (ZnZ.gcd prod (znz_of_Z w_op N))).
intros; discriminate.
2: intros; discriminate.
intros p; case p; clear p.
intros; discriminate.
intros; discriminate.
intros If7.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If8; auto
end.
2: intros; discriminate.
intros If9.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
assert (U1: N - 1 = mkProd dec * R1).
rewrite <- Ppred_Zminus in H1; auto with zarith.
rewrite H1; simpl.
repeat rewrite Zpos_mult; auto with zarith.
assert (HH:Z_of_N s = R1 / (2 * mkProd dec) /\ Zpos r =  R1 mod (2 * mkProd dec)).
apply mod_unique with (2 * mkProd dec);auto with zarith.
apply Z_mod_lt; auto with zarith.
rewrite <- Z_div_mod_eq; auto with zarith.
rewrite H3.
rewrite (Zpos_xO (mkProd dec)).
simpl Z_of_N; ring.
case HH; clear HH; intros HH1 HH2.
apply PocklingtonExtra with (F1:=mkProd dec) (R1:=R1) (m:=1);
  auto with zmisc zarith.
case (Zle_lt_or_eq 1 (mkProd dec)); auto with zarith.
simpl in H2; auto with zarith.
intros HH; contradict If3; rewrite <- HH.
apply Zodd_not_Zeven; red; auto.
intros p; case p; clear p.
intros HH; contradict HH.
apply not_prime_0.
2: intros p (V1, _); contradict V1; apply Zle_not_lt; red; simpl; intros;
     discriminate.
intros p Hprime Hdec; exists (Zpos a);repeat split; auto with zarith.
apply trans_equal with (2 := If6).
rewrite H5.
rewrite pow_mod_pred_spec with (2 := m_spec); auto with zarith.
rewrite F1.
rewrite m_spec.(power_mod_spec) with (t := a); auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
rewrite F1; rewrite F4.
rewrite <- Zpower_mod; auto with zarith.
rewrite <- Zpower_mult; auto with zarith.
rewrite mkProd_pred_mkProd; auto with zarith.
rewrite U1; rewrite Zmult_comm.
rewrite Zpower_mult; auto with zarith.
rewrite <- Zpower_mod; auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
rewrite F1; rewrite F4; rewrite Zmod_small; auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite m_spec.(power_mod_spec) with (t := a); auto with zarith.
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
rewrite F1; rewrite F4; rewrite Zmod_small; auto with zarith.
rewrite pow_mod_pred_spec with (2 := m_spec); auto with zarith.
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
rewrite Zmod_small; auto with zarith.
rewrite m_spec.(power_mod_spec) with (t := a); auto with zarith.
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
rewrite F1; rewrite F4; rewrite Zmod_small; auto with zarith.
match type of H6 with _ -> _ -> ?X =>
  assert (tmp: X); [apply H6 | clear H6; rename tmp into H6];
  auto with zarith
end.
rewrite F1.
change (znz_of_Z w_op 1) with (ZnZ.of_Z 1).
rewrite F5; rewrite Zmod_small; auto with zarith.
rewrite pow_mod_pred_spec with (2 := m_spec); auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4).
rewrite m_spec.(power_mod_spec) with (t := a); auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4).
rewrite Zpos_mult; rewrite <- Zpower_mod; auto with zarith.
rewrite Zpower_mult; auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4).
rewrite Zmod_small; auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4).
rewrite Zmod_small; auto with zarith.
rewrite (power_mod_spec m_spec) with (t := a); auto with zarith.
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4); auto.
rewrite Zmod_small; auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N); auto.
auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a) in H6.
change (znz_of_Z w_op N) with (ZnZ.of_Z N) in H6.
change (znz_of_Z w_op 1) with (ZnZ.of_Z 1) in H6.
rewrite F5 in H6; rewrite F1 in H6; rewrite F4 in H6.
case in_mkProd_prime_div_in with (3 := Hdec); auto.
intros p1 Hp1.
rewrite <- F6 in H6.
apply Zis_gcd_gcd; auto with zarith.
change (rel_prime (a ^ ((N - 1) / p) - 1) N).
match type of H6 with _ = ?X mod _ =>
  apply rel_prime_div with (p := X); auto with zarith
end.
apply rel_prime_mod_rev; auto with zarith.
red.
pattern 1 at 4; rewrite <- If7; rewrite <- H6.
pattern N at 2; rewrite <- F1.
apply ZnZ.spec_gcd; auto with zarith.
assert (foldtmp: forall (A B: Set) (f: A -> B -> A) (P: A -> Prop) l a b,
  In b l -> (forall x, P (f x b)) ->
  (forall x y, P x -> P (f x y)) ->
  P (fold_left f l a)).
assert (foldtmp0: forall (A B: Set) (f: A -> B -> A) (P: A -> Prop) l a,
  P a ->
  (forall x y, P x -> P (f x y)) ->
  P (fold_left f l a)).
intros A B f P l; elim l; simpl; auto.
intros A B f P l; elim l; simpl; auto.
intros a1 b HH; case HH.
intros a1 l1 Rec a2 b [V|V] V1 V2; subst; auto.
apply foldtmp0; auto.
apply Rec with (b := b); auto with zarith.
match goal with |- context [fold_left ?f _ _] =>
 apply (foldtmp _ _ f (fun k => Z.divide (a ^ ((N - 1) / p) - 1) k))
   with (b := (p, p1)); auto with zarith
end.
rewrite <- HH2.
clear F0; match goal with H: ?X < ?Y |- ?X < ?Z =>
 replace Z with Y; auto
end.
repeat (rewrite Zpos_plus || rewrite Zpos_mult || rewrite times_Zmult).
rewrite Zpos_xO; ring.
rewrite <- HH1; rewrite <- HH2.
apply check_s_r_correct with sqrt; auto.
Qed.

(* Simple version of pocklington for primo *)
Definition test_spock N a dec :=
  if (2 ?< N) then
    let Nm1 := Pos.pred N in
    let F1 := mkProd dec in
    match (Nm1 / F1)%P with
    | (Npos R1, N0) =>
          if (1 ?< a) then
            if (a ?< N) then
              if (N ?< F1 * F1) then
              let op := cmk_op (Peano.pred (nat_of_P (get_height 31 (plength N)))) in
              let wN := znz_of_Z op (Zpos N) in
              let wa := znz_of_Z op (Zpos a) in
              let w1 := znz_of_Z op 1 in
              let mod_op := make_mod_op op wN in
              let pow := mod_op.(power_mod) in
              let ttimes := mod_op.(mul_mod) in
              let pred:= mod_op.(pred_mod) in
              let gcd:= ZnZ.gcd in
              let A := pow_mod_pred _ mod_op (pow wa R1) dec in
              match all_pow_mod _ mod_op w1 A dec with
              | (p, aNm1) =>
                match ZnZ.to_Z aNm1 with
                  (Zpos xH) =>
                   match ZnZ.to_Z (gcd p wN) with
                   (Zpos xH) => true
                   | _ => false
                   end
                 | _ => false
                end
              end else false
           else false
         else false
    | _=> false
    end
  else false.

Lemma test_spock_correct : forall N a dec,
   (forall k, In k dec -> prime (Zpos (fst k))) ->
   test_spock N a dec = true ->
   prime N.
unfold test_spock;intros N a dec H.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If1; auto
end.
2: intros; discriminate.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
generalize (div_eucl_spec (Pos.pred N) (mkProd dec));
 destruct ((Pos.pred N) / (mkProd dec))%P as (R1,n).
simpl fst; simpl snd; intros (H1, H2).
destruct R1 as [ |R1].
intros; discriminate.
destruct n.
2: intros; discriminate.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If2; auto
end.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
2: intros; discriminate.
(*
set (bb := pred (nat_of_P (get_height 31 (plength N)))).
set (w_op := cmk_op bb).
assert (op_spec: znz_spec w_op).
unfold bb, w_op; apply cmk_spec; auto.
assert (F0: N < Basic_type.base (znz_digits w_op)).
  apply Z.lt_le_trans with (1 := plength_correct N).
  unfold w_op, Basic_type.base.
  rewrite cmk_op_digits.
  apply Zpower_le_monotone; split; auto with zarith.
  generalize (get_height_correct 31 (plength N)); unfold bb.
  set (p := plength N).
  replace (Z_of_nat (pred (nat_of_P (get_height 31 p)))) with
       ((Zpos (get_height 31 p) - 1) ); auto with zarith.
  rewrite pred_of_minus; rewrite inj_minus1; auto with zarith.
  rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto with zarith.
  generalize (lt_O_nat_of_P (get_height 31 p)); auto with zarith.
*)
set (bb := Peano.pred (nat_of_P (get_height 31 (plength N)))).
set (w_op := cmk_op bb).
assert (op_spec: ZnZ.Specs w_op).
unfold bb, w_op; apply cmk_spec; auto.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If3; auto
end.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If4; auto
end.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
assert (F0: N < DoubleType.base (ZnZ.digits w_op)).
  apply Z.lt_le_trans with (1 := plength_correct N).
  unfold w_op, DoubleType.base.
  rewrite cmk_op_digits.
  apply Zpower_le_monotone; split; auto with zarith.
  generalize (get_height_correct 31 (plength N)); unfold bb.
  set (p := plength N).
  replace (Z_of_nat (Peano.pred (nat_of_P (get_height 31 p)))) with
       ((Zpos (get_height 31 p) - 1) ); auto with zarith.
  rewrite pred_of_minus; rewrite inj_minus1; auto with zarith.
  rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto with zarith.
  generalize (lt_O_nat_of_P (get_height 31 p)); auto with zarith.
assert (F1: ZnZ.to_Z (ZnZ.of_Z N) = N).
rewrite ZnZ.of_Z_correct; auto with zarith.
assert (F2: 1 < ZnZ.to_Z (ZnZ.of_Z N)).
rewrite F1; auto with zarith.
assert (F3: 0 < ZnZ.to_Z (ZnZ.of_Z N)); auto with zarith.
assert (F4: ZnZ.to_Z (ZnZ.of_Z a) = a).
rewrite ZnZ.of_Z_correct; auto with zarith.
assert (F5: ZnZ.to_Z (ZnZ.of_Z 1) = 1).
rewrite ZnZ.of_Z_correct; auto with zarith.
assert (F6: N - 1 = (R1 * mkProd_pred dec)%positive * mkProd' dec).
rewrite Zpos_mult.
rewrite <- Zmult_assoc; rewrite mkProd_pred_mkProd; auto with zarith.
simpl in H1; rewrite Zpos_mult in H1; rewrite <- H1; rewrite Ppred_Zminus;
  auto with zarith.
assert (m_spec: mod_spec w_op (znz_of_Z w_op N)
                  (make_mod_op w_op (znz_of_Z w_op N))).
apply make_mod_spec; auto with zarith.
match goal with |- context[all_pow_mod ?x ?y ?z ?t ?u] =>
  generalize (fst_all_pow_mod x w_op op_spec _ F3 _ m_spec
               u (znz_of_Z w_op a) (R1*mkProd_pred dec) z t);
  generalize (snd_all_pow_mod x w_op op_spec _ F3 _ m_spec u z t);
  fold bb w_op;
  case (all_pow_mod x y z t u); simpl fst; simpl snd
end.
2: intros; discriminate.
intros prod aNm1; intros H5 H6.
case_eq (ZnZ.to_Z aNm1).
intros; discriminate.
2: intros; discriminate.
intros p; case p; clear p.
intros; discriminate.
intros; discriminate.
intros If5.
case_eq (ZnZ.to_Z (ZnZ.gcd prod (znz_of_Z w_op N))).
intros; discriminate.
2: intros; discriminate.
intros p; case p; clear p.
intros; discriminate.
intros; discriminate.
intros If6 _.
assert (U1: N - 1 = mkProd dec * R1).
rewrite <- Ppred_Zminus in H1; auto with zarith.
rewrite H1; simpl.
repeat rewrite Zpos_mult; auto with zarith.
apply PocklingtonCorollary1 with (F1:=mkProd dec) (R1:=R1);
  auto with zmisc zarith.
case (Zle_lt_or_eq 1 (mkProd dec)); auto with zarith.
simpl in H2; auto with zarith.
intros HH; contradict If4; rewrite Zpos_mult_morphism;
  rewrite <- HH.
apply Zle_not_lt; auto with zarith.
intros p; case p; clear p.
intros HH; contradict HH.
apply not_prime_0.
2: intros p (V1, _); contradict V1; apply Zle_not_lt; red; simpl; intros;
     discriminate.
intros p Hprime Hdec; exists (Zpos a);repeat split; auto with zarith.
apply trans_equal with (2 := If5).
rewrite H5.
rewrite pow_mod_pred_spec with (2 := m_spec); auto with zarith.
rewrite F1.
rewrite m_spec.(power_mod_spec) with (t := a); auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
rewrite F1; rewrite F4.
rewrite <- Zpower_mod; auto with zarith.
rewrite <- Zpower_mult; auto with zarith.
rewrite mkProd_pred_mkProd; auto with zarith.
rewrite U1; rewrite Zmult_comm.
rewrite Zpower_mult; auto with zarith.
rewrite <- Zpower_mod; auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
rewrite F1; rewrite F4; rewrite Zmod_small; auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
rewrite Zmod_small; auto with zarith.
rewrite m_spec.(power_mod_spec) with (t := a); auto with zarith.
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
rewrite F1; rewrite F4; rewrite Zmod_small; auto with zarith.
rewrite pow_mod_pred_spec with (2 := m_spec); auto with zarith.
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
rewrite Zmod_small; auto with zarith.
rewrite m_spec.(power_mod_spec) with (t := a); auto with zarith.
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
rewrite F1; rewrite F4; rewrite Zmod_small; auto with zarith.
match type of H6 with _ -> _ -> ?X =>
  assert (tmp: X); [apply H6 | clear H6; rename tmp into H6];
  auto with zarith
end.
rewrite F1.
change (znz_of_Z w_op 1) with (ZnZ.of_Z 1).
rewrite F5; rewrite Zmod_small; auto with zarith.
rewrite pow_mod_pred_spec with (2 := m_spec); auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
repeat (rewrite F1 || rewrite F4).
rewrite m_spec.(power_mod_spec) with (t := a); auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4).
rewrite Zpos_mult; rewrite <- Zpower_mod; auto with zarith.
rewrite Zpower_mult; auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4).
rewrite Zmod_small; auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite m_spec.(power_mod_spec) with (t := a); auto with zarith.
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
repeat (rewrite F1 || rewrite F4).
rewrite Zmod_small; auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N) in H6.
change (znz_of_Z w_op a) with (ZnZ.of_Z a) in H6.
change (znz_of_Z w_op 1) with (ZnZ.of_Z 1) in H6.
rewrite F5 in H6; rewrite F1 in H6; rewrite F4 in H6.
case in_mkProd_prime_div_in with (3 := Hdec); auto.
intros p1 Hp1.
rewrite <- F6 in H6.
apply Zis_gcd_gcd; auto with zarith.
change (rel_prime (a ^ ((N - 1) / p) - 1) N).
match type of H6 with _ = ?X mod _ =>
  apply rel_prime_div with (p := X); auto with zarith
end.
apply rel_prime_mod_rev; auto with zarith.
red.
pattern 1 at 4; rewrite <- If6; rewrite <- H6.
pattern N at 2; rewrite <- F1.
apply ZnZ.spec_gcd; auto with zarith.
assert (foldtmp: forall (A B: Set) (f: A -> B -> A) (P: A -> Prop) l a b,
  In b l -> (forall x, P (f x b)) ->
  (forall x y, P x -> P (f x y)) ->
  P (fold_left f l a)).
assert (foldtmp0: forall (A B: Set) (f: A -> B -> A) (P: A -> Prop) l a,
  P a ->
  (forall x y, P x -> P (f x y)) ->
  P (fold_left f l a)).
intros A B f P l; elim l; simpl; auto.
intros A B f P l; elim l; simpl; auto.
intros a1 b HH; case HH.
intros a1 l1 Rec a2 b [V|V] V1 V2; subst; auto.
apply foldtmp0; auto.
apply Rec with (b := b); auto with zarith.
match goal with |- context [fold_left ?f _ _] =>
 apply (foldtmp _ _ f (fun k => Z.divide (a ^ ((N - 1) / p) - 1) k))
   with (b := (p, p1)); auto with zarith
end.
intros; discriminate.
Qed.

Fixpoint test_Certif (lc : Certif) : bool :=
  match lc with
  | nil => true
  | (Proof_certif _ _) :: lc => test_Certif lc
  | (Lucas_certif n p) :: lc =>
     let xx := test_Certif lc in
     if xx then
     let yy := gt2 p in
     if yy then
       match p with
         Zpos p1 =>
           let zz := Mp p in
           match zz with
          | Zpos n' =>
             if (n ?= n')%P then
               let tt :=  lucas p1 in
               match tt with
               | Z0 => true
               | _ => false
               end
             else false
           | _ => false
           end
         | _ => false
       end
    else false
    else false
  | (Pock_certif n a dec sqrt) :: lc =>
    let xx := test_pock n a dec sqrt in
    if xx then
      let yy := all_in lc dec in
      (if yy then test_Certif lc else false)
    else false
  | (SPock_certif n a dec) :: lc =>
    let xx :=test_spock n a dec in
    if xx then
      let yy := all_in lc dec in
      (if yy then test_Certif lc else false)
    else false
  | (Ell_certif n ss l a b x y) :: lc =>
    let xx := ell_test n ss l a b x y in
    if xx then
     let yy :=  all_in lc l in
     if yy then test_Certif lc else false
    else false
  end.

Lemma test_Certif_In_Prime :
  forall lc, test_Certif lc = true ->
   forall c, In c lc -> prime (nprim c).
intros lc; elim lc; simpl; auto.
intros _ c H; case H.
intros a; case a; simpl; clear a lc.
intros N p l Rec H c [H1 | H1]; subst; auto with arith.
intros n p l; case (test_Certif l); auto with zarith.
2: intros; discriminate.
intros H H1 c [H2 | H2]; subst; auto with arith.
simpl nprim.
generalize H1; clear H1.
case_eq (gt2 p).
2: intros; discriminate.
case p; clear p; try (intros; discriminate; fail).
unfold gt2; intros p H1.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
unfold Mp; case_eq (2 ^ p  -1); try (intros; discriminate; fail).
intros p1 Hp1.
case_eq (n ?= p1)%P; try rewrite <- Hp1.
2: intros; discriminate.
intros H2.
match goal with H: (?X ?= ?Y)%P = true |- _ =>
  generalize (is_eq_eq _ _ H); clear H; intros H
end.
generalize (lucas_prime H1); rewrite Hp1; rewrite <- H2.
case (lucas p); try (intros; discriminate; fail); auto.
intros N a d p l H.
generalize (test_pock_correct N a d p).
case (test_pock N a d p); auto.
2: intros; discriminate.
generalize (all_in_In l d).
case (all_in l d).
2: intros; discriminate.
intros H1 H2 H3 c [H4 | H4]; subst; simpl; auto.
apply H2; auto.
intros k Hk.
case H1 with (2 := Hk); auto.
intros x (Hx1, Hx2); rewrite Hx2; auto.
intros N a d l H.
generalize (test_spock_correct N a d).
case test_spock; auto.
2: intros; discriminate.
generalize (all_in_In l d).
case (all_in l d).
2: intros; discriminate.
intros H1 H2 H3 c [H4 | H4]; subst; simpl; auto.
apply H2; auto.
intros k Hk.
case H1 with (2 := Hk); auto.
intros x (Hx1, Hx2); rewrite Hx2; auto.
intros N S l A B x y l1.
generalize (all_in_In l1 l).
generalize (ell_test_correct N S l A B x y).
case ell_test.
case all_in; auto.
intros H1 H2 H3 H4 c [H5 | H5]; try subst c; simpl; auto.
apply H1.
intros p Hp; case (H2 (refl_equal true) p); auto.
intros x1 (Hx1, Hx2); rewrite Hx2; auto.
intros; discriminate.
intros; discriminate.
Qed.

Lemma Pocklington_refl :
  forall c lc, test_Certif (c::lc) = true -> prime (nprim c).
Proof.
 intros c lc Heq;apply test_Certif_In_Prime with (c::lc);trivial;simpl;auto.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import eqtype seq.
From ipcssr Require Import prelude forms.

Inductive proof_term A : Type :=
  | Var   : nat -> proof_term A
  | Efq   : proof_term A -> form A -> proof_term A
  | Abs   : form A -> proof_term A -> proof_term A
  | App   : form A -> proof_term A -> proof_term A -> proof_term A
  | Pair  : proof_term A -> proof_term A -> proof_term A
  | PrL   : form A -> proof_term A -> proof_term A
  | PrR   : form A -> proof_term A -> proof_term A
  | OrFL  : proof_term A -> form A -> proof_term A
  | OrFR  : proof_term A -> form A -> proof_term A
  | Cas   : form A -> form A -> proof_term A -> proof_term A -> proof_term A -> proof_term A
  | Shift : proof_term A -> proof_term A.

Arguments Var [A].
Arguments Efq [A].
Arguments Abs [A].
Arguments App [A].
Arguments Pair [A].
Arguments PrL [A].
Arguments PrR [A].
Arguments OrFL [A].
Arguments OrFR [A].
Arguments Cas [A].
Arguments Shift [A].

Section Derivation.
Context {A : Type}.

Inductive derives : seq (form A) -> proof_term A -> form A -> Prop :=
| ByAssumption g n a    :
    onth g n = Some a -> derives g (Var n) a
| ByAbsurdity g t a     :
    derives g t Falsum -> derives g (Efq t a) a
| ImpIntro g a r b      :
    derives (a :: g) r b -> derives g (Abs a r) (Imp a b)
| ImpElim g r s a b     :
    derives g r (Imp a b) -> derives g s a -> derives g (App a r s) b
| AndFIntro g r s a b   :
    derives g r a -> derives g s b -> derives g (Pair r s) (AndF a b)
| AndFElimL g r a b     :
    derives g r (AndF a b) -> derives g (PrL b r) a
| AndFElimR g r a b     :
    derives g r (AndF a b) -> derives g (PrR a r) b
| OrFIntroL g r a b     :
    derives g r a -> derives g (OrFL r b) (OrF a b)
| OrFIntroR g r a b     :
    derives g r b -> derives g (OrFR r a) (OrF a b)
| OrFElim g r s t a b c :
    derives g r (OrF a b) -> derives (a :: g) s c -> derives (b :: g) t c -> derives g (Cas a b r s t) c
| ShiftIntro g r a b    :
    derives g r b -> derives (a :: g) (Shift r) b.

Lemma derives_rec (P : seq (form A) -> proof_term A -> form A -> Type) :
  (forall g n a,
     onth g n = Some a -> P g (Var n) a) ->
  (forall g t a,
     derives g t Falsum -> P g t Falsum -> P g (Efq t a) a) ->
  (forall g a r b,
     derives (a :: g) r b -> P (a :: g) r b -> P g (Abs a r) (Imp a b)) ->
  (forall g r s a b,
     derives g r (Imp a b) -> P g r (Imp a b) ->
     derives g s a -> P g s a -> P g (App a r s) b) ->
  (forall g r s a b,
     derives g r a -> P g r a ->
     derives g s b -> P g s b -> P g (Pair r s) (AndF a b)) ->
  (forall g r a b,
     derives g r (AndF a b) -> P g r (AndF a b) -> P g (PrL b r) a) ->
  (forall g r a b,
     derives g r (AndF a b) -> P g r (AndF a b) -> P g (PrR a r) b) ->
  (forall g r a b,
     derives g r a -> P g r a -> P g (OrFL r b) (OrF a b)) ->
  (forall g r a b,
     derives g r b -> P g r b -> P g (OrFR r a) (OrF a b)) ->
  (forall g r s t a b c,
     derives g r (OrF a b) -> P g r (OrF a b) ->
     derives (a :: g) s c -> P (a :: g) s c ->
     derives (b :: g) t c -> P (b :: g) t c -> P g (Cas a b r s t) c) ->
  (forall g r a b,
     derives g r b -> P g r b -> P (a :: g) (Shift r) b) ->
  forall g t a, derives g t a -> P g t a.
Proof.
move=>var efq abs app par prl prr orl orr cas shift /[swap]; elim.
- move=>n g a H; apply: var.
  by case: {-1}_ _ / H (erefl (@Var A n))=>// ???<-; case=>->.
- move=>t IH f g a H.
  have [-> Hd]: a = f /\ derives g t Falsum
    by case: {-1}_ _ / H (erefl (Efq t f))=>// ???? [-> ->].
  by apply: efq=>//; apply: IH.
- move=>f t IH g'; case.
  - move=>H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (Abs f t)) (erefl (@Falsum A)).
  - move=>a H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (Abs f t)) (erefl (Atom a)).
  - move=>f0 f1 H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (Abs f t)) (erefl (AndF f0 f1)).
  - move=>f0 f1 H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (Abs f t)) (erefl (OrF f0 f1)).
  move=>f0 f1 H.
  have [-> Hd]: f = f0 /\ derives (f0 :: g') t f1
    by case: _ {1}_ {1}_ / H (erefl (Abs f t)) (erefl (Imp f0 f1))=>// ????? [<-<-][<-<-].
  by apply: abs=>//; apply: IH.
- move=>f t IHt q IHq g a H.
  have [Hd1 Hd2]: derives g t (Imp f a) /\ derives g q f
    by case: _ {1}_ {1}_ / H (erefl (App f t q))=>// ??????? [<-<-<-].
  by apply: app=>//; [apply: IHt|apply: IHq].
- move=>l IHl r IHr g; case.
  - move=>H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (Pair l r)) (erefl (@Falsum A)).
  - move=>a H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (Pair l r)) (erefl (Atom a)).
  - move=>f0 f1 H.
    have [Hl Hr] : derives g l f0 /\ derives g r f1
      by case: _ {1}_ {1}_ / H (erefl (Pair l r)) (erefl (AndF f0 f1))=>// ??????? [<-<-][<-<-].
    by apply: par=>//; [apply: IHl|apply: IHr].
  - move=>f0 f1 H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (Pair l r)) (erefl (OrF f0 f1)).
  move=>f0 f1 H; exfalso.
  by case: {-1}_ {1}_ {1}_ / H (erefl (Pair l r)) (erefl (Imp f0 f1)).
- move=>b p IH g a H.
  have Hd: derives g p (AndF a b)
    by case: _ {1}_ {1}_ / H (erefl (PrL b p))=>// ????? [<-<-].
  by apply: prl =>//; apply: IH.
- move=>a p IH g b H.
  have Hd: derives g p (AndF a b)
    by case: _ {1}_ {1}_ / H (erefl (PrR a p))=>// ????? [<-<-].
  by apply: prr =>//; apply: IH.
- move=>p IH f g; case.
  - move=>H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (OrFL p f)) (erefl (@Falsum A)).
  - move=>a H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (OrFL p f)) (erefl (Atom a)).
  - move=>f0 f1 H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (OrFL p f)) (erefl (AndF f0 f1)).
  - move=>f0 f1 H.
    have [-> Hd] : f = f1 /\ derives g p f0.
    - by case: _ {1}_ {1}_ / H (erefl (OrFL p f)) (erefl (OrF f0 f1))=>// ????? [<-<-][<-<-].
    by apply: orl=>//; apply: IH.
  move=>f0 f1 H; exfalso.
  by case: _ {1}_ {1}_ / H (erefl (OrFL p f)) (erefl (Imp f0 f1)).
- move=>p IH f g; case.
  - move=>H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (OrFR p f)) (erefl (@Falsum A)).
  - move=>a H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (OrFR p f)) (erefl (Atom a)).
  - move=>f0 f1 H; exfalso.
    by case: {-1}_ {1}_ {1}_ / H (erefl (OrFR p f)) (erefl (AndF f0 f1)).
  - move=>f0 f1 H.
    have [-> Hd] : f = f0 /\ derives g p f1.
    - by case: _ {1}_ {1}_ / H (erefl (OrFR p f)) (erefl (OrF f0 f1))=>// ????? [<-<-][<-<-].
    by apply: orr=>//; apply: IH.
  move=>f0 f1 H; exfalso.
  by case: _ {1}_ {1}_ / H (erefl (OrFR p f)) (erefl (Imp f0 f1)).
- move=>a b r IHr s IHs t IHt g c H.
  have [Hdr Hds Hdt] : [/\ derives g r (OrF a b), derives (a :: g) s c & derives (b :: g) t c].
  - by case: _ {1}_ _ / H (erefl (Cas a b r s t))=>// ?????????? [<-<-<-<-<-].
  by apply: cas=>//; [apply: IHr|apply: IHs|apply: IHt].
move=>r IH + a; case=>[|f g'] H.
- exfalso.
  by case: {-1}_ {1}_ {1}_ / H (erefl (@nil (form A))) (erefl (Shift r)).
have Hd: derives g' r a.
- by case: {-1}_ {1}_ {1}_ / H (erefl (f::g')) (erefl (Shift r))=>// ????? [_ ->][<-].
by apply: shift=>//; apply: IH.
Qed.

End Derivation.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import div fintype bigop order ssralg finset fingroup.
From mathcomp Require Import ssrnum.

(******************************************************************************)
(* This file provide support for intervals in ordered types. The datatype     *)
(* (interval T) gives a formal characterization of an interval, as the pair   *)
(* of its right and left bounds.                                              *)
(*    interval T    == the type of formal intervals on T.                     *)
(*    x \in i       == when i is a formal interval on an ordered type,        *)
(*                     \in can be used to test membership.                    *)
(*    itvP x_in_i   == where x_in_i has type x \in i, if i is ground,         *)
(*                     gives a set of rewrite rules that x_in_i imply.        *)
(* lteBSide, bnd_simp == multirules to simplify inequalities between interval *)
(*                     bounds                                                 *)
(*    miditv i      == middle point of interval i                             *)
(*                                                                            *)
(* Intervals of T form an partially ordered type (porderType) whose ordering  *)
(* is the subset relation. If T is a lattice, intervals also form a lattice   *)
(* (latticeType) whose meet and join are intersection and convex hull         *)
(* respectively. They are distributive if T is an orderType.                  *)
(*                                                                            *)
(* We provide a set of notations to write intervals (see below)               *)
(* `[a, b], `]a, b], ..., `]-oo, a], ..., `]-oo, +oo[                         *)
(* The substrings "oo", "oc", "co", "cc" in the names of lemmas respectively  *)
(* stand for the intervals of the shape `]a, b[, `]a, b], `[a, b[, `[a, b].   *)
(* The substrings "pinfty" and "ninfty" in the names of lemmas stand for      *)
(* +oo and -oo.                                                               *)
(* We also provide the lemma subitvP which computes the inequalities one      *)
(* needs to prove when trying to prove the inclusion of intervals.            *)
(*                                                                            *)
(* Remark that we cannot implement a boolean comparison test for intervals on *)
(* an arbitrary ordered types, for this problem might be undecidable. Note    *)
(* also that type (interval R) may contain several inhabitants coding for the *)
(* same interval. However, this pathological issues do nor arise when R is a  *)
(* real domain: we could provide a specific theory for this important case.   *)
(*                                                                            *)
(* See also ``Formal proofs in real algebraic geometry: from ordered fields   *)
(* to quantifier elimination'', LMCS journal, 2012                            *)
(* by Cyril Cohen and Assia Mahboubi                                          *)
(*                                                                            *)
(* And "Formalized algebraic numbers: construction and first-order theory"    *)
(* Cyril Cohen, PhD, 2012, section 4.3.                                       *)
(******************************************************************************)

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

Local Open Scope order_scope.
Import Order.TTheory.

Variant itv_bound (T : Type) : Type := BSide of bool & T | BInfty of bool.
Notation BLeft := (BSide true).
Notation BRight := (BSide false).
Notation "'-oo'" := (BInfty _ true) (at level 0) : order_scope.
Notation "'+oo'" := (BInfty _ false) (at level 0) : order_scope.
Variant interval (T : Type) := Interval of itv_bound T & itv_bound T.

Coercion pair_of_interval T (I : interval T) : itv_bound T * itv_bound T :=
  let: Interval b1 b2 := I in (b1, b2).

(* We provide the 9 following notations to help writing formal intervals *)
Notation "`[ a , b ]" := (Interval (BLeft a) (BRight b))
  (at level 0, a, b at level 9 , format "`[ a ,  b ]") : order_scope.
Notation "`] a , b ]" := (Interval (BRight a) (BRight b))
  (at level 0, a, b at level 9 , format "`] a ,  b ]") : order_scope.
Notation "`[ a , b [" := (Interval (BLeft a) (BLeft b))
  (at level 0, a, b at level 9 , format "`[ a ,  b [") : order_scope.
Notation "`] a , b [" := (Interval (BRight a) (BLeft b))
  (at level 0, a, b at level 9 , format "`] a ,  b [") : order_scope.
Notation "`] '-oo' , b ]" := (Interval -oo (BRight b))
  (at level 0, b at level 9 , format "`] '-oo' ,  b ]") : order_scope.
Notation "`] '-oo' , b [" := (Interval -oo (BLeft b))
  (at level 0, b at level 9 , format "`] '-oo' ,  b [") : order_scope.
Notation "`[ a , '+oo' [" := (Interval (BLeft a) +oo)
  (at level 0, a at level 9 , format "`[ a ,  '+oo' [") : order_scope.
Notation "`] a , '+oo' [" := (Interval (BRight a) +oo)
  (at level 0, a at level 9 , format "`] a ,  '+oo' [") : order_scope.
Notation "`] -oo , '+oo' [" := (Interval -oo +oo)
  (at level 0, format "`] -oo ,  '+oo' [") : order_scope.

Notation "`[ a , b ]" := (Interval (BLeft a) (BRight b))
  (at level 0, a, b at level 9 , format "`[ a ,  b ]") : ring_scope.
Notation "`] a , b ]" := (Interval (BRight a) (BRight b))
  (at level 0, a, b at level 9 , format "`] a ,  b ]") : ring_scope.
Notation "`[ a , b [" := (Interval (BLeft a) (BLeft b))
  (at level 0, a, b at level 9 , format "`[ a ,  b [") : ring_scope.
Notation "`] a , b [" := (Interval (BRight a) (BLeft b))
  (at level 0, a, b at level 9 , format "`] a ,  b [") : ring_scope.
Notation "`] '-oo' , b ]" := (Interval -oo (BRight b))
  (at level 0, b at level 9 , format "`] '-oo' ,  b ]") : ring_scope.
Notation "`] '-oo' , b [" := (Interval -oo (BLeft b))
  (at level 0, b at level 9 , format "`] '-oo' ,  b [") : ring_scope.
Notation "`[ a , '+oo' [" := (Interval (BLeft a) +oo)
  (at level 0, a at level 9 , format "`[ a ,  '+oo' [") : ring_scope.
Notation "`] a , '+oo' [" := (Interval (BRight a) +oo)
  (at level 0, a at level 9 , format "`] a ,  '+oo' [") : ring_scope.
Notation "`] -oo , '+oo' [" := (Interval -oo +oo)
  (at level 0, format "`] -oo ,  '+oo' [") : ring_scope.

Fact itv_bound_display (disp : unit) : unit. Proof. exact. Qed.
Fact interval_display (disp : unit) : unit. Proof. exact. Qed.

Section IntervalEq.

Variable T : eqType.

Definition eq_itv_bound (b1 b2 : itv_bound T) : bool :=
  match b1, b2 with
    | BSide a x, BSide b y => (a == b) && (x == y)
    | BInfty a, BInfty b => a == b
    | _, _ => false
  end.

Lemma eq_itv_boundP : Equality.axiom eq_itv_bound.
Proof.
move=> b1 b2; apply: (iffP idP).
- by move: b1 b2 => [a x|a][b y|b] => //= [/andP [/eqP -> /eqP ->]|/eqP ->].
- by move=> <-; case: b1 => //= a x; rewrite !eqxx.
Qed.

Canonical itv_bound_eqMixin := EqMixin eq_itv_boundP.
Canonical itv_bound_eqType := EqType (itv_bound T) itv_bound_eqMixin.

Definition eqitv (x y : interval T) : bool :=
  let: Interval x x' := x in
  let: Interval y y' := y in (x == y) && (x' == y').

Lemma eqitvP : Equality.axiom eqitv.
Proof.
move=> x y; apply: (iffP idP).
- by move: x y => [x x'][y y'] => //= /andP [] /eqP -> /eqP ->.
- by move=> <-; case: x => /= x x'; rewrite !eqxx.
Qed.

Canonical interval_eqMixin := EqMixin eqitvP.
Canonical interval_eqType := EqType (interval T) interval_eqMixin.

End IntervalEq.

Module IntervalChoice.
Section IntervalChoice.

Variable T : choiceType.

Lemma itv_bound_can :
  cancel (fun b : itv_bound T =>
            match b with BSide b x => (b, Some x) | BInfty b => (b, None) end)
         (fun b =>
            match b with (b, Some x) => BSide b x | (b, None) => BInfty _ b end).
Proof. by case. Qed.

Lemma interval_can :
  @cancel _ (interval T)
    (fun '(Interval b1 b2) => (b1, b2)) (fun '(b1, b2) => Interval b1 b2).
Proof. by case. Qed.

End IntervalChoice.

Module Exports.

Canonical itv_bound_choiceType (T : choiceType) :=
  ChoiceType (itv_bound T) (CanChoiceMixin (@itv_bound_can T)).
Canonical interval_choiceType (T : choiceType) :=
  ChoiceType (interval T) (CanChoiceMixin (@interval_can T)).

Canonical itv_bound_countType (T : countType) :=
  CountType (itv_bound T) (CanCountMixin (@itv_bound_can T)).
Canonical interval_countType (T : countType) :=
  CountType (interval T) (CanCountMixin (@interval_can T)).

Canonical itv_bound_finType (T : finType) :=
  FinType (itv_bound T) (CanFinMixin (@itv_bound_can T)).
Canonical interval_finType (T : finType) :=
  FinType (interval T) (CanFinMixin (@interval_can T)).

End Exports.

End IntervalChoice.
Export IntervalChoice.Exports.

Section IntervalPOrder.

Variable (disp : unit) (T : porderType disp).
Implicit Types (x y z : T) (b bl br : itv_bound T) (i : interval T).

Definition le_bound b1 b2 :=
  match b1, b2 with
    | -oo, _ | _, +oo => true
    | BSide b1 x1, BSide b2 x2 => x1 < x2 ?<= if b2 ==> b1
    | _, _ => false
  end.

Definition lt_bound b1 b2 :=
  match b1, b2 with
    | -oo, +oo | -oo, BSide _ _ | BSide _ _, +oo => true
    | BSide b1 x1, BSide b2 x2 => x1 < x2 ?<= if b1 && ~~ b2
    | _, _ => false
  end.

Lemma lt_bound_def b1 b2 : lt_bound b1 b2 = (b2 != b1) && le_bound b1 b2.
Proof. by case: b1 b2 => [[]?|[]][[]?|[]] //=; rewrite lt_def. Qed.

Lemma le_bound_refl : reflexive le_bound.
Proof. by move=> [[]?|[]] /=. Qed.

Lemma le_bound_anti : antisymmetric le_bound.
Proof. by case=> [[]?|[]] [[]?|[]] //=; case: comparableP => // ->. Qed.

Lemma le_bound_trans : transitive le_bound.
Proof.
by case=> [[]?|[]] [[]?|[]] [[]?|[]] lexy leyz //;
  apply: (lteif_imply _ (lteif_trans lexy leyz)).
Qed.

Definition itv_bound_porderMixin :=
  LePOrderMixin lt_bound_def le_bound_refl le_bound_anti le_bound_trans.
Canonical itv_bound_porderType :=
  POrderType (itv_bound_display disp) (itv_bound T) itv_bound_porderMixin.

Lemma bound_lexx c1 c2 x : (BSide c1 x <= BSide c2 x) = (c2 ==> c1).
Proof. by rewrite /<=%O /= lteifxx. Qed.

Lemma bound_ltxx c1 c2 x : (BSide c1 x < BSide c2 x) = (c1 && ~~ c2).
Proof. by rewrite /<%O /= lteifxx. Qed.

Lemma ge_pinfty b : (+oo <= b) = (b == +oo). Proof. by move: b => [|[]]. Qed.

Lemma le_ninfty b : (b <= -oo) = (b == -oo). Proof. by case: b => // - []. Qed.

Lemma gt_pinfty b : (+oo < b) = false. Proof. by []. Qed.

Lemma lt_ninfty b : (b < -oo) = false. Proof. by case: b => // -[]. Qed.

Lemma ltBSide x y (b b' : bool) :
  BSide b x < BSide b' y = (x < y ?<= if b && ~~ b').
Proof. by []. Qed.

Lemma leBSide x y (b b' : bool) :
  BSide b x <= BSide b' y = (x < y ?<= if b' ==> b).
Proof. by []. Qed.

Definition lteBSide := (ltBSide, leBSide).

Lemma ltBRight_leBLeft b x : b < BRight x = (b <= BLeft x).
Proof. by move: b => [[] b|[]]. Qed.
Lemma leBRight_ltBLeft b x : BRight x <= b = (BLeft x < b).
Proof. by move: b => [[] b|[]]. Qed.

Let BLeft_ltE x y (b : bool) : BSide b x < BLeft y = (x < y).
Proof. by case: b. Qed.
Let BRight_leE x y (b : bool) : BSide b x <= BRight y = (x <= y).
Proof. by case: b. Qed.
Let BRight_BLeft_leE x y : BRight x <= BLeft y = (x < y).
Proof. by []. Qed.
Let BLeft_BRight_ltE x y : BLeft x < BRight y = (x <= y).
Proof. by []. Qed.
Let BRight_BSide_ltE x y (b : bool) : BRight x < BSide b y = (x < y).
Proof. by case: b. Qed.
Let BLeft_BSide_leE x y (b : bool) : BLeft x <= BSide b y = (x <= y).
Proof. by case: b. Qed.
Let BSide_ltE x y (b : bool) : BSide b x < BSide b y = (x < y).
Proof. by case: b. Qed.
Let BSide_leE x y (b : bool) : BSide b x <= BSide b y = (x <= y).
Proof. by case: b. Qed.
Let BInfty_leE a : a <= BInfty T false. Proof. by case: a => [[] a|[]]. Qed.
Let BInfty_geE a : BInfty T true <= a. Proof. by case: a => [[] a|[]]. Qed.
Let BInfty_le_eqE a : BInfty T false <= a = (a == BInfty T false).
Proof. by case: a => [[] a|[]]. Qed.
Let BInfty_ge_eqE a : a <= BInfty T true = (a == BInfty T true).
Proof. by case: a => [[] a|[]]. Qed.
Let BInfty_ltE a : a < BInfty T false = (a != BInfty T false).
Proof. by case: a => [[] a|[]]. Qed.
Let BInfty_gtE a : BInfty T true < a = (a != BInfty T true).
Proof. by case: a => [[] a|[]]. Qed.
Let BInfty_ltF a : BInfty T false < a = false.
Proof. by case: a => [[] a|[]]. Qed.
Let BInfty_gtF a : a < BInfty T true = false.
Proof. by case: a => [[] a|[]]. Qed.
Let BInfty_BInfty_ltE : BInfty T true < BInfty T false. Proof. by []. Qed.

Definition bnd_simp := (BLeft_ltE, BRight_leE,
  BRight_BLeft_leE, BLeft_BRight_ltE,
  BRight_BSide_ltE, BLeft_BSide_leE, BSide_ltE, BSide_leE,
  BInfty_leE, BInfty_geE, BInfty_BInfty_ltE,
  BInfty_le_eqE, BInfty_ge_eqE, BInfty_ltE, BInfty_gtE, BInfty_ltF, BInfty_gtF,
  @lexx _ T, @ltxx _ T, @eqxx T).

Definition subitv i1 i2 :=
  let: Interval b1l b1r := i1 in
  let: Interval b2l b2r := i2 in (b2l <= b1l) && (b1r <= b2r).

Lemma subitv_refl : reflexive subitv.
Proof. by case=> /= ? ?; rewrite !lexx. Qed.

Lemma subitv_anti : antisymmetric subitv.
Proof.
by case=> [? ?][? ?]; rewrite andbACA => /andP[] /le_anti -> /le_anti ->.
Qed.

Lemma subitv_trans : transitive subitv.
Proof.
case=> [yl yr][xl xr][zl zr] /andP [Hl Hr] /andP [Hl' Hr'] /=.
by rewrite (le_trans Hl' Hl) (le_trans Hr Hr').
Qed.

Definition interval_porderMixin :=
  LePOrderMixin (fun _ _ => erefl) subitv_refl subitv_anti subitv_trans.
Canonical interval_porderType :=
  POrderType (interval_display disp) (interval T) interval_porderMixin.

Definition pred_of_itv i : pred T := [pred x | `[x, x] <= i].

Canonical Structure itvPredType := PredType pred_of_itv.

Lemma subitvE b1l b1r b2l b2r :
  (Interval b1l b1r <= Interval b2l b2r) = (b2l <= b1l) && (b1r <= b2r).
Proof. by []. Qed.

Lemma in_itv x i :
  x \in i =
  let: Interval l u := i in
  match l with
    | BSide b lb => lb < x ?<= if b
    | BInfty b => b
  end &&
  match u with
    | BSide b ub => x < ub ?<= if ~~ b
    | BInfty b => ~~ b
  end.
Proof. by case: i => [[? ?|[]][|[]]]. Qed.

Lemma itv_boundlr bl br x :
  (x \in Interval bl br) = (bl <= BLeft x) && (BRight x <= br).
Proof. by []. Qed.

Lemma itv_splitI bl br x :
  x \in Interval bl br = (x \in Interval bl +oo) && (x \in Interval -oo br).
Proof. by rewrite !itv_boundlr andbT. Qed.

Lemma subitvP i1 i2 : i1 <= i2 -> {subset i1 <= i2}.
Proof. by move=> ? ? /le_trans; exact. Qed.

Lemma subset_itv (r s u v : bool) x y : r <= u -> v <= s ->
  {subset Interval (BSide r x) (BSide s y) <= Interval (BSide u x) (BSide v y)}.
Proof.
by move: r s u v=> [] [] [] []// *; apply: subitvP; rewrite subitvE !bound_lexx.
Qed.

Lemma subset_itv_oo_cc x y : {subset `]x, y[ <= `[x, y]}.
Proof. exact: subset_itv. Qed.

Lemma subset_itv_oo_oc x y : {subset `]x, y[ <= `]x, y]}.
Proof. exact: subset_itv. Qed.

Lemma subset_itv_oo_co x y : {subset `]x, y[ <= `[x, y[}.
Proof. exact: subset_itv. Qed.

Lemma subset_itv_oc_cc x y : {subset `]x, y] <= `[x, y]}.
Proof. exact: subset_itv. Qed.

Lemma subset_itv_co_cc x y : {subset `[x, y[ <= `[x, y]}.
Proof. exact: subset_itv. Qed.

Lemma itvxx x : `[x, x] =i pred1 x.
Proof. by move=> y; rewrite in_itv/= -eq_le eq_sym. Qed.

Lemma itvxxP y x : reflect (y = x) (y \in `[x, x]).
Proof. by rewrite itvxx; apply/eqP. Qed.

Lemma subitvPl b1l b2l br :
  b2l <= b1l -> {subset Interval b1l br <= Interval b2l br}.
Proof. by move=> ?; apply: subitvP; rewrite subitvE lexx andbT. Qed.

Lemma subitvPr bl b1r b2r :
  b1r <= b2r -> {subset Interval bl b1r <= Interval bl b2r}.
Proof. by move=> ?; apply: subitvP; rewrite subitvE lexx. Qed.

Lemma itv_xx x cl cr y :
  y \in Interval (BSide cl x) (BSide cr x) = cl && ~~ cr && (y == x).
Proof. by case: cl cr => [] []; rewrite [LHS]lteif_anti // eq_sym. Qed.

Lemma boundl_in_itv c x b : x \in Interval (BSide c x) b = c && (BRight x <= b).
Proof. by rewrite itv_boundlr bound_lexx. Qed.

Lemma boundr_in_itv c x b :
  x \in Interval b (BSide c x) = ~~ c && (b <= BLeft x).
Proof. by rewrite itv_boundlr bound_lexx implybF andbC. Qed.

Definition bound_in_itv := (boundl_in_itv, boundr_in_itv).

Lemma lt_in_itv bl br x : x \in Interval bl br -> bl < br.
Proof. by case/andP; apply/le_lt_trans. Qed.

Lemma lteif_in_itv cl cr yl yr x :
  x \in Interval (BSide cl yl) (BSide cr yr) -> yl < yr ?<= if cl && ~~ cr.
Proof. exact: lt_in_itv. Qed.

Lemma itv_ge b1 b2 : ~~ (b1 < b2) -> Interval b1 b2 =i pred0.
Proof. by move=> ltb12 y; apply/contraNF: ltb12; apply/lt_in_itv. Qed.

Definition itv_decompose i x : Prop :=
  let: Interval l u := i in
  (match l return Prop with
     | BSide b lb => lb < x ?<= if b
     | BInfty b => b
   end *
   match u return Prop with
     | BSide b ub => x < ub ?<= if ~~ b
     | BInfty b => ~~ b
   end)%type.

Lemma itv_dec : forall x i, reflect (itv_decompose i x) (x \in i).
Proof. by move=> ? [[? ?|[]][? ?|[]]]; apply: (iffP andP); case. Qed.

Arguments itv_dec {x i}.

(* we compute a set of rewrite rules associated to an interval *)
Definition itv_rewrite i x : Type :=
  let: Interval l u := i in
    (match l with
       | BLeft a => (a <= x) * (x < a = false)
       | BRight a => (a <= x) * (a < x) * (x <= a = false) * (x < a = false)
       | -oo => forall x : T, x == x
       | +oo => forall b : bool, unkeyed b = false
     end *
     match u with
       | BRight b => (x <= b) * (b < x = false)
       | BLeft b => (x <= b) * (x < b) * (b <= x = false) * (b < x = false)
       | +oo => forall x : T, x == x
       | -oo => forall b : bool, unkeyed b = false
     end *
     match l, u with
       | BLeft a, BRight b =>
         (a <= b) * (b < a = false) * (a \in `[a, b]) * (b \in `[a, b])
       | BLeft a, BLeft b =>
         (a <= b) * (a < b) * (b <= a = false) * (b < a = false)
         * (a \in `[a, b]) * (a \in `[a, b[) * (b \in `[a, b]) * (b \in `]a, b])
       | BRight a, BRight b =>
         (a <= b) * (a < b) * (b <= a = false) * (b < a = false)
         * (a \in `[a, b]) * (a \in `[a, b[) * (b \in `[a, b]) * (b \in `]a, b])
       | BRight a, BLeft b =>
         (a <= b) * (a < b) * (b <= a = false) * (b < a = false)
         * (a \in `[a, b]) * (a \in `[a, b[) * (b \in `[a, b]) * (b \in `]a, b])
       | _, _ => forall x : T, x == x
     end)%type.

Lemma itvP x i : x \in i -> itv_rewrite i x.
Proof.
case: i => [[[]a|[]][[]b|[]]] /andP [] ha hb; rewrite /= ?bound_in_itv;
  do ![split | apply/negbTE; rewrite (le_gtF, lt_geF)];
  by [|apply: ltW | move: (lteif_trans ha hb) => //=; exact: ltW].
Qed.

Arguments itvP [x i].

Lemma itv_splitU1 b x : b <= BLeft x ->
  Interval b (BRight x) =i [predU1 x & Interval b (BLeft x)].
Proof.
move=> bx z; rewrite !inE/= !subitvE ?bnd_simp//= lt_neqAle.
by case: (eqVneq z x) => [->|]//=; rewrite lexx bx.
Qed.

Lemma itv_split1U b x : BRight x <= b ->
  Interval (BLeft x) b =i [predU1 x & Interval (BRight x) b].
Proof.
move=> bx z; rewrite !inE/= !subitvE ?bnd_simp//= lt_neqAle.
by case: (eqVneq z x) => [->|]//=; rewrite lexx bx.
Qed.

End IntervalPOrder.

Section IntervalLattice.

Variable (disp : unit) (T : latticeType disp).
Implicit Types (x y z : T) (b bl br : itv_bound T) (i : interval T).

Definition bound_meet bl br : itv_bound T :=
  match bl, br with
    | -oo, _ | _, -oo => -oo
    | +oo, b | b, +oo => b
    | BSide xb x, BSide yb y =>
      BSide (((x <= y) && xb) || ((y <= x) && yb)) (x `&` y)
  end.

Definition bound_join bl br : itv_bound T :=
  match bl, br with
    | -oo, b | b, -oo => b
    | +oo, _ | _, +oo => +oo
    | BSide xb x, BSide yb y =>
      BSide ((~~ (x <= y) || yb) && (~~ (y <= x) || xb)) (x `|` y)
  end.

Lemma bound_meetC : commutative bound_meet.
Proof.
case=> [? ?|[]][? ?|[]] //=; rewrite meetC; congr BSide.
by case: lcomparableP; rewrite ?orbF // orbC.
Qed.

Lemma bound_joinC : commutative bound_join.
Proof.
case=> [? ?|[]][? ?|[]] //=; rewrite joinC; congr BSide.
by case: lcomparableP; rewrite ?andbT // andbC.
Qed.

Lemma bound_meetA : associative bound_meet.
Proof.
case=> [? x|[]][? y|[]][? z|[]] //=; rewrite !lexI meetA; congr BSide.
by case: (lcomparableP x y) => [|||->]; case: (lcomparableP y z) => [|||->];
  case: (lcomparableP x z) => [|||//<-]; case: (lcomparableP x y);
  rewrite //= ?andbF ?orbF ?lexx ?orbA //; case: (lcomparableP y z).
Qed.

Lemma bound_joinA : associative bound_join.
Proof.
case=> [? x|[]][? y|[]][? z|[]] //=; rewrite !leUx joinA; congr BSide.
by case: (lcomparableP x y) => [|||->]; case: (lcomparableP y z) => [|||->];
  case: (lcomparableP x z) => [|||//<-]; case: (lcomparableP x y);
  rewrite //= ?orbT ?andbT ?lexx ?andbA //; case: (lcomparableP y z).
Qed.

Lemma bound_meetKU b2 b1 : bound_join b1 (bound_meet b1 b2) = b1.
Proof.
case: b1 b2 => [? ?|[]][? ?|[]] //=;
  rewrite ?meetKU ?joinxx ?leIl ?lexI ?lexx ?andbb //=; congr BSide.
by case: lcomparableP; rewrite ?orbF /= ?andbb ?orbK.
Qed.

Lemma bound_joinKI b2 b1 : bound_meet b1 (bound_join b1 b2) = b1.
Proof.
case: b1 b2 => [? ?|[]][? ?|[]] //=;
  rewrite ?joinKI ?meetxx ?leUl ?leUx ?lexx ?orbb //=; congr BSide.
by case: lcomparableP; rewrite ?orbF ?orbb ?andKb.
Qed.

Lemma bound_leEmeet b1 b2 : (b1 <= b2) = (bound_meet b1 b2 == b1).
Proof.
by case: b1 b2 => [[]?|[]][[]?|[]] //=;
  rewrite [LHS]/<=%O /eq_op /= ?eqxx //= -leEmeet; case: lcomparableP.
Qed.

Definition itv_bound_latticeMixin :=
  LatticeMixin bound_meetC bound_joinC bound_meetA bound_joinA
               bound_joinKI bound_meetKU bound_leEmeet.
Canonical itv_bound_latticeType :=
  LatticeType (itv_bound T) itv_bound_latticeMixin.

Lemma bound_le0x b : -oo <= b. Proof. by []. Qed.

Lemma bound_lex1 b : b <= +oo. Proof. by case: b => [|[]]. Qed.

Canonical itv_bound_bLatticeType :=
  BLatticeType (itv_bound T) (BottomMixin bound_le0x).

Canonical itv_bound_tbLatticeType :=
  TBLatticeType (itv_bound T) (TopMixin bound_lex1).

Definition itv_meet i1 i2 : interval T :=
  let: Interval b1l b1r := i1 in
  let: Interval b2l b2r := i2 in Interval (b1l `|` b2l) (b1r `&` b2r).

Definition itv_join i1 i2 : interval T :=
  let: Interval b1l b1r := i1 in
  let: Interval b2l b2r := i2 in Interval (b1l `&` b2l) (b1r `|` b2r).

Lemma itv_meetC : commutative itv_meet.
Proof. by case=> [? ?][? ?] /=; rewrite meetC joinC. Qed.

Lemma itv_joinC : commutative itv_join.
Proof. by case=> [? ?][? ?] /=; rewrite meetC joinC. Qed.

Lemma itv_meetA : associative itv_meet.
Proof. by case=> [? ?][? ?][? ?] /=; rewrite meetA joinA. Qed.

Lemma itv_joinA : associative itv_join.
Proof. by case=> [? ?][? ?][? ?] /=; rewrite meetA joinA. Qed.

Lemma itv_meetKU i2 i1 : itv_join i1 (itv_meet i1 i2) = i1.
Proof. by case: i1 i2 => [? ?][? ?] /=; rewrite meetKU joinKI. Qed.

Lemma itv_joinKI i2 i1 : itv_meet i1 (itv_join i1 i2) = i1.
Proof. by case: i1 i2 => [? ?][? ?] /=; rewrite meetKU joinKI. Qed.

Lemma itv_leEmeet i1 i2 : (i1 <= i2) = (itv_meet i1 i2 == i1).
Proof. by case: i1 i2 => [? ?][? ?]; rewrite /eq_op /= eq_meetl eq_joinl. Qed.

Definition interval_latticeMixin :=
  LatticeMixin itv_meetC itv_joinC itv_meetA itv_joinA
               itv_joinKI itv_meetKU itv_leEmeet.
Canonical interval_latticeType :=
  LatticeType (interval T) interval_latticeMixin.

Lemma itv_le0x i : Interval +oo -oo <= i. Proof. by case: i => [[|[]]]. Qed.

Lemma itv_lex1 i : i <= `]-oo, +oo[. Proof. by case: i => [?[|[]]]. Qed.

Canonical interval_bLatticeType :=
  BLatticeType (interval T) (BottomMixin itv_le0x).

Canonical interval_tbLatticeType :=
  TBLatticeType (interval T) (TopMixin itv_lex1).

Lemma in_itvI x i1 i2 : x \in i1 `&` i2 = (x \in i1) && (x \in i2).
Proof. exact: lexI. Qed.

End IntervalLattice.

Section IntervalTotal.

Variable (disp : unit) (T : orderType disp).
Implicit Types (a b c : itv_bound T) (x y z : T) (i : interval T).

Lemma itv_bound_totalMixin : totalLatticeMixin [latticeType of itv_bound T].
Proof. by move=> [[]?|[]][[]?|[]]; rewrite /<=%O //=; case: ltgtP. Qed.

Canonical itv_bound_distrLatticeType :=
  DistrLatticeType (itv_bound T) itv_bound_totalMixin.
Canonical itv_bound_bDistrLatticeType := [bDistrLatticeType of itv_bound T].
Canonical itv_bound_tbDistrLatticeType := [tbDistrLatticeType of itv_bound T].
Canonical itv_bound_orderType := OrderType (itv_bound T) itv_bound_totalMixin.

Lemma itv_meetUl : @left_distributive (interval T) _ Order.meet Order.join.
Proof.
by move=> [? ?][? ?][? ?]; rewrite /Order.meet /Order.join /= -meetUl -joinIl.
Qed.

Canonical interval_distrLatticeType :=
  DistrLatticeType (interval T) (DistrLatticeMixin itv_meetUl).
Canonical interval_bDistrLatticeType := [bDistrLatticeType of interval T].
Canonical interval_tbDistrLatticeType := [tbDistrLatticeType of interval T].

Lemma itv_splitU c a b : a <= c <= b ->
  forall y, y \in Interval a b = (y \in Interval a c) || (y \in Interval c b).
Proof.
case/andP => leac lecb y.
rewrite !itv_boundlr !(ltNge (BLeft y) _ : (BRight y <= _) = _).
case: (leP a) (leP b) (leP c) => leay [] leby [] lecy //=.
- by case: leP lecy (le_trans lecb leby).
- by case: leP leay (le_trans leac lecy).
Qed.

Lemma itv_splitUeq x a b : x \in Interval a b ->
  forall y, y \in Interval a b =
    [|| y \in Interval a (BLeft x), y == x | y \in Interval (BRight x) b].
Proof.
case/andP => ax xb y; rewrite (@itv_splitU (BLeft x)) ?ax ?ltW //.
by congr orb; rewrite (@itv_splitU (BRight x)) ?bound_lexx // itv_xx.
Qed.

Lemma itv_total_meet3E i1 i2 i3 :
  i1 `&` i2 `&` i3 \in [:: i1 `&` i2; i1 `&` i3; i2 `&` i3].
Proof.
case: i1 i2 i3 => [b1l b1r] [b2l b2r] [b3l b3r]; rewrite !inE /eq_op /=.
case: (leP b1l b2l); case: (leP b1l b3l); case: (leP b2l b3l);
  case: (leP b1r b2r); case: (leP b1r b3r); case: (leP b2r b3r);
  rewrite ?eqxx ?orbT //= => b23r b13r b12r b23l b13l b12l.
- by case: leP b13r (le_trans b12r b23r).
- by case: leP b13l (le_trans b12l b23l).
- by case: leP b13l (le_trans b12l b23l).
- by case: leP b13r (le_trans b12r b23r).
- by case: leP b13r (le_trans b12r b23r).
- by case: leP b13l (lt_trans b23l b12l).
- by case: leP b13r (lt_trans b23r b12r).
- by case: leP b13l (lt_trans b23l b12l).
- by case: leP b13r (lt_trans b23r b12r).
- by case: leP b13r (lt_trans b23r b12r).
Qed.

Lemma itv_total_join3E i1 i2 i3 :
  i1 `|` i2 `|` i3 \in [:: i1 `|` i2; i1 `|` i3; i2 `|` i3].
Proof.
case: i1 i2 i3 => [b1l b1r] [b2l b2r] [b3l b3r]; rewrite !inE /eq_op /=.
case: (leP b1l b2l); case: (leP b1l b3l); case: (leP b2l b3l);
  case: (leP b1r b2r); case: (leP b1r b3r); case: (leP b2r b3r);
  rewrite ?eqxx ?orbT //= => b23r b13r b12r b23l b13l b12l.
- by case: leP b13r (le_trans b12r b23r).
- by case: leP b13r (le_trans b12r b23r).
- by case: leP b13l (le_trans b12l b23l).
- by case: leP b13l (le_trans b12l b23l).
- by case: leP b13l (le_trans b12l b23l).
- by case: leP b13r (lt_trans b23r b12r).
- by case: leP b13l (lt_trans b23l b12l).
- by case: leP b13l (lt_trans b23l b12l).
- by case: leP b13l (lt_trans b23l b12l).
- by case: leP b13r (lt_trans b23r b12r).
Qed.

Lemma predC_itvl a : [predC Interval -oo a] =i Interval a +oo.
Proof.
case: a => [b x|[]//] y.
by rewrite !inE !subitvE/= bnd_simp andbT !lteBSide/= lteifNE negbK.
Qed.

Lemma predC_itvr a : [predC Interval a +oo] =i Interval -oo a.
Proof. by move=> y; rewrite inE/= -predC_itvl negbK. Qed.

Lemma predC_itv i : [predC i] =i [predU Interval -oo i.1 & Interval i.2 +oo].
Proof.
case: i => [a a']; move=> x; rewrite inE/= itv_splitI negb_and.
by symmetry; rewrite inE/= -predC_itvl -predC_itvr.
Qed.

End IntervalTotal.

Local Open Scope ring_scope.
Import GRing.Theory Num.Theory.

Section IntervalNumDomain.

Variable R : numDomainType.
Implicit Types x : R.

Lemma mem0_itvcc_xNx x : (0 \in `[- x, x]) = (0 <= x).
Proof. by rewrite itv_boundlr [in LHS]/<=%O /= oppr_le0 andbb. Qed.

Lemma mem0_itvoo_xNx x : 0 \in `](- x), x[ = (0 < x).
Proof. by rewrite itv_boundlr [in LHS]/<=%O /= oppr_lt0 andbb. Qed.

Lemma oppr_itv ba bb (xa xb x : R) :
  (- x \in Interval (BSide ba xa) (BSide bb xb)) =
  (x \in Interval (BSide (~~ bb) (- xb)) (BSide (~~ ba) (- xa))).
Proof.
by rewrite !itv_boundlr /<=%O /= !implybF negbK andbC lteif_oppl lteif_oppr.
Qed.

Lemma oppr_itvoo (a b x : R) : (- x \in `]a, b[) = (x \in `](- b), (- a)[).
Proof. exact: oppr_itv. Qed.

Lemma oppr_itvco (a b x : R) : (- x \in `[a, b[) = (x \in `](- b), (- a)]).
Proof. exact: oppr_itv. Qed.

Lemma oppr_itvoc (a b x : R) : (- x \in `]a, b]) = (x \in `[(- b), (- a)[).
Proof. exact: oppr_itv. Qed.

Lemma oppr_itvcc (a b x : R) : (- x \in `[a, b]) = (x \in `[(- b), (- a)]).
Proof. exact: oppr_itv. Qed.

Definition miditv (R : numDomainType) (i : interval R) : R :=
  match i with
  | Interval (BSide _ a) (BSide _ b) => (a + b) / 2%:R
  | Interval -oo%O (BSide _ b) => b - 1
  | Interval (BSide _ a) +oo%O => a + 1
  | Interval -oo%O +oo%O => 0
  | _ => 0
  end.

End IntervalNumDomain.

Section IntervalField.

Variable R : numFieldType.
Implicit Types (x y z : R) (i : interval R).

Local Notation mid x y := ((x + y) / 2).

Lemma mid_in_itv : forall ba bb (xa xb : R), xa < xb ?<= if ba && ~~ bb ->
  mid xa xb \in Interval (BSide ba xa) (BSide bb xb).
Proof.
by move=> [] [] xa xb /= ?; apply/itv_dec; rewrite /= ?midf_lte // ?ltW.
Qed.

Lemma mid_in_itvoo : forall (xa xb : R), xa < xb -> mid xa xb \in `]xa, xb[.
Proof. by move=> xa xb ?; apply: mid_in_itv. Qed.

Lemma mid_in_itvcc : forall (xa xb : R), xa <= xb -> mid xa xb \in `[xa, xb].
Proof. by move=> xa xb ?; apply: mid_in_itv. Qed.

Lemma mem_miditv i : (i.1 < i.2)%O -> miditv i \in i.
Proof.
move: i => [[ba a|[]] [bb b|[]]] //= ab; first exact: mid_in_itv.
by rewrite !in_itv -lteif_subl_addl subrr lteif01.
by rewrite !in_itv lteif_subl_addr -lteif_subl_addl subrr lteif01.
Qed.

Lemma miditv_le_left i b : (i.1 < i.2)%O -> (BSide b (miditv i) <= i.2)%O.
Proof.
case: i => [x y] lti; have := mem_miditv lti; rewrite inE => /andP[_ ].
by apply: le_trans; rewrite !bnd_simp.
Qed.

Lemma miditv_ge_right i b : (i.1 < i.2)%O -> (i.1 <= BSide b (miditv i))%O.
Proof.
case: i => [x y] lti; have := mem_miditv lti; rewrite inE => /andP[+ _].
by move=> /le_trans; apply; rewrite !bnd_simp.
Qed.

Lemma in_segment_addgt0Pr x y z :
  reflect (forall e, e > 0 -> y \in `[x - e, z + e]) (y \in `[x, z]).
Proof.
apply/(iffP idP)=> [xyz e /[dup] e_gt0 /ltW e_ge0 | xyz_e].
  by rewrite in_itv /= ler_subl_addr !ler_paddr// (itvP xyz).
by rewrite in_itv /= ; apply/andP; split; apply/ler_addgt0Pr => ? /xyz_e;
  rewrite in_itv /= ler_subl_addr => /andP [].
Qed.

Lemma in_segment_addgt0Pl x y z :
  reflect (forall e, e > 0 -> y \in `[(- e + x), (e + z)]) (y \in `[x, z]).
Proof.
apply/(equivP (in_segment_addgt0Pr x y z)).
by split=> zxy e /zxy; rewrite [z + _]addrC [_ + x]addrC.
Qed.

End IntervalField.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* Certified Undecidability of Intuitionistic Linear Logic via Binary Stack Machines and Minsky Machines. Yannick Forster and Dominique Larchey-Wendling. CPP '19. http://uds-psl.github.io/ill-undecidability/ *)

Require Import List Permutation.

From Undecidability.ILL Require Import ILL.

Set Implicit Arguments.

Local Infix "~p" := (@Permutation _) (at level 70).

Notation eill_vars := nat.

Inductive eill_cmd : Set :=
  | in_eill_cmd_inc  : eill_vars -> eill_vars -> eill_vars -> eill_cmd
  | in_eill_cmd_dec  : eill_vars -> eill_vars -> eill_vars -> eill_cmd
  | in_eill_cmd_fork : eill_vars -> eill_vars -> eill_vars -> eill_cmd.

Notation LL_INC  := in_eill_cmd_inc.
Notation LL_DEC  := in_eill_cmd_dec.
Notation LL_FORK := in_eill_cmd_fork.

Definition eill_cmd_vars c :=
  match c with
    | LL_INC  a p q => a::p::q::nil
    | LL_DEC  a p q => a::p::q::nil
    | LL_FORK p q r => p::q::r::nil
  end.

(* The embedding of eill commands into ill
   or its (!,&,-o) fragment *)

Definition eill_cmd_map c :=
  match c with
    | LL_INC  a p q => (£a ⊸ £p) ⊸ £ q
    | LL_DEC  a p q => £a ⊸ £p ⊸ £ q
    | LL_FORK p q r => (£p & £q) ⊸ £ r
  end.

(* Symbols for cut&paste ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  !  ‼  ∅  ⊢ ⟦ ⟧ Γ Δ Σ *)

Section GeILL.

  Reserved Notation "Σ ; Γ ⊦ u" (at level 70, no associativity).

  Inductive G_eill (Σ : list eill_cmd) : list eill_vars -> eill_vars -> Prop :=
    | in_geill_ax  : forall u,                                    Σ; u::∅ ⊦ u
    | in_geill_perm : forall Γ Δ p,    Γ ~p Δ                 ->  Σ; Γ     ⊦ p
                                                              ->  Σ; Δ     ⊦ p
    | in_geill_inc : forall Γ a p q,   In (LL_INC a p q) Σ    ->  Σ; a::Γ  ⊦ p
                                                              ->  Σ; Γ     ⊦ q
    | in_geill_dec : forall Γ Δ p q r, In (LL_DEC p q r) Σ    ->  Σ; Γ     ⊦ p
                                                              ->  Σ; Δ     ⊦ q
                                                              ->  Σ; Γ++Δ  ⊦ r
    | in_geill_fork : forall Γ p q r,  In (LL_FORK p q r) Σ   ->  Σ; Γ     ⊦ p
                                                              ->  Σ; Γ     ⊦ q
                                                              ->  Σ; Γ     ⊦ r
  where "Σ ; Γ ⊦ u" := (G_eill Σ Γ u).

End GeILL.

Definition EILL_SEQUENT := (list eill_cmd * list eill_vars * eill_vars)%type.

Definition EILL_PROVABILITY (c : EILL_SEQUENT) := match c with (Σ,Γ,u) => G_eill Σ Γ u end.


(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require Export field_general_properties.
Require Export chou_gao_zhang_axioms.

(* This file contains the lemmas needed by the tactics used as tools for
both the development and the decision procedure. *)

(********************************************************)
(* Signed areas                                         *)
(********************************************************)

Lemma S_0 : forall A B C : Point, S A B C = S C A B.
auto with Geom.
Qed.

Lemma S_1 : forall A B C : Point, S A B C = S B C A.
auto with Geom.
Qed.
Hint Resolve S_1: Geom.

Lemma S_2 : forall A B C : Point, S A B C = - S C B A.
Proof with try solve [ Geometry | congruence ].
intros...
assert (S A B C = - S B A C)...
assert (S B A C = S C B A)...
Qed.
Hint Resolve S_2: Geom.

Lemma S_3 : forall A B C : Point, S A B C = - S A C B.
Proof with try solve [ Geometry | congruence ].
intros...
assert (S A B C = - S B A C)...
assert (S B A C = S A C B)...
Qed.
Hint Resolve S_3: Geom.

Lemma S_4 : forall A B C : Point, S A B C = - S B A C.
intros.
Geometry.
Qed.

(********************************************************)
(* Signed areas (4)                                     *)
(********************************************************)

Lemma S4_1 : forall A B C D : Point, S4 A B C D = S A B D - S C B D.
Proof with try solve [ Geometry | ring ].
intros...
unfold S4 in |- *...
assert (S A B C = S A B D + S A D C + S D B C)...
assert (S D B C = - S C B D)...
rewrite H0 in H...
assert (S A D C = - S A C D)...
rewrite H1 in H...
clear H0 H1...
rewrite H...
Qed.
Hint Resolve S4_1: Geom.

Lemma S4_2 : forall A B C D : Point, S4 A B C D = S4 B C D A.
Proof with try solve [ Geometry | ring ].
unfold S4 in |- *...
intros...
assert (S B D A = S A B D)...
assert (S B C D = - S C B D)...
assert (S4 A B C D = S A B D - S C B D)...
rewrite <- H in H1.
rewrite H0.
unfold S4 in H1.
rewrite H1 in |- *.
ring.
Qed.
Hint Resolve S4_2: Geom.

Lemma S4_3 : forall A B C D : Point, S4 A B C D = S4 C D A B.
Proof with try solve [ Geometry | congruence ].
intros...
assert (S4 A B C D = S4 B C D A)...
rewrite H...
Qed.
Hint Resolve S4_3: Geom.

Lemma S4_4 : forall A B C D : Point, S4 A B C D = S4 D A B C.
Proof with Geometry.
intros...
Qed.
Hint Resolve S4_4: Geom.

Lemma S4_5 : forall A B C D : Point, S4 A B C D = - S4 A D C B.
Proof with Geometry.
intros...
unfold S4 in |- *...
assert (S A C D = - S A D C)...
rewrite H.
assert (S A B C = - S A C B)...
rewrite H0.
ring.
Qed.
Hint Resolve S4_5: Geom.

Lemma S4_6 : forall A B C D : Point, S4 A B C D = - S4 D C B A.
Proof with try solve [ Geometry | congruence ].
intros...
assert (S4 D C B A = S4 A D C B)...
rewrite H...
Qed.
Hint Resolve S4_6: Geom.

Lemma S4_7 : forall A B C D : Point, S4 A B C D = - S4 C B A D.
Proof with try solve [ Geometry | congruence ].
intros...
assert (S4 A D C B = S4 C B A D)...
rewrite <- H...
Qed.
Hint Resolve S4_7: Geom.

Lemma S4_8 : forall A B C D : Point, S4 A B C D = - S4 B A D C.
Proof with Geometry.
intros...
assert (S4 A D C B = S4 B A D C)...
rewrite <- H...
Qed.
Hint Resolve S4_8: Geom.

Lemma lpar1 : forall A B C D : Point, parallel A B C D -> parallel A B D C.
Proof.
intros.
unfold parallel in *.
rewrite S4_5.
rewrite H.
ring.
Qed.

Lemma lpar2 : forall A B C D : Point, parallel A B C D -> parallel B A C D.
Proof.
intros.
unfold parallel in *.
rewrite S4_7.
rewrite H.
ring.
Qed.

Lemma lpar3 : forall A B C D : Point, parallel A B C D -> parallel B A D C.
Proof.
intros.
unfold parallel in *.
rewrite S4_3.
assumption.
Qed.

Lemma ldiff : forall A B : Point, A <> B -> B <> A.
Proof.
intros.
Geometry.
Qed.

(***************************************************)
(* Simplification lemmas                           *)
(***************************************************)

Lemma simplring1 : forall x : F, x = - - x.
Proof.
intro.
ring.
Qed.

Lemma zeroegal : forall A B : Point, A = B -> A ** B = 0.
Proof.
intros.
assert (P := A1b A B).
intuition.
Qed.

Lemma egalzero : forall A B : Point, A ** B = 0 -> A = B.
Proof.
intros.
assert (P := A1b A B).
intuition.
Qed.

Hint Resolve zeroegal egalzero: Geom.

Lemma nuldirseg : forall A : Point, 0 = A ** A.
Proof.
intros.
symmetry  in |- *.
Geometry.
Qed.

Lemma neq_not_zero : forall A B:Point,
  A<>B -> A**B<>0.
Proof.
intros.
Geometry.
Qed.

(* This lemma depends on the fact the 2<>0 *)

Lemma field_prop_2 : forall a : F, a = - a -> a = 0.
Proof with try solve [ ring | congruence ].
intros...
assert (a + a = - a + a)...
assert (- a + a = 0)...
rewrite H1 in H0...
assert (a + a = 2 * a)...
rewrite H2 in H0...
assert (2 * a / 2 = a)...
field...
auto with Geom...
assert (2 * a / 2 = 0 / 2)...
rewrite H3 in H4...
assert (0 / 2 = 0)...
field...
auto with Geom...
Qed.

Hint Resolve field_prop_2: Geom.

Lemma trivial_col1 : forall A B : Point, 0 = S A A B.
intros.
symmetry  in |- *.
Geometry.
Qed.

Lemma trivial_col2 : forall A B : Point, 0 = S A B B.
intros.
symmetry  in |- *.
Geometry.
Qed.

Lemma trivial_col3 : forall A B : Point, 0 = S A B A.
intros.
symmetry  in |- *.
Geometry.
Qed.

Lemma A1a : forall A B : Point, A ** B = - B ** A.
Proof.
intros.
assert (Col A B A).
Geometry.
assert (T:=chasles A B A H).
replace (A**A) with 0 in T.
2:symmetry;Geometry.
IsoleVar (A**B) T.
rewrite T.
ring.
Qed.

Lemma degenerated_ratio : forall A B C D,
  A=B -> C<>D -> A**B/C**D=0.
Proof.
intros.
field_simplify_eq; Geometry.
Qed.

Hint Immediate A1a: Geom.


Require Export D.

(** **** Problem #3 : 3 stars (list_exercises) *)
(** More practice with lists. *)

Theorem app_nil_end : forall l : natlist,
  l ++ [] = l.
Proof.
  intros. induction l. reflexivity.
  simpl. rewrite -> IHl. reflexivity.
Qed.


(* This file is extracted from the TLC library.
   http://github.com/charguer/tlc
   DO NOT EDIT. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Sum of Data Structures                                                  *
**************************************************************************)

Set Implicit Arguments.
From SLF Require Import LibTactics LibLogic LibBool.
Generalizable Variables A B.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Sum type *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definition *)

(** From the Prelude:

    Inductive sum A B : Type :=
      | inl : A -> sum A B
      | inr : B -> sum A B.

    Hint Constructors sum : core.
    Notation "x + y" := (sum x y) : type_scope.

  Remark: ideally, constructors would be renamed to [sum_l] and [sum_r];
  to follow conventions.

*)

Arguments inl {A} {B}.
Arguments inr {A} {B}.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inhabited *)

Instance sum_inhab_l : forall `{Inhab A} B, Inhab (A + B).
Proof using. intros. apply (Inhab_of_val (inl arbitrary)). Qed.

Instance sum_inhab_r : forall `{Inhab B} A, Inhab (A + B).
Proof using. intros. apply (Inhab_of_val (inr arbitrary)). Qed.

Definition Inhab_sum : forall `{Inhab A, Inhab B}, Inhab (A + B).
Proof using. typeclass. Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Operations *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Testing the branch of the sum *)

Definition is_inl (A B : Type) (x : A + B) : bool :=
  match x with
  | inl _ => true
  | inr _ => false
  end.

Definition is_inr (A B : Type) (x : A + B) : bool :=
  match x with
  | inl _ => false
  | inr _ => true
  end.

Section IsIn.
Variables (A B : Type).
Implicit Type x : A + B.

Lemma is_inl_neg_is_inr : forall x,
  is_inl x = ! (is_inr x).
Proof using. intros x. destruct~ x. Qed.

Lemma is_inr_neg_is_inl : forall x,
  is_inr x = ! (is_inl x).
Proof using. intros x. destruct~ x. Qed.

End IsIn.

(*-----------------------------------------------------*)
(* ================================================================= *)
(** ** Stripping of the branch tag *)

Section Get.
Context `{IA1:Inhab A1} `{IA2:Inhab A2}.
Implicit Types x : A1+A2.

Definition get21 x :=
  match x with
  | inl x1 => x1
  | inr x2 => arbitrary
  end.

Definition get22 x :=
  match x with
  | inl x1 => arbitrary
  | inr x2 => x2
  end.

End Get.

(*-----------------------------------------------------*)
(* ================================================================= *)
(** ** Lifting functions over sum types *)

Section Fget.
Context {A1:Type} {A2:Type} `{IB1:Inhab B1} `{IB2:Inhab B2}.
Implicit Types f : A1+A2->B1+B2.

Definition fun_get21 f :=
  fun x => get21 (f (inl x)).
Definition fun_get22 f :=
  fun x => get22 (f (inr x)).

End Fget.

(* 2021-08-11 15:24 *)