Require Import Utf8.
Require Import IxFree.Base.

Definition I_forall_func (A : Type) (P : A → IProp) : nat → Prop :=
  λ n, ∀ x : A, n ⊨ P x.
Lemma I_forall_func_monotone (A : Type) (P : A → IProp) :
  monotone (I_forall_func A P).
Proof.
unfold monotone; unfold I_forall_func; intros n H₁ x.
apply I_valid_monotone_S; auto.
Qed.

Definition I_forall (A : Type) (P : A → IProp) : IProp :=
  mk_IProp (I_forall_func A P) (I_forall_func_monotone A P).

Notation "'∀ᵢ' x .. y , P" :=
  (I_forall _ (fun x => .. (I_forall _ (fun y => P)) .. ))
  (at level 200, x binder, y binder, right associativity).

Lemma I_forall_intro {n : nat} {A : Type} {P : A → IProp} :
  (∀ x : A, (n ⊨ P x)) → (n ⊨ ∀ᵢ x, P x).
Proof.
intro H; apply I_valid_intro; intro x; auto.
Qed.

Lemma I_forall_elim {n : nat} {A : Type} {P : A → IProp} :
  (n ⊨ ∀ᵢ x : A, P x) → ∀ x, n ⊨ P x.
Proof.
intros H x; apply I_valid_elim in H; apply H.
Qed.

(* ========================================================================= *)
(* Tactics *)

Ltac iintro_forall_named x :=
  apply I_forall_intro; intro x.

Ltac iintro_forall_anon :=
  apply I_forall_intro; intro.


Require Import ZArith List.
Require Import veristar.variables.

(** datatypes.v:
Datatypes used throughout the development *)

Definition var : Type := Ident.t.

(** expr:
Program expressions *)

Inductive expr := Nil | Var : var -> expr.

(** pn_atom:
Pure (heap-independent) atoms *)

Inductive pn_atom := Equ : expr -> expr -> pn_atom | Nequ : expr -> expr -> pn_atom.

(** space_atom:
Spatial atoms are either next pointers or acyclic list segments. *)

Inductive space_atom :=
| Next : expr -> expr -> space_atom
| Lseg : expr -> expr -> space_atom.

(** assertion:
An assertion is composed of a list of pure atoms [pi], and a list of spatial
atoms [sigma].  [sigma] is interpreted as the _spatial_ conjunction of the
atoms, whereas [pi] asserts the conjunction of its pure atoms. *)

Inductive assertion : Type :=
  Assertion : forall (pi : list pn_atom) (sigma : list space_atom), assertion.

(** entailment:
An entailment is just a pair of assertions. Entailments are interpreted as:
In all models (pairs of heaps [h] and stacks [s]), the interpretation of the
assertion on the left implies the interpretation of the assertion on the right. *)

Inductive entailment : Type :=
  Entailment : assertion -> assertion -> entailment.

(** Various substitution functions:
 *)

Definition subst_var (i: var) (t: expr) (j: var) :=
  if Ident.eq_dec i j then t else Var j.

Definition subst_expr (i: var) (t: expr) (t': expr) :=
  match t' with
    | Nil => Nil
    | Var j => if Ident.eq_dec i j then t else t'
  end.

Definition subst_pn (i: var) (t: expr) (a: pn_atom) :=
 match a with
   | Equ t1 t2 => Equ (subst_expr i t t1) (subst_expr i t t2)
   | Nequ t1 t2 => Nequ (subst_expr i t t1) (subst_expr i t t2)
 end.

Definition subst_pns (i: var) (t: expr) (pa: list pn_atom)
  : list pn_atom := map (subst_pn i t) pa.

Definition subst_space (i: var) (t: expr) (a: space_atom) :=
  match a with
    | Next t1 t2 => Next (subst_expr i t t1) (subst_expr i t t2)
    | Lseg t1 t2 => Lseg (subst_expr i t t1) (subst_expr i t t2)
  end.

Definition subst_spaces (i: var) (t: expr)
  : list space_atom -> list space_atom := map (subst_space i t).

Definition subst_assertion (i: var) (e: expr) (a: assertion) :=
 match a with Assertion pi sigma =>
   Assertion (subst_pns i e pi) (subst_spaces i e sigma)
 end.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (y : natural) (lf2 : natural) : natural := y.


Require Import Coq.Strings.String.

Require Export SPAM.SeparationLogic.Syntax.

Inductive massert : Type :=
  | mut_s (A : sassert)
  | immut_s (A : sassert)
  | indif_s (A : sassert)
  | and_m (a : massert) (b : massert)
  | or_m (a : massert) (b : massert)
  | not_m (a : massert)
  | implies_m (a : massert) (b : massert)
  | sand_m (a : massert) (b : massert)
  | simplies_m (a : massert) (b : massert)
  | forall_m (x : lvar) (a : massert)
  | exists_m (x: lvar) (a : massert).

Notation "[ A ]mut" := (mut_s A) (at level 50).
Notation "[ A ]immut" := (immut_s A) (at level 50).
Notation "[ A ]indif" := (indif_s A) (at level 50).
Notation "A m/\ B" := (and_m A B) (at level 70).
Notation "A m\/ B" := (or_m A B) (at level 80).
Notation "m~ A" := (not_m A) (at level 65).
Notation "A m-> B" := (implies_m A B) (at level 85).
Notation "A m* B" := (sand_m A B) (at level 75).
Notation "A m-* B" := (simplies_m A B) (at level 90).
Notation "'mforall' X , B" := (forall_m X B) (at level 50).
Notation "'mexists' X , B" := (exists_m X B) (at level 50).


Section pbc.
 Variable phi: Prop.

 Axiom lem: phi \/ ~phi.

 Hypothesis H: ~phi -> False.
 Lemma pbc: phi.
 Proof.
  pose proof lem.
  destruct H0.
  - assumption.
  - apply H in H0.
    contradiction.
 Qed.

 Lemma pbc2: phi.
 Proof.
  pose proof lem.
  destruct H0.
  - assumption.
  - apply False_ind.
    apply H.
    assumption.
 Qed.

End pbc.


Require Export Shared.FiniteTypes.FinTypes Shared.FiniteTypes.BasicFinTypes Shared.FiniteTypes.CompoundFinTypes Shared.FiniteTypes.VectorFin.
Require Export Shared.Vectors.FinNotation.
Require Export Shared.Retracts.
Require Export Shared.Inhabited.
Require Export Shared.Base.
Require Export Shared.Vectors.Vectors Shared.Vectors.VectorDupfree.

Require Export smpl.Smpl.

Global Open Scope vector_scope.

Section Loop.
  Variable (A : Type) (f : A -> A) (p : A -> bool).

  Fixpoint loop (a : A) (k : nat) {struct k} :=
    if p a then Some a else
      match k with
      | O => None
      | S k' => loop (f a) k'
      end.

  Lemma loop_step k a :
    p a = false ->
    loop a (S k) = loop (f a) k.
  Proof. intros HHalt. destruct k; cbn; rewrite HHalt; auto. Qed.

  Lemma loop_injective k1 k2 a b b' :
    loop a k1 = Some b ->
    loop a k2 = Some b' ->
    b = b'.
  Proof.
    revert k2 b b' a. induction k1; intros; cbn in *.
    - destruct (p a) eqn:E; inv H.
      destruct k2; cbn in H0; rewrite E in H0; now inv H0.
    - destruct (p a) eqn:E.
      + inv H. destruct k2; cbn in H0; rewrite E in H0; now inv H0.
      + destruct k2; cbn in H0; rewrite E in H0; try now inv H0.
        eauto.
  Qed.

  Lemma loop_fulfills k a b :
    loop a k = Some b ->
    p b = true.
  Proof.
    revert a; induction k; intros; cbn in *.
    - now destruct (p a) eqn:E; inv H.
    - destruct (p a) eqn:E.
      + now inv H.
      + eapply IHk; eauto.
  Qed.

  Lemma loop_0 k a :
    p a = true ->
    loop a k = Some a.
  Proof. intros. destruct k; cbn; now rewrite H. Qed.

  Lemma loop_eq_0 k a b :
    p a = true ->
    loop a k = Some b ->
    b = a.
  Proof. intros H1 H2. eapply (loop_0 k) in H1. congruence. Qed.

  Lemma loop_monotone (k1 k2 : nat) (a b : A) : loop a k1 = Some b -> k1 <= k2 -> loop a k2 = Some b.
  Proof.
    revert a k2; induction k1 as [ | k1' IH]; intros a k2 HLoop Hk; cbn in *.
    - destruct k2; cbn; destruct (p a); now inv HLoop.
    - destruct (p a) eqn:E.
      + inv HLoop. now apply loop_0.
      + destruct k2 as [ | k2']; cbn in *; rewrite E.
        * exfalso. omega.
        * apply IH. assumption. omega.
  Qed.

End Loop.

Section LoopLift.

  Variable A B : Type. (** Abstract states *)
  Variable lift : A -> B. (** Lifting function between states *)
  Variable (f : A -> A) (f' : B -> B). (** Abstract steps *)
  Variable (h : A -> bool) (h' : B -> bool). (** Abstract halting states *)

  Hypothesis halt_lift_comp : forall x:A, h' (lift x) = h x.
  Hypothesis step_lift_comp : forall x:A, h x = false -> f' (lift x) = lift (f x).

  Lemma loop_lift (k : nat) (a a' : A) :
    loop (A := A) f  h  a        k = Some a' ->
    loop (A := B) f' h' (lift a) k = Some (lift a').
  Proof.
    revert a. induction k as [ | k']; intros; cbn in *.
    - rewrite halt_lift_comp. destruct (h a); now inv H.
    - rewrite halt_lift_comp. destruct (h a) eqn:E.
      + now inv H.
      + rewrite step_lift_comp by auto. now apply IHk'.
  Qed.

  Lemma loop_unlift (k : nat) (a : A) (b' : B) :
    loop f' h' (lift a) k = Some b' ->
    exists a' : A, loop f h a k = Some a' /\ b' = lift a'.
  Proof.
    revert a b'. induction k as [ | k']; intros; cbn in *.
    - rewrite halt_lift_comp in H.
      exists a. destruct (h a) eqn:E; now inv H.
    - rewrite halt_lift_comp in H.
      destruct (h a) eqn:E.
      + exists a. now inv H.
      + rewrite step_lift_comp in H by assumption.
        specialize IHk' with (1 := H) as (x&IH&->). now exists x.
  Qed.

End LoopLift.

Section LoopMerge.

  Variable A : Type. (** abstract states *)
  Variable f : A -> A. (** abstract step function *)
  Variable (h h' : A -> bool). (** abstract halting functions *)

  (** Every non-halting state w.r.t. [h] is also a non-halting state w.r.t. [h'] *)
  Hypothesis halt_comp : forall a, h a = false -> h' a = false.

  Lemma loop_merge (k1 k2 : nat) (a1 a2 a3 : A) :
    loop f h  a1 k1      = Some a2 ->
    loop f h' a2 k2      = Some a3 ->
    loop f h' a1 (k1+k2) = Some a3.
  Proof.
    revert a1 a2 a3. induction k1 as [ | k1' IH]; intros a1 a2 a3 HLoop1 HLoop2; cbn in HLoop1.
    - now destruct (h a1); inv HLoop1.
    - destruct (h a1) eqn:E.
      + inv HLoop1. eapply loop_monotone; eauto. omega.
      + cbn. rewrite (halt_comp E). eapply IH; eauto.
  Qed.

  Lemma loop_split (k : nat) (a1 a3 : A) :
    loop f h' a1 k = Some a3 ->
    exists k1 a2 k2,
      loop f h  a1 k1 = Some a2 /\
      loop f h' a2 k2 = Some a3 /\
      k1 + k2 <= k.
  Proof.
    revert a1 a3. revert k; refine (size_recursion id _); intros k IH. intros a1 a3 HLoop. cbv [id] in *.
    destruct k as [ | k']; cbn in *.
    - destruct (h' a1) eqn:E; inv HLoop.
      exists 0, a3, 0. cbn. rewrite E.
      destruct (h a3) eqn:E'.
      + auto.
      + apply halt_comp in E'. congruence.
    - destruct (h a1) eqn:E.
      + exists 0, a1, (S k'). cbn. rewrite E. auto.
      + rewrite (halt_comp E) in HLoop.
        apply IH in HLoop as (k1&c2&k2&IH1&IH2&IH3); [ | omega].
        exists (S k1), c2, k2. cbn. rewrite E. repeat split; auto. omega.
  Qed.

End LoopMerge.

(** Apply functions in tuples, options, etc. *)
Section Map.
  Variable X Y Z : Type.

  Definition map_opt : (X -> Y) -> option X -> option Y :=
    fun f a =>
      match a with
      | Some x => Some (f x)
      | None => None
      end.

  Definition map_inl : (X -> Y) -> X + Z -> Y + Z :=
    fun f a =>
      match a with
      | inl x => inl (f x)
      | inr y => inr y
      end.

  Definition map_inr : (Y -> Z) -> X + Y -> X + Z :=
    fun f a =>
      match a with
      | inl y => inl y
      | inr x => inr (f x)
      end.

  Definition map_fst : (X -> Z) -> X * Y -> Z * Y := fun f '(x,y) => (f x, y).
  Definition map_snd : (Y -> Z) -> X * Y -> X * Z := fun f '(x,y) => (x, f y).

End Map.

(** We often use the vernacular commands
<<
Local Arguments plus : simpl never.
Local Arguments mult : simpl never.
>>
to avoid unfolding [*] and [+] in running time polynoms. However, this can break proofs that use [Fin.R], since the [plus] in the type of [Fin.R] doesn't simplify with [cbn] any more. To work around this problem, we have a copy of [Fin.R] and [plus], that isn't affected by these commands. *)

Fixpoint plus' (n m : nat) { struct n } : nat :=
  match n with
  | 0 => m
  | S p => S (plus' p m)
  end.

Fixpoint FinR {m} n (p : Fin.t m) : Fin.t (plus' n m) :=
  match n with
  | 0 => p
  | S n' => Fin.FS (FinR n' p)
  end.


Require Export UniMath.MoreFoundations.Notations.
Require Export UniMath.MoreFoundations.PartA.
Require Export UniMath.MoreFoundations.Tactics.
Require Export UniMath.MoreFoundations.DecidablePropositions.

Local Open Scope logic.
Local Open Scope type.

Lemma ishinh_irrel {X:UU} (x:X) (x':∥X∥) : hinhpr x = x'.
Proof.
  apply proofirrelevance. apply propproperty.
Defined.

Corollary squash_to_hProp {X:UU} {Q:hProp} : ∥ X ∥ -> (X -> Q) -> Q.
Proof. intros h f. exact (hinhuniv f h). Defined.

Lemma hdisj_impl_1 {P Q : hProp} : P∨Q -> (Q->P) -> P.
Proof.
  intros o f. apply (squash_to_hProp o).
  intros [p|q].
  - exact p.
  - exact (f q).
Defined.

Lemma hdisj_impl_2 {P Q : hProp} : P∨Q -> (P->Q) -> Q.
Proof.
  intros o f. apply (squash_to_hProp o).
  intros [p|q].
  - exact (f p).
  - exact q.
Defined.

Definition weqlogeq (P Q : hProp) : (P = Q) ≃ (P ⇔ Q).
Proof.
  intros.
  apply weqimplimpl.
  - intro e. induction e. apply isrefl_logeq.
  - intro c. apply hPropUnivalence.
    + exact (pr1 c).
    + exact (pr2 c).
  - apply isasethProp.
  - apply propproperty.
Defined.

Lemma decidable_proof_by_contradiction {P:hProp} : decidable P -> ¬ ¬ P -> P.
Proof.
  intros dec nnp. induction dec as [p|np].
  - exact p.
  - apply fromempty. exact (nnp np).
Defined.

Lemma proof_by_contradiction {P:hProp} : LEM -> ¬ ¬ P -> P.
Proof.
  intro lem.
  exact (decidable_proof_by_contradiction (lem P)).
Defined.

Lemma dneg_elim_to_LEM : (∏ P:hProp, ¬ ¬ P -> P) -> LEM.
(* a converse for Lemma dneg_LEM *)
Proof.
  intros dne. intros P. simple refine (dne (_,,_) _).
  simpl. intros n.
  assert (q : ¬ (P ∨ ¬ P)).
  { now apply weqnegtonegishinh. }
  assert (r := fromnegcoprod_prop q).
  exact (pr2 r (pr1 r)).
Defined.

Lemma negforall_to_existsneg {X:UU} (P:X->hProp) : LEM -> (¬ ∀ x, P x) -> (∃ x, ¬ (P x)).
(* was omitted from the section on "Negation and quantification" in Foundations/Propositions.v *)
Proof.
  intros lem nf. apply (proof_by_contradiction lem); intro c. use nf; clear nf. intro x.
  assert (q := neghexisttoforallneg _ c x); clear c; simpl in q.
  exact (proof_by_contradiction lem q).
Defined.

Lemma negimpl_to_conj (P Q:hProp) : LEM -> ( ¬ (P ⇒ Q) -> P ∧ ¬ Q ).
Proof.
  intros lem ni. assert (r := negforall_to_existsneg _ lem ni); clear lem ni.
  apply (squash_to_hProp r); clear r; intros [p nq]. exact (p,,nq).
Defined.

Definition hrel_set (X : hSet) : hSet := make_hSet (hrel X) (isaset_hrel X).

Lemma isaprop_assume_it_is {X : UU} : (X -> isaprop X) -> isaprop X.
Proof.
  intros f. apply invproofirrelevance; intros x y.
  apply proofirrelevance. now apply f.
Defined.

Lemma isaproptotal2 {X : UU} (P : X → UU) :
  isPredicate P →
  (∏ x y : X, P x → P y → x = y) →
  isaprop (∑ x : X, P x).
Proof.
  intros HP Heq.
  apply invproofirrelevance.
  intros [x p] [y q].
  induction (Heq x y p q).
  induction (iscontrpr1 (HP x p q)).
  apply idpath.
Defined.

(* this is the dependent eliminator for propositional truncation *)
Lemma squash_rec {X : UU} (P : ∥ X ∥ -> hProp) : (∏ x, P (hinhpr x)) -> (∏ x, P x).
Proof.
  intros xp x'. simple refine (hinhuniv _ x'). intro x.
  assert (q : hinhpr x = x').
  { apply propproperty. }
  induction q. exact (xp x).
Defined.

(* here we show that the dependent eliminator does not compute judgmentally *)
Goal ∏ {X:UU} {P:∥X∥ -> hProp} (h : ∏ x, P (hinhpr x)) (x:X),
  squash_rec _ h (hinhpr x) = h x.
Proof.
  Fail reflexivity.             (* too bad! *)
Abort.

(* here's another version *)
Goal ∏ (X:Type)
     (P := λ x':∥X∥, ∃ x, (x' = hinhpr x))
     (h := λ x, (hinhpr (x,,idpath _) : P (hinhpr x)))
     (x:X),
  squash_rec _ h (hinhpr x) = h x.
Proof.
  Fail reflexivity.             (* too bad! *)
Abort.

Lemma logeq_if_both_true (P Q : hProp) : P -> Q -> ( P ⇔ Q ).
Proof.
  intros p q.
  split.
  - intros _. exact q.
  - intros _. exact p.
Defined.

Lemma logeq_if_both_false (P Q : hProp) : ¬P -> ¬Q -> ( P ⇔ Q ).
Proof.
  intros np nq.
  split.
  - intros p. apply fromempty. exact (np p).
  - intros q. apply fromempty. exact (nq q).
Defined.

Definition proofirrelevance_hProp (X : hProp) : isProofIrrelevant X
  := proofirrelevance X (propproperty X).

Ltac induction_hProp x y := induction (proofirrelevance_hProp _ x y).

Definition iscontr_hProp (X:UU) : hProp := make_hProp (iscontr X) (isapropiscontr X).

Notation "'∃!' x .. y , P"
  := (iscontr_hProp (∑ x, .. (∑ y, P) ..))
       (at level 200, x binder, y binder, right associativity) : logic.
(* type this in emacs in agda-input method with \ex ! *)

(** Various algebraic properties of hProp *)
Section hProp_logic.

(** We first state the algebraic properties as bi-implications *)

(* This is already in Foundations/Propositions.v *)
(* Lemma islogeqcommhdisj {P Q : hProp} : hdisj P Q <-> hdisj Q P. *)

Lemma islogeqassochconj {P Q R : hProp} : (P ∧ Q) ∧ R <-> P ∧ (Q ∧ R).
Proof.
split.
- intros PQR.
  exact (pr1 (pr1 PQR),,(pr2 (pr1 PQR),,pr2 PQR)).
- intros PQR.
  exact ((pr1 PQR,,pr1 (pr2 PQR)),,pr2 (pr2 PQR)).
Defined.

Lemma islogeqcommhconj {P Q : hProp} : P ∧ Q <-> Q ∧ P.
Proof.
split.
- intros PQ.
  exact (pr2 PQ,,pr1 PQ).
- intros QP.
  exact (pr2 QP,,pr1 QP).
Defined.

Lemma islogeqassochdisj {P Q R : hProp} : (P ∨ Q) ∨ R <-> P ∨ (Q ∨ R).
Proof.
split.
- apply hinhuniv; intros hPQR.
  induction hPQR as [hPQ|hR].
  + use (hinhuniv _ hPQ); clear hPQ; intros hPQ.
    induction hPQ as [hP|hQ].
    * exact (hinhpr (ii1 hP)).
    * exact (hinhpr (ii2 (hinhpr (ii1 hQ)))).
  + exact (hinhpr (ii2 (hinhpr (ii2 hR)))).
- apply hinhuniv; intros hPQR.
  induction hPQR as [hP|hQR].
  + exact (hinhpr (ii1 (hinhpr (ii1 hP)))).
  + use (hinhuniv _ hQR); clear hQR; intros hQR.
    induction hQR as [hQ|hR].
    * exact (hinhpr (ii1 (hinhpr (ii2 hQ)))).
    * exact (hinhpr (ii2 hR)).
Defined.

Lemma islogeqhconj_absorb_hdisj {P Q : hProp} : P ∧ (P ∨ Q) <-> P.
Proof.
split.
- intros hPPQ; apply (pr1 hPPQ).
- intros hP.
  split; [ apply hP | apply (hinhpr (ii1 hP)) ].
Defined.

Lemma islogeqhdisj_absorb_hconj {P Q : hProp} : P ∨ (P ∧ Q) <-> P.
Proof.
split.
- apply hinhuniv; intros hPPQ.
  induction hPPQ as [hP|hPQ].
  + exact hP.
  + exact (pr1 hPQ).
- intros hP; apply (hinhpr (ii1 hP)).
Defined.

Lemma islogeqhfalse_hdisj {P : hProp} : ∅ ∨ P <-> P.
Proof.
split.
- apply hinhuniv; intros hPPQ.
  induction hPPQ as [hF|hP].
  + induction hF.
  + exact hP.
- intros hP; apply (hinhpr (ii2 hP)).
Defined.

Lemma islogeqhhtrue_hconj {P : hProp} : htrue ∧ P <-> P.
Proof.
split.
- intros hP; apply (pr2 hP).
- intros hP.
  split; [ apply tt | apply hP ].
Defined.

(** We now turn these into equalities using univalence for propositions *)
Lemma isassoc_hconj (P Q R : hProp) : ((P ∧ Q) ∧ R) = (P ∧ (Q ∧ R)).
Proof.
now apply hPropUnivalence; apply islogeqassochconj.
Qed.

Lemma iscomm_hconj (P Q : hProp) : (P ∧ Q) = (Q ∧ P).
Proof.
now apply hPropUnivalence; apply islogeqcommhconj.
Qed.

Lemma isassoc_hdisj (P Q R : hProp) : ((P ∨ Q) ∨ R) = (P ∨ (Q ∨ R)).
Proof.
now apply hPropUnivalence; apply islogeqassochdisj.
Qed.

Lemma iscomm_hdisj (P Q : hProp) : (P ∨ Q) = (Q ∨ P).
Proof.
now apply hPropUnivalence; apply islogeqcommhdisj.
Qed.

Lemma hconj_absorb_hdisj (P Q : hProp) : (P ∧ (P ∨ Q)) = P.
Proof.
now apply hPropUnivalence; apply islogeqhconj_absorb_hdisj.
Qed.

Lemma hdisj_absorb_hconj (P Q : hProp) : (P ∨ (P ∧ Q)) = P.
Proof.
now apply hPropUnivalence; apply islogeqhdisj_absorb_hconj.
Qed.

Lemma hfalse_hdisj (P : hProp) : (∅ ∨ P) = P.
Proof.
now apply hPropUnivalence; apply islogeqhfalse_hdisj.
Qed.

Lemma htrue_hconj (P : hProp) : (htrue ∧ P) = P.
Proof.
now apply hPropUnivalence; apply islogeqhhtrue_hconj.
Qed.

End hProp_logic.

(** ** Factoring maps through squash *)

Lemma squash_uniqueness {X} (x:X) (h:∥ X ∥) : squash_element x = h.
Proof. intros. apply propproperty. Qed.

Goal ∏ X Q (i:isaprop Q) (f:X -> Q) (x:X),
   factor_through_squash i f (squash_element x) = f x.
Proof. reflexivity. Defined.

Lemma factor_dep_through_squash {X} {Q:∥ X ∥->UU} :
  (∏ h, isaprop (Q h)) ->
  (∏ x, Q(squash_element x)) ->
  (∏ h, Q h).
Proof.
  intros i f ?.  apply (h (make_hProp (Q h) (i h))).
  intro x. simpl. induction (squash_uniqueness x h). exact (f x).
Defined.

Lemma factor_through_squash_hProp {X} : ∏ hQ:hProp, (X -> hQ) -> ∥ X ∥ -> hQ.
Proof. intros [Q i] f h. refine (h _ _). assumption. Defined.

Lemma funspace_isaset {X Y} : isaset Y -> isaset (X -> Y).
Proof. intros is. apply (impredfun 2). assumption. Defined.

Lemma squash_map_uniqueness {X S} (ip : isaset S) (g g' : ∥ X ∥ -> S) :
  g ∘ squash_element ~ g' ∘ squash_element -> g ~ g'.
Proof.
  intros h.
  set ( Q := λ y, g y = g' y ).
  unfold homot.
  apply (@factor_dep_through_squash X). intros y. apply ip.
  intro x. apply h.
Qed.

Lemma squash_map_epi {X S} (ip : isaset S) (g g' : ∥ X ∥ -> S) :
  g ∘ squash_element = g'∘ squash_element -> g = g'.
Proof.
  intros e.
  apply funextsec.
  apply squash_map_uniqueness. exact ip.
  intro x. induction e. apply idpath.
Qed.

Lemma uniqueExists {A : UU} {P : A -> UU} {a b : A}
  (Hexists : ∃! a, P a) (Ha : P a) (Hb : P b) : a = b.
Proof.
  assert (H : tpair _ _ Ha = tpair _ _ Hb).
  { now apply proofirrelevancecontr. }
  exact (base_paths _ _ H).
Defined.

(** ** Connected types *)

Definition isConnected X : hProp := ∥ X ∥ ∧ ∀ (x y:X), ∥ x = y ∥.

Lemma predicateOnConnectedType {X:Type} (i : isConnected X) {P:X->hProp} (x0:X) (p:P x0) :
   ∏ x, P x.
Proof.
  intros x. apply (squash_to_hProp (pr2 i x x0)); intros e. now induction e.
Defined.

Definition isBaseConnected (X:PointedType) : hProp := ∀ (y:X), ∥ basepoint X = y ∥.

Lemma isConnected_isBaseConnected (X:PointedType) : isConnected X <-> isBaseConnected X.
Proof.
  split.
  - intros [_ ic] x. use ic.
  - intros ibc. split.
    + exact (hinhpr (basepoint X)).
    + intros x y.
      apply (squash_to_hProp (ibc x)); intros p; apply (squash_to_hProp (ibc y)); intros q.
      exact (hinhpr (!p @ q)).
Defined.

Definition BasePointComponent (X:PointedType) : PointedType :=
  pointedType (∑ (y:X), ∥ basepoint X = y ∥) (basepoint X,, hinhpr (idpath (basepoint X))).

Definition basePointComponent_inclusion {X:PointedType} (x : BasePointComponent X) : X
  := pr1 x.

Lemma BasePointComponent_isBaseConnected (X:PointedType) : isBaseConnected (BasePointComponent X).
Proof.
  intros [x' c'].
  change (basepoint (BasePointComponent X))
    with (tpair (λ (y:X), ∥ basepoint X = y ∥) (basepoint X) (hinhpr (idpath (basepoint X)))).
  use (hinhfun _ c'); intro q. induction q.
  apply maponpaths. apply propproperty.
Defined.

Lemma BasePointComponent_isincl {X:PointedType} : isincl (@basePointComponent_inclusion X).
Proof.
  use isinclpr1. intros x. apply propproperty.
Defined.

Lemma BasePointComponent_isweq {X:PointedType} (bc : isBaseConnected X) :
  isweq (@basePointComponent_inclusion X).
Proof.
  use isweqpr1.
  intros x.
  apply iscontraprop1.
  - apply propproperty.
  - exact (bc x).
Defined.

Definition BasePointComponent_weq {X:PointedType} (bc : isBaseConnected X) :
  BasePointComponent X ≃ X
  := make_weq (@basePointComponent_inclusion X) (BasePointComponent_isweq bc).

Lemma baseConnectedness X : isBaseConnected X -> isConnected X.
Proof.
  intros p. split.
  - exact (hinhpr (basepoint X)).
  - intros x y. assert (a := p x); assert (b := p y); clear p.
    apply (squash_to_prop a); [apply propproperty|]; clear a; intros a.
    apply (squash_to_prop b); [apply propproperty|]; clear b; intros b.
    apply hinhpr. exact (!a@b).
Defined.

Lemma predicateOnBaseConnectedType (X:PointedType) (b:isBaseConnected X)
      (P:X->hProp) (p:P (basepoint X)) :
   ∏ x, P x.
Proof.
  intros x. apply (squash_to_hProp (b x)); intros e. now induction e.
Defined.

Goal ∏ (X:PointedType) (b:isBaseConnected X) (P:X->hProp) (p:P (basepoint X)),
       predicateOnBaseConnectedType X b P p (basepoint X) = p.
Proof.
  Fail reflexivity.
  intros.
  (* stuck *)
Abort.

Lemma predicateOnBasePointComponent
      (X:PointedType) (X' := BasePointComponent X) (pt' := basepoint X')
      (P:X'->hProp) (p:P pt') :
   ∏ x, P x.
Proof.
  intros x.
  apply (squash_to_hProp (BasePointComponent_isBaseConnected _ x)); intros e.
  now induction e.
Defined.

Goal ∏ (X:PointedType)
     (X' := BasePointComponent X) (pt' := basepoint X')
     (P:X'->hProp) (p:P pt'),
   predicateOnBasePointComponent X P p pt' = p.
Proof.
  Fail reflexivity.
  intros.
  unfold pt', basepoint, X', BasePointComponent, pointedType, pr2; cbn beta.
Abort.


(* Copyright (c) 2012-2017, Coq-std++ developers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file implements sets as functions into Prop. *)
From stdpp Require Export collections.
Set Default Proof Using "Type".

Record set (A : Type) : Type := mkSet { set_car : A → Prop }.
Add Printing Constructor set.
Arguments mkSet {_} _ : assert.
Arguments set_car {_} _ _ : assert.
Notation "{[ x | P ]}" := (mkSet (λ x, P))
  (at level 1, format "{[  x  |  P  ]}") : stdpp_scope.

Instance set_elem_of {A} : ElemOf A (set A) := λ x X, set_car X x.

Instance set_top {A} : Top (set A) := {[ _ | True ]}.
Instance set_empty {A} : Empty (set A) := {[ _ | False ]}.
Instance set_singleton {A} : Singleton A (set A) := λ y, {[ x | y = x ]}.
Instance set_union {A} : Union (set A) := λ X1 X2, {[ x | x ∈ X1 ∨ x ∈ X2 ]}.
Instance set_intersection {A} : Intersection (set A) := λ X1 X2,
  {[ x | x ∈ X1 ∧ x ∈ X2 ]}.
Instance set_difference {A} : Difference (set A) := λ X1 X2,
  {[ x | x ∈ X1 ∧ x ∉ X2 ]}.
Instance set_collection : Collection A (set A).
Proof. split; [split | |]; by repeat intro. Qed.

Lemma elem_of_top {A} (x : A) : x ∈ (⊤ : set A) ↔ True.
Proof. done. Qed.
Lemma elem_of_mkSet {A} (P : A → Prop) x : x ∈ {[ x | P x ]} ↔ P x.
Proof. done. Qed.
Lemma not_elem_of_mkSet {A} (P : A → Prop) x : x ∉ {[ x | P x ]} ↔ ¬P x.
Proof. done. Qed.
Lemma top_subseteq {A} (X : set A) : X ⊆ ⊤.
Proof. done. Qed.
Hint Resolve top_subseteq.

Instance set_ret : MRet set := λ A (x : A), {[ x ]}.
Instance set_bind : MBind set := λ A B (f : A → set B) (X : set A),
  mkSet (λ b, ∃ a, b ∈ f a ∧ a ∈ X).
Instance set_fmap : FMap set := λ A B (f : A → B) (X : set A),
  {[ b | ∃ a, b = f a ∧ a ∈ X ]}.
Instance set_join : MJoin set := λ A (XX : set (set A)),
  {[ a | ∃ X : set A, a ∈ X ∧ X ∈ XX ]}.
Instance set_collection_monad : CollectionMonad set.
Proof. by split; try apply _. Qed.

Instance set_unfold_set_all {A} (x : A) : SetUnfold (x ∈ (⊤ : set A)) True.
Proof. by constructor. Qed.
Instance set_unfold_mkSet {A} (P : A → Prop) x Q :
  SetUnfoldSimpl (P x) Q → SetUnfold (x ∈ mkSet P) Q.
Proof. intros HPQ. constructor. apply HPQ. Qed.

Global Opaque set_elem_of set_top set_empty set_singleton.
Global Opaque set_union set_intersection set_difference.
Global Opaque set_ret set_bind set_fmap set_join.


Load "preamble2D.v".

(* dans la couche 0 *)
Lemma LMNP : forall A B C M N P ,
rk(A :: B :: C ::  nil) = 3 -> rk(A :: B :: M ::  nil) = 2 -> rk(A :: C :: N ::  nil) = 2 ->
rk(B :: C :: P ::  nil) = 2 -> rk(M :: N :: P ::  nil) >= 1/\rk(M :: N :: P ::  nil) <= 3.
Proof.

intros A B C M N P
HABCeq HABMeq HACNeq HBCPeq .

assert(HMNPM : rk(M :: N :: P ::  nil) <= 3) by (solve_hyps_max HMNPeq HMNPM3).
assert(HMNPm : rk(M :: N :: P ::  nil) >= 1) by (solve_hyps_min HMNPeq HMNPm1).
split. intuition. intuition.
Qed.


Require Import ssreflect ssrfun ssrbool.
Require Import Generic.lemmas Generic.wlog.
Require Import PG32.pg32_inductive PG32.pg32_spreads_packings.

Require Import Lia.
Require Import List.
Import ListNotations.

Lemma Point_dec : forall p q : Point, {p=q}+{p<>q}.
Proof.
intros p q; case p; case q; solve [left; reflexivity | right; discriminate].
Defined.

Lemma Line_dec : forall p q : Line, {p=q}+{p<>q}.
Proof.
intros p q; case p; case q; solve [left; reflexivity | right; discriminate].
Defined.

Definition eqL (p q : Line) : bool :=
  match (Line_dec p q) with left _ => true | right _ => false end.

Definition add_points_list (l:Line) (acc:list Point) :=
  match (points_from_line l) with
  (p,q,r) => (* p::q::r::acc*)
  if (in_dec Point_dec r acc)
  then
    if (in_dec Point_dec q acc)
    then
      if (in_dec Point_dec p acc)
      then acc
      else p::acc
    else
      if (in_dec Point_dec p acc)
      then q::acc
      else p::q::acc
  else
    if (in_dec Point_dec q acc)
    then
      if (in_dec Point_dec p acc)
      then r::acc
      else p::r::acc
    else
      if (in_dec Point_dec p acc)
      then q::r::acc
      else p::q::r::acc
  end.

Definition all_points_of_line (l:  Line) := match (points_from_line l) with (A,B,C) => [A;B;C] end.

Definition all_points_of_lines (l: list Line) := fold_right add_points_list (@nil Point) l.

Eval compute in all_points_of_lines (L0::L1::L2::L3::L4::nil).

Definition dist_5l  (A B C D E:Line) : bool :=
    (negb (eqL A B)) && (negb (eqL A C)) && (negb (eqL A D)) && (negb (eqL A E))
                     && (negb (eqL B C)) && (negb (eqL B D)) && (negb (eqL B E))
                     && (negb (eqL C D)) && (negb (eqL C E))
                     && (negb (eqL D E)).

Definition inter (l1 l2:Line) : option Point :=
    match (points_from_line l1) with ((X,Y),Z) =>
      match (points_from_line l2) with (X',Y',Z') =>
              if (Point_dec X X') then Some (X) else
                if (Point_dec X Y') then Some (X) else
                  if (Point_dec X Z') then Some (X) else
                    if (Point_dec Y X') then Some (Y) else
                      if (Point_dec Y Y') then Some (Y) else
                        if (Point_dec Y Z') then (Some Y) else
                          if (Point_dec Z X') then (Some Z) else
                            if (Point_dec Z Y') then (Some Z) else
                              if (Point_dec Z Z') then (Some Z) else None end end.

Definition disjoint (l1 l2:Line) : bool :=
  match inter l1 l2 with
  | None => true
  | Some _ => false
  end.

Definition disj_5l (A B C D E:Line) : bool :=
    (disjoint A B) && (disjoint A C) && (disjoint A D) && (disjoint A E)
                     && (disjoint B C) && (disjoint B D) && (disjoint B E)
                     && (disjoint C D) && (disjoint C E)
                     && (disjoint D E).

Definition forall_Point (f:Point -> bool) : bool :=
  f P0 && f P1 && f P2 && f P3 && f P4 && f P5 && f P6 && f P7 && f P8 && f P9 && f P10 && f P11 && f P12 && f P13 && f P14.

Lemma forall_forall_Point : forall P:Point->bool, (forall p:Point, P p) <-> forall_Point P.
Proof.
  intros P; split.
  intros H; unfold forall_Point; repeat apply foo; apply H.
  unfold forall_Point; intros Hf.
  induction p; revert Hf; repeat rewrite and_bool; intros Hf; intuition.
Qed.

Definition inb := in_dec Point_dec.

Definition is_partition5 (p q r s t: list Point) :bool :=
  (forall_Point (fun x => inb x p || inb x q || inb x r || inb x s || inb x t))
    && (forall_Point (fun x => negb (inb x p && inb x q && inb x r && inb x s && inb x t))).

Definition is_spread5 (l1 l2 l3 l4 l5:Line) : bool :=
  disj_5l l1 l2 l3 l4 l5  &&
          is_partition5 (all_points_of_line l1) (all_points_of_line l2) (all_points_of_line l3) (all_points_of_line l4) (all_points_of_line l5).

(*
Lemma simpler : forall l1 l2 l3 l4 l5:Line, is_partition5 (all_points_of_lines (l1::nil)) (all_points_of_lines (l2::nil)) (all_points_of_lines (l3::nil)) (all_points_of_lines (l4::nil)) (all_points_of_lines (l5::nil)) -> disj_5l l1 l2 l3 l4 l5.
Proof.
  intros l1 l2 l3 l4 l5 Hpart; destruct l1; destruct l2.
  unfold is_partition5 in Hpart.
  revert Hpart; rewrite and_bool; intros [Hpart1 Hpart2].
  unfold forall_Point in Hpart1, Hpart2; try solve [exact (degen_bool _ Hpart1) | exact (degen_bool _ Hpart2)].
  unfold disj_5l, is_partition5 in *.
  unfold forall_Point in H; simpl in H.
revert H; rewrite and_bool; intros H.
rewrite <- forall_forall_Point in H.
rewrite <- forall_forall_Point in H.
destruct H as [HA HB].
destruct l3; destruct l4; destruct l5; try solve [exact (degen_bool _ HA) | exact (degen_bool _ HB) | exact (erefl true)].
  destruct (and_bool_lr _  _ H).
 (* simpl in H1.

; destruct l3; destruct l4; destruct l5.*)

           (abstract (destruct l3; abstract (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) | destruct l4;
                                                                                abstract (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His)
                                                                                | destruct l5;
                                                                                abstract (solve [ exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                                           exact (erefl true)])])]))).
Show Proof.
 *)

(* there are only 56 spreads - try_pg32.c finds them all *)

Lemma eqL_eq : forall x y, eqL x y -> x=y.
Proof.
intros.
destruct x; destruct y;solve [reflexivity | discriminate].
Qed.

Lemma is_spread_descr_A :
  forall l1 l2 l3 l4 l5 : Line, In [l1;l2;l3;l4;l5] spreads -> (is_spread5 l1 l2 l3 l4 l5).
Proof.
  intros l1 l2 l3 l4 l5 HIn_S.
  repeat (destruct HIn_S as [HeqL | HIn_S]; [unfold S0 in *; inversion HeqL; reflexivity | idtac]).
inversion HIn_S.
Qed.

(* 35 auxiliary lemmas when l1=L0, l1=L1, etc. *)

Ltac solve_In := solve [apply in_eq | apply in_cons; solve_In].

Lemma aux_L0 : forall l2 l3 l4 l5 : Line,
  leL L0 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L0 l2 l3 l4 l5 -> In [L0; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L1 : forall l2 l3 l4 l5 : Line,
  leL L1 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L1 l2 l3 l4 l5 -> In [L1; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L2 : forall l2 l3 l4 l5 : Line,
  leL L2 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L2 l2 l3 l4 l5 -> In [L2; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L3 : forall l2 l3 l4 l5 : Line,
  leL L3 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L3 l2 l3 l4 l5 -> In [L3; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L4 : forall l2 l3 l4 l5 : Line,
  leL L4 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L4 l2 l3 l4 l5 -> In [L4; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L5 : forall l2 l3 l4 l5 : Line,
  leL L5 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L5 l2 l3 l4 l5 -> In [L5; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L6 : forall l2 l3 l4 l5 : Line,
  leL L6 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L6 l2 l3 l4 l5 -> In [L6; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L7 : forall l2 l3 l4 l5 : Line,
  leL L7 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L7 l2 l3 l4 l5 -> In [L7; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L8 : forall l2 l3 l4 l5 : Line,
  leL L8 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L8 l2 l3 l4 l5 -> In [L8; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L9 : forall l2 l3 l4 l5 : Line,
  leL L9 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L9 l2 l3 l4 l5 -> In [L9; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.
Lemma aux_L10 : forall l2 l3 l4 l5 : Line,
  leL L10 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L10 l2 l3 l4 l5 -> In [L10; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L11 : forall l2 l3 l4 l5 : Line,
  leL L11 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L11 l2 l3 l4 l5 -> In [L11; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L12 : forall l2 l3 l4 l5 : Line,
  leL L12 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L12 l2 l3 l4 l5 -> In [L12; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L13 : forall l2 l3 l4 l5 : Line,
  leL L13 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L13 l2 l3 l4 l5 -> In [L13; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L14 : forall l2 l3 l4 l5 : Line,
  leL L14 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L14 l2 l3 l4 l5 -> In [L14; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L15 : forall l2 l3 l4 l5 : Line,
  leL L15 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L15 l2 l3 l4 l5 -> In [L15; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L16 : forall l2 l3 l4 l5 : Line,
  leL L16 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L16 l2 l3 l4 l5 -> In [L16; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L17 : forall l2 l3 l4 l5 : Line,
  leL L17 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L17 l2 l3 l4 l5 -> In [L17; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L18 : forall l2 l3 l4 l5 : Line,
  leL L18 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L18 l2 l3 l4 l5 -> In [L18; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.
Lemma aux_L19 : forall l2 l3 l4 l5 : Line,
  leL L19 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L19 l2 l3 l4 l5 -> In [L19; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.
Lemma aux_L20 : forall l2 l3 l4 l5 : Line,
  leL L20 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L20 l2 l3 l4 l5 -> In [L20; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L21 : forall l2 l3 l4 l5 : Line,
  leL L21 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L21 l2 l3 l4 l5 -> In [L21; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L22 : forall l2 l3 l4 l5 : Line,
  leL L22 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L22 l2 l3 l4 l5 -> In [L22; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L23 : forall l2 l3 l4 l5 : Line,
  leL L23 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L23 l2 l3 l4 l5 -> In [L23; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L24 : forall l2 l3 l4 l5 : Line,
  leL L24 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L24 l2 l3 l4 l5 -> In [L24; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L25 : forall l2 l3 l4 l5 : Line,
  leL L25 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L25 l2 l3 l4 l5 -> In [L25; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L26 : forall l2 l3 l4 l5 : Line,
  leL L26 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L26 l2 l3 l4 l5 -> In [L26; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L27 : forall l2 l3 l4 l5 : Line,
  leL L27 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L27 l2 l3 l4 l5 -> In [L27; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L28 : forall l2 l3 l4 l5 : Line,
  leL L28 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L28 l2 l3 l4 l5 -> In [L28; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L29 : forall l2 l3 l4 l5 : Line,
  leL L29 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L29 l2 l3 l4 l5 -> In [L29; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L30 : forall l2 l3 l4 l5 : Line,
  leL L30 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L30 l2 l3 l4 l5 -> In [L30; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L31 : forall l2 l3 l4 l5 : Line,
  leL L31 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L31 l2 l3 l4 l5 -> In [L31; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L32 : forall l2 l3 l4 l5 : Line,
  leL L32 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L32 l2 l3 l4 l5 -> In [L32; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L33 : forall l2 l3 l4 l5 : Line,
  leL L33 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L33 l2 l3 l4 l5 -> In [L33; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma aux_L34 : forall l2 l3 l4 l5 : Line,
  leL L34 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 -> is_spread5 L34 l2 l3 l4 l5 -> In [L34; l2; l3; l4; l5] spreads.
Proof.
  intros l2 l3 l4 l5 Hle His;
    destruct l2; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l3; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l4; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
     destruct l5; (solve [exact (degen_bool _ Hle) | exact (degen_bool _ His) |
                    solve [unfold spreads;solve_In]])])])]).
Qed.

Lemma is_spread_descr_B :
  forall l1 l2 l3 l4 l5 : Line,
    leL l1 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 ->
    (is_spread5 l1 l2 l3 l4 l5) -> In [l1;l2;l3;l4;l5] spreads.
Proof.
  intros l1 l2 l3 l4 l5 Hle His; destruct l1.
  apply aux_L0; assumption.
  apply aux_L1; assumption.
  apply aux_L2; assumption.
  apply aux_L3; assumption.
  apply aux_L4; assumption.
  apply aux_L5; assumption.
  apply aux_L6; assumption.
  apply aux_L7; assumption.
  apply aux_L8; assumption.
  apply aux_L9; assumption.
  apply aux_L10; assumption.
  apply aux_L11; assumption.
  apply aux_L12; assumption.
  apply aux_L13; assumption.
  apply aux_L14; assumption.
  apply aux_L15; assumption.
  apply aux_L16; assumption.
  apply aux_L17; assumption.
  apply aux_L18; assumption.
  apply aux_L19; assumption.
  apply aux_L20; assumption.
  apply aux_L21; assumption.
  apply aux_L22; assumption.
  apply aux_L23; assumption.
  apply aux_L24; assumption.
  apply aux_L25; assumption.
  apply aux_L26; assumption.
  apply aux_L27; assumption.
  apply aux_L28; assumption.
  apply aux_L29; assumption.
  apply aux_L30; assumption.
  apply aux_L31; assumption.
  apply aux_L32; assumption.
  apply aux_L33; assumption.
  apply aux_L34; assumption.
Qed.

(* main theorem *)
Lemma is_spread_descr : forall l1 l2 l3 l4 l5,
    leL l1 l2 && leL l2 l3 && leL l3 l4 && leL l4 l5 ->
    (is_spread5 l1 l2 l3 l4 l5 <-> In [l1;l2;l3;l4;l5] spreads).
Proof.
  intros; split; [apply is_spread_descr_B ; assumption| apply is_spread_descr_A].
Qed.

(* corollary: making the lines explicit (56 equalities) *)
Lemma equiv_spreads_def : forall l1 l2 l3 l4 l5:Line,
    In [l1;l2;l3;l4;l5] spreads <->
    (((eqL l1 L0) &&(eqL l2 L19) && (eqL l3 L24) && (eqL l4 L28) && (eqL l5 L33)) ||
     ((eqL l1 L0) &&(eqL l2 L19) && (eqL l3 L26) && (eqL l4 L29) && (eqL l5 L32)) ||
     ((eqL l1 L0) &&(eqL l2 L20) && (eqL l3 L23) && (eqL l4 L28) && (eqL l5 L34)) ||
     ((eqL l1 L0) &&(eqL l2 L20) && (eqL l3 L25) && (eqL l4 L29) && (eqL l5 L31)) ||
     ((eqL l1 L0) &&(eqL l2 L21) && (eqL l3 L24) && (eqL l4 L30) && (eqL l5 L31)) ||
     ((eqL l1 L0) &&(eqL l2 L21) && (eqL l3 L26) && (eqL l4 L27) && (eqL l5 L34)) ||
     ((eqL l1 L0) &&(eqL l2 L22) && (eqL l3 L23) && (eqL l4 L30) && (eqL l5 L32)) ||
     ((eqL l1 L0) &&(eqL l2 L22) && (eqL l3 L25) && (eqL l4 L27) && (eqL l5 L33)) ||
     ((eqL l1 L1) &&(eqL l2 L8) && (eqL l3 L14) && (eqL l4 L28) && (eqL l5 L33)) ||
     ((eqL l1 L1) &&(eqL l2 L8) && (eqL l3 L16) && (eqL l4 L29) && (eqL l5 L31)) ||
     ((eqL l1 L1) &&(eqL l2 L9) && (eqL l3 L13) && (eqL l4 L29) && (eqL l5 L32)) ||
     ((eqL l1 L1) &&(eqL l2 L9) && (eqL l3 L18) && (eqL l4 L28) && (eqL l5 L34)) ||
     ((eqL l1 L1) &&(eqL l2 L10) && (eqL l3 L14) && (eqL l4 L30) && (eqL l5 L32)) ||
     ((eqL l1 L1) &&(eqL l2 L10) && (eqL l3 L16) && (eqL l4 L27) && (eqL l5 L34)) ||
     ((eqL l1 L1) &&(eqL l2 L11) && (eqL l3 L13) && (eqL l4 L27) && (eqL l5 L33)) ||
     ((eqL l1 L1) &&(eqL l2 L11) && (eqL l3 L18) && (eqL l4 L30) && (eqL l5 L31)) ||
     ((eqL l1 L2) &&(eqL l2 L8) && (eqL l3 L14) && (eqL l4 L21) && (eqL l5 L26)) ||
     ((eqL l1 L2) &&(eqL l2 L8) && (eqL l3 L16) && (eqL l4 L22) && (eqL l5 L23)) ||
     ((eqL l1 L2) &&(eqL l2 L9) && (eqL l3 L13) && (eqL l4 L21) && (eqL l5 L24)) ||
     ((eqL l1 L2) &&(eqL l2 L9) && (eqL l3 L18) && (eqL l4 L22) && (eqL l5 L25)) ||
     ((eqL l1 L2) &&(eqL l2 L10) && (eqL l3 L14) && (eqL l4 L20) && (eqL l5 L25)) ||
     ((eqL l1 L2) &&(eqL l2 L10) && (eqL l3 L16) && (eqL l4 L19) && (eqL l5 L24)) ||
     ((eqL l1 L2) &&(eqL l2 L11) && (eqL l3 L13) && (eqL l4 L20) && (eqL l5 L23)) ||
     ((eqL l1 L2) &&(eqL l2 L11) && (eqL l3 L18) && (eqL l4 L19) && (eqL l5 L26)) ||
     ((eqL l1 L3) &&(eqL l2 L7) && (eqL l3 L14) && (eqL l4 L21) && (eqL l5 L30)) ||
     ((eqL l1 L3) &&(eqL l2 L7) && (eqL l3 L16) && (eqL l4 L19) && (eqL l5 L29)) ||
     ((eqL l1 L3) &&(eqL l2 L9) && (eqL l3 L15) && (eqL l4 L25) && (eqL l5 L29)) ||
     ((eqL l1 L3) &&(eqL l2 L9) && (eqL l3 L17) && (eqL l4 L21) && (eqL l5 L34)) ||
     ((eqL l1 L3) &&(eqL l2 L11) && (eqL l3 L15) && (eqL l4 L23) && (eqL l5 L30)) ||
     ((eqL l1 L3) &&(eqL l2 L11) && (eqL l3 L17) && (eqL l4 L19) && (eqL l5 L33)) ||
     ((eqL l1 L3) &&(eqL l2 L12) && (eqL l3 L14) && (eqL l4 L25) && (eqL l5 L33)) ||
     ((eqL l1 L3) &&(eqL l2 L12) && (eqL l3 L16) && (eqL l4 L23) && (eqL l5 L34)) ||
     ((eqL l1 L4) &&(eqL l2 L7) && (eqL l3 L14) && (eqL l4 L20) && (eqL l5 L28)) ||
     ((eqL l1 L4) &&(eqL l2 L7) && (eqL l3 L16) && (eqL l4 L22) && (eqL l5 L27)) ||
     ((eqL l1 L4) &&(eqL l2 L9) && (eqL l3 L15) && (eqL l4 L24) && (eqL l5 L28)) ||
     ((eqL l1 L4) &&(eqL l2 L9) && (eqL l3 L17) && (eqL l4 L22) && (eqL l5 L32)) ||
     ((eqL l1 L4) &&(eqL l2 L11) && (eqL l3 L15) && (eqL l4 L26) && (eqL l5 L27)) ||
     ((eqL l1 L4) &&(eqL l2 L11) && (eqL l3 L17) && (eqL l4 L20) && (eqL l5 L31)) ||
     ((eqL l1 L4) &&(eqL l2 L12) && (eqL l3 L14) && (eqL l4 L26) && (eqL l5 L32)) ||
     ((eqL l1 L4) &&(eqL l2 L12) && (eqL l3 L16) && (eqL l4 L24) && (eqL l5 L31)) ||
     ((eqL l1 L5) &&(eqL l2 L7) && (eqL l3 L13) && (eqL l4 L21) && (eqL l5 L27)) ||
     ((eqL l1 L5) &&(eqL l2 L7) && (eqL l3 L18) && (eqL l4 L19) && (eqL l5 L28)) ||
     ((eqL l1 L5) &&(eqL l2 L8) && (eqL l3 L15) && (eqL l4 L23) && (eqL l5 L28)) ||
     ((eqL l1 L5) &&(eqL l2 L8) && (eqL l3 L17) && (eqL l4 L21) && (eqL l5 L31)) ||
     ((eqL l1 L5) &&(eqL l2 L10) && (eqL l3 L15) && (eqL l4 L25) && (eqL l5 L27)) ||
     ((eqL l1 L5) &&(eqL l2 L10) && (eqL l3 L17) && (eqL l4 L19) && (eqL l5 L32)) ||
     ((eqL l1 L5) &&(eqL l2 L12) && (eqL l3 L13) && (eqL l4 L23) && (eqL l5 L32)) ||
     ((eqL l1 L5) &&(eqL l2 L12) && (eqL l3 L18) && (eqL l4 L25) && (eqL l5 L31)) ||
     ((eqL l1 L6) &&(eqL l2 L7) && (eqL l3 L13) && (eqL l4 L20) && (eqL l5 L29)) ||
     ((eqL l1 L6) &&(eqL l2 L7) && (eqL l3 L18) && (eqL l4 L22) && (eqL l5 L30)) ||
     ((eqL l1 L6) &&(eqL l2 L8) && (eqL l3 L15) && (eqL l4 L26) && (eqL l5 L29)) ||
     ((eqL l1 L6) &&(eqL l2 L8) && (eqL l3 L17) && (eqL l4 L22) && (eqL l5 L33)) ||
     ((eqL l1 L6) &&(eqL l2 L10) && (eqL l3 L15) && (eqL l4 L24) && (eqL l5 L30)) ||
     ((eqL l1 L6) &&(eqL l2 L10) && (eqL l3 L17) && (eqL l4 L20) && (eqL l5 L34)) ||
     ((eqL l1 L6) &&(eqL l2 L12) && (eqL l3 L13) && (eqL l4 L24) && (eqL l5 L33)) ||
     ((eqL l1 L6) &&(eqL l2 L12) && (eqL l3 L18) && (eqL l4 L26) && (eqL l5 L34)) ).
Proof.
  intros l1 l2 l3 l4 l5.
  split.
  intros HIn_S.
  repeat (destruct HIn_S as [HeqL | HIn_S]; [unfold S0 in *; inversion HeqL; reflexivity | idtac]).
  inversion HIn_S.
  repeat rewrite or_bool;repeat rewrite ab5_bool.
  intros Hor; repeat destruct Hor as [Hor | Hor];
    destruct Hor as [Hand1  [Hand2 [Hand3 [Hand4 Hand5]]]];
    rewrite (eqL_eq _  _ Hand1);
    rewrite (eqL_eq _  _ Hand2);
    rewrite (eqL_eq _  _ Hand3);
    rewrite (eqL_eq _  _ Hand4);
    rewrite (eqL_eq _  _ Hand5); solve [repeat apply in_eq || apply in_cons].
Qed.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__8__2.
Require Export lemma__8__3.
Require Export lemma__collinearorder.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__droppedperpendicularunique.
Require Export lemma__extension.
Require Export lemma__extensionunique.
Require Export lemma__inequalitysymmetric.
Require Export lemma__ray4.
Require Export logic.
Definition lemma__8__7 : forall A B C, (euclidean__defs.Per C B A) -> (~(euclidean__defs.Per A C B)).
Proof.
intro A.
intro B.
intro C.
intro H.
assert (* Cut *) (euclidean__axioms.neq B A) as H0.
- assert (exists X, (euclidean__axioms.BetS C B X) /\ ((euclidean__axioms.Cong C B X B) /\ ((euclidean__axioms.Cong C A X A) /\ (euclidean__axioms.neq B A)))) as H0 by exact H.
assert (exists X, (euclidean__axioms.BetS C B X) /\ ((euclidean__axioms.Cong C B X B) /\ ((euclidean__axioms.Cong C A X A) /\ (euclidean__axioms.neq B A)))) as __TmpHyp by exact H0.
destruct __TmpHyp as [x H1].
destruct H1 as [H2 H3].
destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
exact H7.
- assert (* Cut *) (euclidean__defs.Per A B C) as H1.
-- apply (@lemma__8__2.lemma__8__2 C B A H).
-- assert (* Cut *) (euclidean__axioms.neq B C) as H2.
--- assert (exists X, (euclidean__axioms.BetS A B X) /\ ((euclidean__axioms.Cong A B X B) /\ ((euclidean__axioms.Cong A C X C) /\ (euclidean__axioms.neq B C)))) as H2 by exact H1.
assert (exists X, (euclidean__axioms.BetS A B X) /\ ((euclidean__axioms.Cong A B X B) /\ ((euclidean__axioms.Cong A C X C) /\ (euclidean__axioms.neq B C)))) as __TmpHyp by exact H2.
destruct __TmpHyp as [x H3].
destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
assert (exists X, (euclidean__axioms.BetS C B X) /\ ((euclidean__axioms.Cong C B X B) /\ ((euclidean__axioms.Cong C A X A) /\ (euclidean__axioms.neq B A)))) as H10 by exact H.
assert (exists X, (euclidean__axioms.BetS C B X) /\ ((euclidean__axioms.Cong C B X B) /\ ((euclidean__axioms.Cong C A X A) /\ (euclidean__axioms.neq B A)))) as __TmpHyp0 by exact H10.
destruct __TmpHyp0 as [x0 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H9.
--- assert (* Cut *) (euclidean__axioms.neq C B) as H3.
---- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B C H2).
---- assert (* Cut *) (exists E, (euclidean__axioms.BetS B C E) /\ (euclidean__axioms.Cong C E C B)) as H4.
----- apply (@lemma__extension.lemma__extension B C C B H2 H3).
----- destruct H4 as [E H5].
destruct H5 as [H6 H7].
assert (* Cut *) (euclidean__axioms.Col B C E) as H8.
------ right.
right.
right.
right.
left.
exact H6.
------ assert (* Cut *) (euclidean__axioms.Col E C B) as H9.
------- assert (* Cut *) ((euclidean__axioms.Col C B E) /\ ((euclidean__axioms.Col C E B) /\ ((euclidean__axioms.Col E B C) /\ ((euclidean__axioms.Col B E C) /\ (euclidean__axioms.Col E C B))))) as H9.
-------- apply (@lemma__collinearorder.lemma__collinearorder B C E H8).
-------- destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H17.
------- assert (euclidean__defs.Per A B C) as H10 by exact H1.
assert (* Cut *) (euclidean__defs.Out B C E) as H11.
-------- apply (@lemma__ray4.lemma__ray4 B C E).
---------right.
right.
exact H6.

--------- exact H2.
-------- assert (* Cut *) (euclidean__defs.Per A B E) as H12.
--------- apply (@lemma__8__3.lemma__8__3 A B C E H10 H11).
--------- assert (* Cut *) (euclidean__defs.Per E B A) as H13.
---------- apply (@lemma__8__2.lemma__8__2 A B E H12).
---------- assert (* Cut *) (~(euclidean__defs.Per A C B)) as H14.
----------- intro H14.
assert (* Cut *) (euclidean__defs.Per B C A) as H15.
------------ apply (@lemma__8__2.lemma__8__2 A C B H14).
------------ assert (exists F, (euclidean__axioms.BetS B C F) /\ ((euclidean__axioms.Cong B C F C) /\ ((euclidean__axioms.Cong B A F A) /\ (euclidean__axioms.neq C A)))) as H16 by exact H15.
destruct H16 as [F H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
assert (* Cut *) (euclidean__axioms.Cong F C B C) as H24.
------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric F B C C H20).
------------- assert (* Cut *) (euclidean__axioms.Cong C F B C) as H25.
-------------- assert (* Cut *) ((euclidean__axioms.Cong C F C B) /\ ((euclidean__axioms.Cong C F B C) /\ (euclidean__axioms.Cong F C C B))) as H25.
--------------- apply (@lemma__congruenceflip.lemma__congruenceflip F C B C H24).
--------------- destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
exact H28.
-------------- assert (* Cut *) (euclidean__axioms.Cong C E B C) as H26.
--------------- assert (* Cut *) ((euclidean__axioms.Cong E C B C) /\ ((euclidean__axioms.Cong E C C B) /\ (euclidean__axioms.Cong C E B C))) as H26.
---------------- apply (@lemma__congruenceflip.lemma__congruenceflip C E C B H7).
---------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
exact H30.
--------------- assert (* Cut *) (euclidean__axioms.Cong B C C E) as H27.
---------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B C E C H26).
---------------- assert (* Cut *) (euclidean__axioms.Cong C F C E) as H28.
----------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive C F B C C E H25 H27).
----------------- assert (* Cut *) (F = E) as H29.
------------------ apply (@lemma__extensionunique.lemma__extensionunique B C F E H18 H6 H28).
------------------ assert (* Cut *) (euclidean__axioms.BetS E C B) as H30.
------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry B C E H6).
------------------- assert (* Cut *) (euclidean__axioms.Cong F A B A) as H31.
-------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric F B A A H22).
-------------------- assert (* Cut *) (euclidean__axioms.Cong E A B A) as H32.
--------------------- apply (@eq__ind__r euclidean__axioms.Point E (fun F0 => (euclidean__axioms.BetS B C F0) -> ((euclidean__axioms.Cong B C F0 C) -> ((euclidean__axioms.Cong B A F0 A) -> ((euclidean__axioms.Cong F0 C B C) -> ((euclidean__axioms.Cong C F0 B C) -> ((euclidean__axioms.Cong C F0 C E) -> ((euclidean__axioms.Cong F0 A B A) -> (euclidean__axioms.Cong E A B A))))))))) with (x := F).
----------------------intro H32.
intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
intro H38.
exact H38.

---------------------- exact H29.
---------------------- exact H18.
---------------------- exact H20.
---------------------- exact H22.
---------------------- exact H24.
---------------------- exact H25.
---------------------- exact H28.
---------------------- exact H31.
--------------------- assert (* Cut *) (euclidean__axioms.Cong E C B C) as H33.
---------------------- assert (* Cut *) ((euclidean__axioms.Cong E C C B) /\ ((euclidean__axioms.Cong E C B C) /\ (euclidean__axioms.Cong C E C B))) as H33.
----------------------- apply (@lemma__congruenceflip.lemma__congruenceflip C E B C H26).
----------------------- destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
exact H36.
---------------------- assert (* Cut *) (euclidean__defs.Per E C A) as H34.
----------------------- exists B.
split.
------------------------ exact H30.
------------------------ split.
------------------------- exact H33.
------------------------- split.
-------------------------- exact H32.
-------------------------- exact H23.
----------------------- assert (* Cut *) (C = B) as H35.
------------------------ apply (@lemma__droppedperpendicularunique.lemma__droppedperpendicularunique E B C A H34 H13 H9).
------------------------ apply (@H3 H35).
----------- exact H14.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype bigop fintype finfun ssralg ssrnat.
Require Import Reals.
Require Import Coquelicot.Coquelicot.
Require Import Psatz.
Require Import Bool.
Require Import network_calculus_def.
Require Import interval_bounding.
Require Import Rstruct.

Open Scope ring_scope.
Local Open Scope R_scope.

Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

Definition start' (A D : dflow) (t : nnR) :=
  Lub_Rbar (fun u => exists u' : nnR, u = u' /\ u <= t /\ A u' = D u' :> R).

Lemma start_proof (A D : dflow) (t : nnR) : 0 <= start' A D t.
Proof.
  unfold start'.
  set (E := fun _ => _).
  assert (Rbar_le 0 (Lub_Rbar E)).
  destruct (proj2_sig (ex_lub_Rbar E)) as [Hub _].
  apply Hub.
  unfold E.
  exists nnR0.
  split. now trivial.
  split. pose (Ht := nnR_pos t); now lra.
  rewrite (dflow_cond_start A).
  now rewrite (dflow_cond_start D).
  revert H. unfold Rbar_le.
  case (Lub_Rbar E); simpl; intros; first [now lra | now trivial].
Qed.

Definition start (A D : dflow) (t : nnR) :=
  mk_nnR (start' A D t) (start_proof A D t).

Lemma start'_is_finite A D t : is_finite (start' A D t).
Proof.
  unfold start'.
  set (E := fun _ => _).
  assert (Rbar_le (Lub_Rbar E) t).
  { apply (proj2 (proj2_sig (ex_lub_Rbar _))).
    now intros x Hx; destruct Hx. }
  assert (H0 : Rbar_le 0 (start' A D t)).
  { unfold start'.
    assert (Rbar_le 0 (Lub_Rbar E)).
    { apply (proj1 (proj2_sig (ex_lub_Rbar E))).
      unfold E.
      exists nnR0.
      split; [now simpl|]; split.
      { pose (Ht := nnR_pos t); lra. }
      now rewrite !dflow_cond_start. }
    revert H; unfold Rbar_le.
    now case (Lub_Rbar E); simpl; intros; [|lra|].
  }
  revert H H0.
  unfold start'.
  fold E.
  now case (Lub_Rbar E).
Qed.

Lemma ndf_start' (A D : dflow) (x y : nnR) :
  x <= y -> start' A D x <= start' A D y.
Proof.
  intro H.
  cut (Rbar_le (start' A D x) (start' A D y)).
  - now unfold Rbar_le; rewrite <- start'_is_finite; rewrite <- start'_is_finite at 1; intros.
  unfold start'.
  set (E1 := fun _ => _).
  set (E2 := fun _ => _).
  apply (is_lub_Rbar_subset E2 E1).
  - intros z [u [Hz [Hz_re Hu]]].
    exists u.
    split; [trivial | split; [lra | trivial]].
  - apply Lub_Rbar_correct.
  - apply Lub_Rbar_correct.
Qed.

Lemma start'_le_t A D t : start' A D t <= t.
Proof.
  unfold start'.
  set (E := fun _ => _).
  destruct (proj2_sig (ex_lub_Rbar E)) as [_ Hlub].
  assert (Rbar_le (Lub_Rbar E) t).
  { apply Hlub.
    intros x [u' [_ [Hx_le _]]].
    now simpl. }
  assert (HR := start'_is_finite).
  specialize (HR A D t).
  unfold start' in HR; fold E in HR.
  rewrite <- HR in H; simpl in H.
  now trivial.
Qed.

Definition nnR_minus x y (P : y <= x) :=
  mk_nnR (x - y) (Rge_le _ _ (Rge_minus _ _ (Rle_ge _ _ P))).

Lemma start_eq (A D : dflow) (t : nnR) : A (start A D t) = D (start A D t).
Proof.
  unfold start, start'.
  set (E := fun _ => _).
  assert (HA : Lub_Rbar (fun y => exists x, y = A x /\ E x) = A (start A D t) :> R).
  {
    assert (HA : Lub_Rbar (fun y => exists x, y = A x /\ E x) = A (start A D t) :> Rbar).
    apply (dflow_cond_cont_left A).
    rewrite (start'_is_finite A D t).
    exact (proj2_sig (ex_lub_Rbar E)).
    now rewrite HA. }
  assert (HD : Lub_Rbar (fun y => exists x, y = D x /\ E x) = D (start A D t) :> R).
  {
    assert (HD : Lub_Rbar (fun y => exists x, y = D x /\ E x) = D (start A D t) :> Rbar).
    apply (dflow_cond_cont_left D).
    rewrite (start'_is_finite A D t).
    exact (proj2_sig (ex_lub_Rbar E)).
    now rewrite HD. }
  apply nnR_inj.
  unfold E.
  fold (start' A D t); fold (start A D t).
  rewrite <- HA; rewrite <- HD.
  f_equal.
  apply Lub_Rbar_eqset.
  intro x.
  split;
  intro H; destruct H as [x0 [Hx0D Hx0E]]; exists x0;
  split; auto;
  destruct Hx0E as [x0' [H1 [H2 H3]]];
  assert (H1' := nnR_inj _ _ H1);
  rewrite <- H1' in H3.
  now rewrite <- H3.
  now rewrite H3.
Qed.

Ltac simpl_re := rewrite /GRing.add /GRing.zero /=.

Lemma big_sum_pred_pos_pos n (P : pred 'I_n) F :
  (forall i, P i -> 0 <= F i) -> 0 <= \sum_(i | P i) F i.
Proof.
move=> HF.
apply big_rec; [by right|]; move=> i x HP Hx.
by apply Rplus_le_le_0_compat; [apply HF|].
Qed.

Lemma big_sum_pos_eq_0 n (F : 'I_n -> R) :
  (forall i, 0 <= F i) -> \sum_i F i = 0 -> forall i, F i = 0.
Proof.
move=> H Hi i.
have [R|//] := Rle_lt_or_eq_dec _ _ (H i).
suff HH: (0 < \big[+%R/0]_j F j)%Re by move: Hi HH; simpl_re; lra.
rewrite (bigD1 i) //=.
set X := \big[_/_]_(_|_) _.
suff: (0 <= X)%Ri by simpl_re; lra.
by apply big_sum_pred_pos_pos.
Qed.

Lemma sum_eq_imp_el_eq n (S : n_server n.+1) (A D : dflow^n.+1) (x : nnR) :
  S A D -> sum_dflow A x = sum_dflow D x -> forall i, (A i) x = (D i) x.
Proof.
  intros HAD Heq i.
  simpl in Heq; unfold ndf_sum_dflow_val in Heq.
  inversion Heq as [Heq'].
  unfold ndf_sum_dflow_val_val in Heq'; simpl in Heq'.
  assert (\sum_i (A i x - D i x)%Re = 0).
  { rewrite GRing.sumrB.
    rewrite Heq'.
    unfold GRing.add, GRing.opp; simpl.
    ring. }
  cut (A i x - D i x = 0).
  - now intros; apply nnR_inj; rewrite <- Rplus_0_l; rewrite <- H0; ring.
  revert H i; apply big_sum_pos_eq_0; intro i.
  apply Rge_le, Rge_minus, Rle_ge, (n_server_cond_dflow _ _ _ _ HAD).
Qed.

Lemma after_start_is_backlog_period (S : server) (A D : dflow) (t : nnR) :
  S A D -> forall (s : nnR), start A D t < s <= t -> D s < A s.
Proof.
  intros HAD s (Hs_lt, Hs_le).
  apply Rnot_le_lt.
  intro H.
  case H.
  { intro H0.
    exact (Rlt_not_le _ _ H0 (server_cond_dflow S A D HAD s)). }
  { intro H0.
    unfold start, start' in Hs_lt. simpl in Hs_lt.
    set (E := fun _ => _) in Hs_lt.
    destruct (Lub_Rbar_correct E) as [Hub Hlub].
    refine (Rbar_le_not_lt _ _ (Hub s _) _).
    now exists s.
    assert (H1 := start'_is_finite A D t).
    revert H1.
    unfold start'. fold E.
    now revert Hs_lt; case (Lub_Rbar E).
   }
Qed.

Lemma strict_imp_simpl (S : server) (A D : dflow) (beta : nnR -> nnRbar) :
  S A D -> is_strict_min_service_curve S beta -> is_min_service_curve S beta.
Proof.
  intros HAD Hbeta.
  unfold is_min_service_curve.
  unfold is_strict_min_service_curve in Hbeta.
  intros A0 D0 HA0D0 t.
  specialize(Hbeta A0 D0 HA0D0).
  unfold min_conv, min_conv_val; simpl.
  apply Rbar_le_trans with (y := (Rbar_plus (A0 (start A0 D0 t)) (beta (nnR_minus t (start A0 D0 t) (start'_le_t A0 D0 t))))).
  {
    unfold nnR_plus, nnR_minus.
    simpl.
    set (E := fun _ => _).
    destruct (proj2_sig (Rbar_ex_glb E)) as [Hlb _].
    unfold is_lb_Rbar in Hlb.
    unfold is_ub_Rbar in Hlb.
    apply Hlb.
    exists (start A0 D0 t), (nnR_minus t (start A0 D0 t) (start'_le_t A0 D0 t));
    split; first[ now simpl; f_equal; ring | now trivial].
  }
  rewrite start_eq.
  specialize (Hbeta (start A0 D0 t) (nnR_minus t (start A0 D0 t) (start'_le_t A0 D0 t))).
  simpl in Hbeta.
  replace (_ + (_ - _)) with (nnR_val t) in Hbeta by ring.
  specialize (Hbeta (after_start_is_backlog_period S A0 D0 t HA0D0)).
  replace (nnR_plus _ _) with t in Hbeta.
  { revert Hbeta.
    now case (D0 t), (D0 (start A0 D0 t)), nnRbar_val; simpl; [lra| |]. }
  apply nnR_inj; simpl; ring.
Qed.

Lemma sum_equiv_Rbar_sum_on_R I r (P : pred I) (E1 : I -> R) :
  \sum_(i <- r | P i) E1 i
  = \big[Rbar_plus/Finite 0]_(i <- r | P i) E1 i :> Rbar.
Proof. now apply big_morph. Qed.

Theorem blind_multiplexing n (S : n_server n.+1)
        (alpha : (nnR -> nnRbar)^n.+1) (beta : nnR -> nnRbar)
        i :
  (forall A D, S A D -> forall j, is_upper_interval_bound (A j) (alpha j)) ->
  is_strict_min_service_curve (aggregate_server S) beta ->
  is_min_service_curve
    (residual_server S i)
    (non_decreasing_closure
       (fun x =>
         Rbar_to_nnRbar
           (Rbar_minus
              (beta x)
              (\big[Rbar_plus/Finite 0]_(j | j != i) (alpha j x))))).
Proof.
  intros HA Hbeta Ai Di HAiDi t.
  destruct HAiDi as [A [D [HAD [HAi HDi]]]].
  specialize (HA A D HAD).
  unfold min_conv, min_conv_val.
  set (E := fun _ => _).
  destruct (proj2_sig (Rbar_ex_glb E)) as [Hlb _].
  unfold Rbar_is_lower_bound in Hlb.
  simpl.
  pose (start_sum := start (sum_dflow A) (sum_dflow D) t).
  pose (v := (nnR_minus t start_sum (start'_le_t (sum_dflow A) (sum_dflow D) t))).
  pose (El := Rbar_plus
                (Ai start_sum)
                (non_decreasing_closure
                   (fun v => (Rbar_to_nnRbar
                   (Rbar_minus
                      (beta v)
                      (\big[Rbar_plus/Finite 0]_(j | j != i) alpha j v)))) v)).
  assert (HEl : E El).
  { now exists start_sum, v; split; [simpl; f_equal; ring|]. }
  apply (Rbar_le_trans _ _ _ (Hlb El HEl)).
  unfold El.
  rewrite <- (HAi start_sum).
  rewrite (sum_eq_imp_el_eq _ _ _ _ _ HAD (start_eq _ _ _)).
  rewrite <- (HDi t).
  cut (Rbar_le (non_decreasing_closure
                 (fun v => Rbar_to_nnRbar
                 (Rbar_minus (beta v)
                 (\big[Rbar_plus/Finite 0]_(j | j != i) alpha j v))) v)
               (Rbar_minus (D i t) (D i start_sum))).
  { case non_decreasing_closure; fold start_sum; simpl; intro nv.
    case nv; intro nnRbar_val; case nnRbar_val; unfold Rbar_le, Rbar_plus; simpl; intros; simpl; lra. }
  simpl. unfold non_decreasing_closure_val_val; simpl.
  set (E' := fun _ => _).
  destruct (proj2_sig (Rbar_ex_lub E')) as [_ Hlub].
  apply Hlub.
  unfold Rbar_is_upper_bound.
  intros W [w [Hw HW]].
  rewrite HW; clear W HW.
  pose (u := nnR_plus w start_sum).
  assert (Hu_le : start_sum <= u).
  - now unfold u; assert(Hw_pos := Rle_bool_Rle _ _ (nnR_prop w)); simpl; lra.
  assert (Hwu : w = nnR_minus u start_sum Hu_le).
  - now apply nnR_inj; unfold u; simpl; ring.
  rewrite Hwu.
  apply Rbar_le_trans with (y := (D i u - D i start_sum));
  [| apply Rplus_le_compat; [apply (ndf_nnR_nnR_prop (D i)); unfold u; simpl; lra | now lra]].
  (* PR : ça vaudrait peut être le coup de sortir ce assert dans un lemme *)
  assert (Hnd : forall x y, Rbar_le x y -> Rbar_le (Rbar_to_nnRbar x) (Rbar_to_nnRbar y)).
  { intros x y Hxy; simpl; unfold nn_part.
    case Rbar_le_dec, Rbar_le_dec; simpl; [now simpl| |now simpl|lra].
    now exfalso; apply n0, (Rbar_le_trans _ _ _ r).
  }
  apply Rbar_le_trans
  with (y := (Rbar_to_nnRbar (Rbar_minus (beta (nnR_minus u start_sum Hu_le))
                                         (\big[Rbar_plus/Finite 0]_(j | j != i)
                                           ((A j u) - (A j start_sum))%Re)))).
  { apply Hnd.
    (* PR : un lemme Rbar_plus_le_compat_l ? *)
    apply Rbar_plus_le_compat; [now apply Rbar_le_refl|]; apply Rbar_opp_le.
    apply Rbar_leq_sum.
    intros i0 Hi0.
    specialize (HA i0 start_sum w).
    rewrite <- Hwu.
    assert (H : nnR_plus start_sum w = u).
    { now apply nnR_inj; unfold u; simpl; ring. }
    rewrite <- H.
    now apply HA.
  }
  apply Rbar_le_trans
  with (y := (Rbar_to_nnRbar (Rbar_minus (beta w)
                                         (\big[Rbar_plus/Finite 0]_(j | j != i)
                                           ((D j u) - (A j start_sum))%Re)))).
  { apply Hnd.
    rewrite <- Hwu.
    apply Rbar_plus_le_compat; [now apply Rbar_le_refl|]; apply Rbar_opp_le.
    apply Rbar_leq_sum.
    intros i0 Hi0.
    apply Rplus_le_compat; [|now right].
    apply (n_server_cond_dflow _ _ _ _ HAD).
  }
  assert (H : (Rbar_minus (D i u) (D i start_sum) =
               (Rbar_minus (\big[Rbar_plus/Finite 0]_j
                             ((D j u) - (D j start_sum)))
                           (\big[Rbar_plus/Finite 0]_(j | j != i)
                             ((D j u) - (D j start_sum)))))).
  {
    rewrite <- !sum_equiv_Rbar_sum_on_R; simpl.
    rewrite (bigD1 i); [|now simpl].
    repeat (unfold GRing.add; simpl); f_equal.
    change ((Finite.eqType (ordinal_finType n))) with ((ordinal_eqType n)).
    ring.
  }
  (* PR : éviter de laisser Coq choisir les noms des hypothèses (H, H0,...),
   * ça rend les preuves beaucoup moins robustes *)
  assert (H0 : (Rbar_minus (D i u) (D i start_sum))
               = Rbar_to_nnRbar (Rbar_minus (D i u) (D i start_sum))).
  {
    assert (H0 : Rbar_le 0 (Rbar_minus (D i u) (D i start_sum))).
    { rewrite <- (Rbar_minus_eq_0 (D i u)).
      apply Rbar_plus_le_compat; [now apply (ndf_nnR_nnR_prop (D i)); simpl; lra|].
      simpl; apply Ropp_ge_le_contravar; apply Rle_ge.
      apply (ndf_nnR_nnR_prop (D i)), Hu_le. }
    now symmetry; apply ifT; case Rbar_le_dec.
  }
  simpl in H0; rewrite H0.
  apply Hnd.
  assert (H1 : (\big[Rbar_plus/Finite 0]_(j | j != i) (D j u - A j start_sum))
               = (\big[Rbar_plus/Finite 0]_(j | j != i) (D j u - D j start_sum))).
  { apply eq_bigr; intros j Hj; do 3 f_equal.
    now rewrite (sum_eq_imp_el_eq _ _ _ _ _ HAD (start_eq _ _ t)). }
  rewrite H1.
  simpl in H; rewrite H.
  apply Rbar_plus_le_compat; [|now apply Rbar_le_refl].
  assert (HAsDs : (aggregate_server S) (sum_dflow A) (sum_dflow D)).
  { now simpl; unfold aggregate_server_val; exists A, D. }
  unfold u.
  assert (Hbacklog := after_start_is_backlog_period
                        (aggregate_server S) (sum_dflow A) (sum_dflow D)
                        (nnR_plus w start_sum) HAsDs).
  rewrite <- sum_equiv_Rbar_sum_on_R.
  rewrite GRing.sumrB.
  unfold GRing.add, GRing.opp; simpl.
  assert (Hcomm : nnR_plus w start_sum = nnR_plus start_sum w).
  - now apply nnR_inj; simpl; ring.
  rewrite Hcomm.
  apply (Hbeta _ _ HAsDs _ _).
  intros s [Hs_lt Hs_le].
  assert (Hs_weak : start (sum_dflow A) (sum_dflow D) (nnR_plus w start_sum) < s
                 <= nnR_plus w start_sum).
  split.
  - apply Rle_lt_trans with (r2 := start_sum).
    * apply ndf_start'; simpl; lra.
    * now trivial.
  - now simpl; simpl in Hs_le; lra.
  now apply (Hbacklog s Hs_weak).
Qed.


From mathcomp Require Import ssreflect.
From Category.Base Require Import Logic Category Functor NatTran.
From Category.Instances Require Import Univ.FunctorComp Comma.CommaCat.

Set Universe Polymorphism.

Definition HomCat (C : Category) : Category := CommaCat (IdFunctor C) (IdFunctor C).

Definition ToHomCat {C : Category} {X Y : Obj C} (f : Hom X Y) : Obj (HomCat C) :=
  existT _ (pair X Y) f.

Definition Hom_equiv {C : Category} {X1 Y1 X2 Y2 : Obj C} (f : Hom X1 Y1) (g : Hom X2 Y2) := ToHomCat f ~~~ ToHomCat g in (HomCat C).


Require Import Verse.Word.
Require Import Verse.NFacts.
Require Import Verse.Types.Internal.
Require Import Verse.Types.
Require Import Verse.Language.Operators.
Require Import Verse.Error.
Require Import Verse.Semantics.

Require Import Arith.
Require Import NArith.

Module NWord <: WORD_SEMANTICS.

  Definition wordDenote (n : nat) : Type :=
    N.

End NWord.

Module NConst <: CONST_SEMANTICS NWord.

  Definition constWordDenote n (w : constant (word n)) : NWord.wordDenote n :=
    Nibble.toN w.

End NConst.

Module NOps <: OP_SEMANTICS (NWord).

  Definition OpError := True.

  Definition wordOpDenote ar n (o : op ar) : arityDenote ar (NWord.wordDenote n) :=
    let split2 n0 := (n0 / 2 ^ N.of_nat n, n0 mod (2 ^ N.of_nat n))%N in
    let merge2 n0 n1 := (2 ^ N.of_nat n * n0 + n1)%N in
    match o in op ar0 return arityDenote ar0 (NWord.wordDenote n) with
    | plus => fun a b => N.add a b
    | minus => fun a b => N.sub a b
    | mul => fun a b => N.mul a b
    | quot => fun a b => N.div a b
    | rem => fun a b => N.modulo a b
    | bitOr => fun a b => N.lor a b
    | bitAnd => fun a b => N.land a b
    | bitXor => fun a b => N.lxor a b
    | bitComp => fun a => Bv2N n (Bvector.Bneg n (N2Bv_gen n a) )
    | rotL m => fun b => Bv2N n (BOps.BRotL m (N2Bv_gen n b))
    | rotR m => fun b => Bv2N n (BOps.BRotR m (N2Bv_gen n b))
    | shiftL m => fun b => (N.shiftl_nat b m mod two_power_nat_N (8 * 2 ^ n))%N
    | shiftR m => fun b => N.shiftr_nat b m
    | nop => fun b => b
    end.

End NOps.

Module NSemantics := Semantics NWord NConst NOps.
Module NSemanticsTactics := SemanticTactics NWord NConst NOps.


Require Import primRec.
Require Import cPair.
Require Import Arith.
Require Import code.
Require Import folProp.
Require Import folProof.
Require Import Languages.
Require LNN.
Require LNT.

Definition natToTermLNN := LNN.natToTerm.

Definition natToTermLNT := LNT.natToTerm.

Definition codeNatToTerm : nat -> nat :=
  nat_rec (fun _ => nat) (cPair 4 0)
    (fun _ rec : nat => cPair 3 (S (cPair rec 0))).

Lemma codeNatToTermCorrectLNN :
 forall n : nat,
 codeNatToTerm n = codeTerm LNN codeLNTFunction (natToTermLNN n).
Proof.
intro.
induction n as [| n Hrecn].
reflexivity.
simpl in |- *.
rewrite Hrecn.
reflexivity.
Qed.

Lemma codeNatToTermCorrectLNT :
 forall n : nat,
 codeNatToTerm n = codeTerm LNT codeLNTFunction (natToTermLNT n).
Proof.
intro.
induction n as [| n Hrecn].
reflexivity.
simpl in |- *.
rewrite Hrecn.
reflexivity.
Qed.

Lemma codeNatToTermIsPR : isPR 1 codeNatToTerm.
Proof.
unfold codeNatToTerm in |- *.
apply
 indIsPR
  with (f := fun _ rec : nat => cPair 3 (S (cPair rec 0))) (g := cPair 4 0).
apply filter01IsPR with (g := fun rec : nat => cPair 3 (S (cPair rec 0))).
apply
 compose1_2IsPR
  with (f := fun _ : nat => 3) (f' := fun rec : nat => S (cPair rec 0)).
apply const1_NIsPR.
apply compose1_1IsPR with (f := fun rec : nat => cPair rec 0).
apply
 compose1_2IsPR with (f := fun rec : nat => rec) (f' := fun _ : nat => 0).
apply idIsPR.
apply const1_NIsPR.
apply cPairIsPR.
apply succIsPR.
apply cPairIsPR.
Qed.


Require Import Coq.Strings.String.
Require Import List.
Import ListNotations.

Inductive nt: Type :=
  NT : string -> nt.

Inductive t: Type :=
  T : string -> t.

Definition sf: Type := list (sum nt t).
Definition rule: Type := (nt * sf).

Record cfg: Type:= {
  start_symbol: nt;
  rules: (list rule);
}.

Definition terminal_lift (s: t): nt + t := inr s.

Inductive derives (g: cfg): sf -> sf -> Prop :=
| derives_refl: forall (s: sf),
                derives g s s
| derives_step: forall (s1 s2 s3: sf) (left: nt) (right: sf),
                derives g s1 (s2 ++ inl left :: s3) ->
                In (left,right) (rules g) ->
                derives g s1 (s2 ++ right ++ s3).

Theorem derives_trans (g: cfg) (s1 s2 s3: sf):
derives g s1 s2 ->
derives g s2 s3 ->
derives g s1 s3.
Proof.
intros H1 H2.
induction H2.
- exact H1.
- apply derives_step with (left:=left).
  + apply IHderives.
    exact H1.
  + exact H.
Qed.

Theorem derives_left (g: cfg) (left: nt) (right: sf) (s1 s2 s3: sf):
  derives g (s1 ++ right ++ s2) s3 ->
  In (left,right) (rules g) ->
  derives g (s1 ++ inl left :: s2) s3.
Proof.
  intros.
  apply derives_trans with (s2 := s1 ++ right ++ s2).
  - apply derives_step with (left := left).
    + apply derives_refl.
    + assumption.
  - assumption.
Qed.

(* Theorem derives_left2 (g: cfg) (left: nt) (right: sf) (s1 s2 s3: sf):
  derives g (s1 ++ inl left :: s2) s3 ->
  In (left,right) (rules g) ->
  (forall l' r', In (l',r') (rules g) -> left = l' -> r' = right) -> (* exists! *)
  derives g (s1 ++ right ++ s2) s3.
Proof.
  intros.
  apply derives_trans with (s1 := s1 ++ inl left :: s2) in H.
  apply derives_left with (s1 := s1) (right := inl left) in H.
Admitted. *)

Definition generates (g: cfg) (s: list (nt + t)): Prop:=
  derives g [inl (start_symbol g)] s.

Definition produces (g: cfg) (s: list t): Prop:=
  generates g (map terminal_lift s).

Definition g_equiv (g1: cfg) (g2: cfg): Prop:=
  forall s: list t, produces g1 s <-> produces g2 s.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

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

(***********************************************************************
      Root.v

      Proof that a polynomial has at most n roots
************************************************************************)
Require Import ZArith.
Require Import List.
Require Import UList.
Require Import Tactic.
Require Import Permutation.

Open Scope Z_scope.

Section Root.

Variable A: Set.
Variable P: A -> Prop.
Variable plus mult: A -> A -> A.
Variable op: A -> A.
Variable zero one: A.

Let pol := list A.

Definition toA z :=
match z with
  Z0  => zero
| Zpos p => iter_pos  p _ (plus one) zero
| Zneg p => op (iter_pos p _ (plus one) zero)
end.

Fixpoint eval (p: pol) (x: A) {struct p} : A :=
match p with
  nil => zero
| a::p1 => plus a (mult x (eval p1 x))
end.

Fixpoint div (p: pol) (x: A) {struct p} : pol * A :=
match p with
  nil => (nil, zero)
| a::nil => (nil, a)
| a::p1 =>
                     (snd (div p1 x)::fst (div p1 x),
                     (plus a (mult  x (snd (div p1 x)))))
end.

Hypothesis Pzero: P zero.
Hypothesis Pplus: forall x y, P x -> P y -> P (plus x y).
Hypothesis Pmult: forall x y, P x -> P y -> P (mult x y).
Hypothesis Pop: forall x, P x -> P (op x).
Hypothesis plus_zero: forall a, P a -> plus zero a = a.
Hypothesis plus_comm: forall a b, P a -> P b -> plus a b = plus b a.
Hypothesis plus_assoc: forall a b c, P a -> P b -> P c -> plus a (plus b c) = plus (plus a b) c.
Hypothesis mult_zero: forall a, P a -> mult zero a = zero.
Hypothesis mult_comm: forall a b, P a -> P b -> mult a b = mult b a.
Hypothesis mult_assoc: forall a b c, P a -> P b -> P c -> mult a (mult b c) = mult (mult a b) c.
Hypothesis mult_plus_distr: forall a b c, P a -> P b -> P c -> mult a (plus b c) = plus (mult a b) (mult a c).
Hypothesis plus_op_zero: forall a, P a -> plus a (op a) = zero.
Hypothesis mult_integral: forall a b, P a -> P b -> mult a b = zero -> a = zero \/ b = zero.
(* Not necessary in Set just handy *)
Hypothesis A_dec: forall a b: A, {a = b} + {a <> b}.

Theorem eval_P: forall p a, P a -> (forall i, In i p -> P i) -> P (eval p a).
intros p a Pa; elim p; simpl; auto with datatypes.
intros a1 l1 Rec H; apply Pplus; auto.
Qed.

Hint Resolve eval_P.

Theorem div_P: forall p a, P a -> (forall i, In i p -> P i) -> (forall i, In i (fst (div p a)) -> P i) /\ P (snd (div p a)).
intros p a Pa; elim p; auto with datatypes.
intros a1 l1; case l1.
simpl; intuition.
intros a2 p2 Rec Hi; split.
case Rec; auto with datatypes.
intros H H1 i.
replace (In i (fst (div (a1 :: a2 :: p2) a))) with
 (snd (div (a2::p2) a) = i \/  In i (fst (div (a2::p2) a))); auto.
intros [Hi1 | Hi1]; auto.
rewrite <- Hi1; auto.
change ( P (plus a1 (mult  a (snd (div (a2::p2) a))))); auto with datatypes.
apply Pplus; auto with datatypes.
apply Pmult; auto with datatypes.
case Rec; auto with datatypes.
Qed.

Theorem div_correct:
  forall p x y, P x -> P y -> (forall i, In i p -> P i) -> eval p y = plus (mult (eval (fst (div p x)) y) (plus y (op x))) (snd (div p x)).
intros p x y; elim p; simpl.
intros; rewrite mult_zero; try rewrite plus_zero; auto.
intros a l; case l; simpl; auto.
intros _ px py pa; rewrite (fun x => mult_comm x zero); repeat rewrite mult_zero; try apply plus_comm; auto.
intros a1 l1.
generalize (div_P (a1::l1) x); simpl.
match goal with |-  context[fst ?A]   => case A end; simpl.
intros q r Hd Rec px py pi.
assert (pr: P r).
case Hd; auto.
assert (pa1: P a1).
case Hd; auto.
assert (pey: P (eval q y)).
apply eval_P; auto.
case Hd; auto.
rewrite Rec; auto with datatypes.
rewrite (fun x y => plus_comm x (plus a y)); try rewrite <- plus_assoc; auto.
apply f_equal2 with (f := plus); auto.
repeat rewrite mult_plus_distr; auto.
repeat (rewrite (fun x y => (mult_comm (plus x y))) || rewrite mult_plus_distr); auto.
rewrite (fun x => (plus_comm  x (mult y r))); auto.
repeat rewrite  plus_assoc; try apply f_equal2 with (f := plus); auto.
2: repeat rewrite mult_assoc; try rewrite (fun y => mult_comm y (op x));
    repeat rewrite mult_assoc; auto.
rewrite (fun z => (plus_comm  z (mult (op x) r))); auto.
repeat rewrite  plus_assoc; try apply f_equal2 with (f := plus); auto.
2: apply f_equal2 with (f := mult); auto.
repeat rewrite (fun x => mult_comm x r); try rewrite <- mult_plus_distr; auto.
rewrite (plus_comm (op x)); try rewrite plus_op_zero; auto.
rewrite (fun x => mult_comm x zero); try rewrite mult_zero; try rewrite plus_zero; auto.
Qed.

Theorem div_correct_factor:
  forall p a, (forall i, In i p -> P i) -> P a ->
       eval p a = zero -> forall x,  P x -> eval p x =  (mult (eval (fst (div p a)) x) (plus x (op a))).
intros p a Hp Ha H x px.
case (div_P p a); auto; intros Hd1 Hd2.
rewrite (div_correct p a x); auto.
generalize (div_correct p a a).
rewrite plus_op_zero; try rewrite (fun x => mult_comm x zero); try rewrite mult_zero; try rewrite plus_zero; try rewrite H; auto.
intros H1; rewrite <- H1; auto.
rewrite (fun x => plus_comm x zero); auto.
Qed.

Theorem length_decrease: forall p x, p <> nil -> (length (fst (div p x)) < length p)%nat.
intros p x; elim p; simpl; auto.
intros H1; case H1; auto.
intros a l; case l; simpl; auto.
intros a1 l1.
match goal with |-  context[fst ?A]   => case A end; simpl; auto with zarith.
intros p1 _ H H1.
apply lt_n_S; apply H; intros; discriminate.
Qed.

Theorem root_max:
forall p l, ulist l -> (forall i, In i p -> P i) -> (forall i, In i l -> P i) ->
  (forall x, In x l -> eval p x = zero) -> (length p <= length l)%nat -> forall x, P x -> eval p x = zero.
intros p l; generalize p; elim l; clear l p; simpl; auto.
intros p; case p; simpl; auto.
intros a p1 _ _ _ _ H; contradict H; auto with arith.
intros a p1 Rec p; case p.
simpl; auto.
intros a1 p2 H H1 H2 H3 H4 x px.
assert (Hu: eval (a1 :: p2) a = zero); auto with datatypes.
rewrite (div_correct_factor (a1 :: p2) a); auto with datatypes.
match goal with |- mult ?X _ = _ => replace X with zero end; try apply mult_zero; auto.
apply sym_equal; apply Rec; auto with datatypes.
apply ulist_inv with (1 := H).
intros i Hi; case (div_P (a1 :: p2) a); auto.
intros x1 H5; case (mult_integral (eval (fst (div (a1 :: p2) a)) x1) (plus x1 (op a))); auto.
apply eval_P; auto.
intros i Hi; case (div_P (a1 :: p2) a); auto.
rewrite <- div_correct_factor; auto.
intros H6; case (ulist_app_inv _ (a::nil) p1 x1); simpl; auto.
left.
apply trans_equal with (plus zero x1); auto.
rewrite <- (plus_op_zero a); try rewrite <- plus_assoc; auto.
rewrite (fun x => plus_comm (op x)); try rewrite H6; try rewrite plus_comm; auto.
apply sym_equal; apply plus_zero; auto.
apply lt_n_Sm_le;apply lt_le_trans with (length (a1 :: p2)); auto with zarith.
apply length_decrease; auto with datatypes.
Qed.

Theorem root_max_is_zero:
forall p l, ulist l -> (forall i, In i p -> P i) -> (forall i, In i l -> P i) ->
  (forall x, In x l -> eval p x = zero) -> (length p <= length l)%nat -> forall x, (In x p) -> x = zero.
intros p l; generalize p; elim l; clear l p; simpl; auto.
intros p; case p; simpl; auto.
intros _ _ _  _ _ x H; case H.
intros a p1 _ _ _ _ H; contradict H; auto with arith.
intros a p1 Rec p; case p.
simpl; auto.
intros _ _ _ _ _ x H; case H.
simpl; intros a1 p2 H H1 H2 H3 H4 x H5.
assert (Ha1: a1 = zero).
assert (Hu: (eval (a1::p2) zero = zero)).
apply root_max with (l := a :: p1); auto.
rewrite <- Hu; simpl; rewrite mult_zero; try rewrite plus_comm; sauto.
case H5; clear H5; intros H5; subst; auto.
apply Rec with p2; auto with arith.
apply ulist_inv with (1 := H).
intros x1 Hx1.
case (In_dec A_dec zero p1); intros Hz.
case (in_permutation_ex _ zero p1); auto; intros p3 Hp3.
apply root_max with (l := a::p3); auto.
apply ulist_inv with zero.
apply ulist_perm with (a::p1); auto.
apply permutation_trans with (a:: (zero:: p3)); auto.
apply permutation_skip; auto.
apply permutation_sym; auto.
simpl; intros x2 [Hx2 | Hx2]; subst; auto.
apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes.
simpl; intros x2 [Hx2 | Hx2]; subst.
case (mult_integral x2 (eval p2 x2)); auto.
rewrite <- H3 with x2; sauto.
rewrite plus_zero; auto.
intros H6; case (ulist_app_inv _ (x2::nil) p1 x2) ; auto with datatypes.
rewrite H6; apply permutation_in with (1 := Hp3); auto with datatypes.
case (mult_integral x2 (eval p2 x2)); auto.
apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes.
apply eval_P; auto.
apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes.
rewrite <- H3 with x2; sauto; try right.
apply sym_equal; apply plus_zero; auto.
apply Pmult; auto.
apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes.
apply eval_P; auto.
apply H2; right; apply permutation_in with (1 := Hp3); auto with datatypes.
apply permutation_in with (1 := Hp3); auto with datatypes.
intros H6; case (ulist_app_inv _ (zero::nil) p3 x2) ; auto with datatypes.
simpl; apply ulist_perm with (1:= (permutation_sym _ _ _ Hp3)).
apply ulist_inv with (1 := H).
rewrite H6; auto with datatypes.
replace (length (a :: p3))  with (length (zero::p3)); auto.
rewrite permutation_length with (1 := Hp3); auto with arith.
case (mult_integral x1 (eval p2 x1)); auto.
rewrite <- H3 with x1; sauto; try right.
apply sym_equal; apply plus_zero; auto.
intros HH; case Hz; rewrite <- HH; auto.
Qed.

End Root.