Require Export ho_proof_gen.

Set Implicit Arguments.

Section step_one.

Variables (cfg : Type) (cstep : cfg -> cfg -> Prop).
Definition Spec : Type := cfg -> (cfg -> Prop) -> Prop.

(* Soundness *)
CoInductive reaches (k : cfg) (P : cfg -> Prop) : Prop :=
  (* reaches : Spec, but defining k and P as parameters
     gives a cleaner definition and induction principle. *)
| rdone : P k -> reaches k P
| rstep : forall k', cstep k k' -> reaches k' P -> reaches k P.

Definition sound Rules : Prop := subspec Rules reaches.

Inductive step (X : Spec) (k : cfg) (P : cfg -> Prop) : Prop :=
  (* step : Spec -> Spec *)
| sdone : P k -> step X k P
| sstep : forall k', cstep k k' -> X k' P -> step X k P.

Lemma step_mono : mono step.
Proof. destruct 2;econstructor(solve[eauto using step]). Qed.

Lemma reaches_stable : subspec reaches (step reaches).
Proof. destruct 1;econstructor(eassumption). Qed.

CoFixpoint stable_sound Rules (Hstable : subspec Rules (step Rules)) : sound Rules :=
  fun x P H =>
  match Hstable _ _ H with
    | sdone pf => rdone _ _ pf
    | sstep k' Hstep H' =>
        rstep Hstep (stable_sound Hstable _ _ H')
  end.

Lemma proof_by_t : forall (Rules : Spec), subspec Rules (step (t step Rules)) -> sound Rules.
  intros. apply t_ext in H. apply stable_sound in H. revert H.
  unfold sound, subspec. firstorder using t_id. apply step_mono.
Qed.

Definition trans (X:Spec) : Spec := fun k P => exists Q, X k Q /\ (forall k', Q k' -> X k' P).

Lemma mono_trans : mono trans.
Proof.
  destruct 2. inversion H0. econstructor; split. apply H. eassumption.
  intros. apply H. apply H2. trivial.
Qed.

Lemma trans_ok_rule : forall X, subspec (trans X) (t step X).
  apply rule_by_T. apply step_mono. apply mono_trans.
  unfold subspec. intros. destruct H as [Q [HQ H]].
  destruct HQ. specialize (H _ H0). revert H. apply step_mono. apply Tf_id.
  eapply sstep;eauto. intros. apply Tf_idem. apply step_mono.
  firstorder. apply T_id.
  exists Q. split. eapply Tf_id;apply H1;assumption. intros.
  specialize (H k'0 H2). apply Tf_base. apply step_mono. assumption.
Qed.

Lemma use_trans : forall A, subspec (trans (t step A)) (t step A).
apply t_rule. firstorder. apply step_mono. apply trans_ok_rule.
Qed.

Lemma tstep: forall F, mono F -> forall A x P,
    forall x', cstep x x' -> T step F A x' P -> T step F A x P.
Proof.
  intros. apply use_step. apply step_mono. assumption. eapply sstep;eassumption.
Qed.

Lemma tdone: forall F, mono F -> forall A x (P:cfg->Prop), P x -> T step F A x P.
Proof.
  intros. apply use_step. apply step_mono. assumption. eapply sdone;eassumption.
Qed.

Lemma ttrans: forall F, mono F -> forall A x Q P,
    T step F A x Q -> (forall y, Q y -> T step F A y P) -> T step F A x P.
Proof.
  intros. apply Tf_idem. apply step_mono. assumption. apply Tf_t. assumption.
  apply trans_ok_rule. unfold trans. exists Q.
  split;assumption.
Qed.

(* X <= step(t X) ==> X <= gfp step *)
(* X <= Step (T X) *)
(* X (step A) <= step ((T X) A) ==> X <= t
   ==> X reaches <= reaches, other stuff *)

(* t_|_ = gfp step ==> t (gfp step) = t (t _|_) = t bot = gfp step *)

(* F : higher order spec  *)
(* F(A) <= step((T F) A)  *)
(* gfp F <= reaches *)
Lemma ok : forall F, mono F ->
    (forall A, subspec (F A) (step (T step F A))) ->
    (forall X, subspec X (F X) -> subspec X reaches)
    (* == subspec (gfp F) reaches *).
  intros.
  assert (forall A, subspec (F A) (t step A)).
  intros. apply rule_by_T. apply step_mono. apply H.
  unfold subspec;intros. apply H0 in H2. revert H2. apply step_mono.
  unfold subspec;intros. apply Tf_idem. apply step_mono. assumption.
  revert H2. apply T_mono. assumption. apply Tf_base. apply step_mono.
  apply proof_by_t. intro;intros.
  apply H1 in H3. apply H0 in H3.
  revert H3. apply step_mono. apply T_rule_f. apply step_mono. assumption. assumption.
Qed.

End step_one.


Require Import Basics.
Require Import Paths.
Require Import HIT.
Require Import Polygraphs.
Require Import PolyMorphs.

Definition EmptyA (n : nat) (T : Type) : Aug T n := mkAug False (fun x => False_rect _ x.1).

Definition Empty {n : nat} (p : Pol n) : Pol (S n) :=  Ext p (EmptyA (S n) (Free p)).

Definition FreeEmptyA (n : nat) (T : Type) : T -> FreeA (EmptyA n T) := inl.

Definition FreeEmpty {n :nat} (p : Pol n) : Free p -> Free (Empty p) := FreeEmptyA (S n) (Free p).

Definition EmptyMA (n : nat) (T : Type) (aug : Aug T n) : MAug (fun x => x) (EmptyA n T) aug.
Proof.
  simpl. unshelve econstructor.
  - exact (False_rect _).
  - simpl. intro. contradiction.
Defined.

Lemma EmptyExtensionInitial {n : nat} {p : Pol n} (aug : Aug (Free p) (S n)) : MPol (Empty p) (Ext p aug).
Proof.
  unfold Empty.
  unshelve econstructor.
  - exact (fstd IdAndFreeM p).
  - simpl. change (MAug (FreeM (fstd IdAndFreeM p)) (EmptyA (S n) (Free p)) aug).
    simple refine (eq_rect (fun W => MAug W (EmptyA (S n) (Free p)) aug) _ _).
    + exact (fun x => x).
    + exact (EmptyMA _ _ _).
    + exact ((sndd IdAndFreeM p) ^).
Defined.

Definition injectA {n : nat} {F : Type} (aug : Aug F n) : F -> FreeA aug := compose (FreeMA (EmptyMA n F aug)) (FreeEmptyA n F).

Definition injectPol {n :nat} (p : Pol n) (aug : Aug (Free p) (S n)) : Free p -> Free (Ext p aug) := injectA aug.

Definition UnitA  {n : nat} {F T : Type}  (aug : Aug F n) (f : FreeA aug -> T) :
  aug - (injectA aug) -- (ForgetA f n).
Proof.
  unshelve econstructor.
  - intro e. simple refine (mkPullB _ _ _).
    + intro b. apply f. simpl. simple refine (inr _). exact (e, b).
    + intro. simple refine (inl _). exact (d aug (e, X)).
    + apply funext. intro. unfold nFaces. unfold compose. exact (f_equal f (incoh (e, x))^).
  - simpl. intros. reflexivity.
Defined.

Definition TriangleA  {n : nat} {F T : Type}  (aug : Aug F n) (f : FreeA aug -> T) :
  compose (CounitA n f) (FreeMA (UnitA aug f)) = f.
Proof.
  apply funext. simple refine (eqMorphPushout _ _ _).
  - reflexivity.
  - intro b2. unfold compose. simpl. destruct b2. reflexivity.
  - intros [a a']. simpl.
    simple refine (concat_1p _ @ _).
    match goal with
    | |- _ = f_equal (compose ?f ?g) ?p => simple refine (_ @ (ap_compose g f p)^)
    end.
    unfold compose.
    match goal with
    | |- _ = f_equal ?f _ => simple refine (_ @ f_equal (@f_equal _ _ f _ _) Pushout_rect_compute_coh^)
    end.
    simpl.
    rewrite concat_1p.
    unfold CounitA.
    simple refine (_ @ Pushout_rect_compute_coh^). simpl.
    simple refine (_ @ (concat_ap_V _ _)^).
    simple refine (_ @ (f_equal (fun W => W ^) (funextcompute _ a')^)). simpl.
    match goal with
    | |- _ = (f_equal f ?p ^)^ =>
      simple refine (_ @ f_equal (fun W => W^ ) (concat_ap_V f p)^);
        exact ((concat_VV _)^)
    end.
Defined.

(** The previous two lemmas seem like the correct notions of units and triangle identity for augmentations. However, it turns out that the proof of polygraphs requires the following two more complicated versions **)

Definition UnitBisA {n : nat} {F : Type} (aug : Aug F (S n)) (f : F -> (Free (Forget (FreeA aug) n)))
           (H : compose (Counit (FreeA aug) n) f = injectA aug):
  aug - f -- (ForgetA (Counit (FreeA aug) n) (S n)).
Proof.
  unshelve econstructor.
  -  intro e. simpl. simple refine (mkPullB _ _ _).
     + intro x. exact (inr (e, x)).
     + intro x. simpl.
       apply f. exact (d aug (e, x)).
     + unfold nFaces. unfold compose. apply funext. intro x.
       simple refine (_ @ (f_equal (fun W => W (d aug (e, x))) H^)).
       exact ((incoh (e, x))^).
  - reflexivity.
Defined.

Lemma TriangleABis {n : nat} {F : Type} (aug : Aug F (S n)) (f : F -> (Free (Forget (FreeA aug) n)))
           (H : compose (Counit (FreeA aug) n) f = injectA aug):
           compose (CounitA (S n) (Counit (FreeA aug) n))
                   (FreeMA (UnitBisA aug f H)) = (fun x : FreeA aug => x).
Proof.
  apply funext. simple refine (eqMorphPushout _ _ _).
  - intro b1. unfold compose. simpl. exact (f_equal (fun W => W b1) H).
  - intro b2. unfold compose. simpl. destruct b2. reflexivity.
  - intros a. unfold compose. simpl.
    match goal with
    | |- _ = f_equal (fun x => CounitA ?a1 ?a2  (@?W x)) (incoh a) =>
      change (f_equal (fun x => CounitA a1 a2 (W x)) (incoh a)) with
          (f_equal (compose (CounitA a1 a2) W) (incoh a));
        simple refine (_ @ (ap_compose W (CounitA a1 a2) (incoh a))^)
    end. unfold compose. unfold CounitA.
    match goal with
    | |- _ = f_equal ?f _  => simple refine (_ @ (f_equal (fun W => f_equal f W) Pushout_rect_compute_coh^))
    end. simpl.
    match goal with
    | |- _ = f_equal ?f (1 @ ?p)  => simple refine (_ @ (f_equal (fun W => f_equal f W) (concat_1p p )^))
    end.
    match goal with
    | |- _ = f_equal (Pushout_rect ?a1 ?a2 ?a3) (incoh ?a4) =>
      simple refine (_ @ (Pushout_rect_compute_coh (f1 := (fun x  => pi2 x.1 x.2)) )^)
    end.
    simpl.
    match goal with
    | |- _ = f_equal ?f ?p ^ => simple refine (_ @ (concat_ap_V f p)^)
    end.
    match goal with
    | |- _ = (f_equal (fun W => W a.2) (funext ?p))^ =>
      simple refine (_ @ (f_equal (fun W => W^) (funextcompute p a.2)^))
    end.
    match goal with
    | |- ?p @ _ = _ => simple refine ((f_equal (fun W => p @ W) (f_equal_id _)) @ _)
    end.
    simple refine (_ @ (concat_V _ _)^).
    match goal with
    | |- _ = ?p ^ @ ?q ^ ^ =>
      simple refine (_ @ f_equal (fun W => p ^ @ W) (concat_VV _)^);
        simple refine (_ @ f_equal (fun W => W ^ @ q) (concat_ap_V _ _)^);
        exact (f_equal (fun W => W @ q) (concat_VV _)^)
    end.
Defined.

Fixpoint UnitPol {n : nat} (p : Pol n) {struct n} : {f :  MPol p (Forget (Free p) n) |
                                                              compose (Counit (Free p) n) (FreeM f) = (fun x => x)}.
Proof.
  destruct n.
  - simple refine (mkDPair _ _).
    + destruct p using case0. econstructor. exact (fun x => x).
    + destruct p using case0. exact 1.
  - simple refine (mkDPair _ _); destruct p as [p aug] using caseS'.
    + simpl. unshelve econstructor.
      * exact (ComposeM (fstd (UnitPol n p)) (ForgetM n (injectPol p aug) ) ).
      * simpl.  simple refine (UnitBisA _ _ _).
        match goal with
          |- compose ?f _ = _ => simple refine (f_equal (fun W => compose f W) (FreeComposeM _ _) @ _)
        end.
        match goal with
        | |- compose ?f (compose ?g ?h) = _ => change (compose f (compose g h)) with (compose (compose f g) h);
                                               simple refine (f_equal (fun W => compose W h) (CounitM _ _) @ _)
        end.
        match goal with
        | |- compose (compose ?f ?g) ?h = _ => change (compose (compose f g) h) with (compose f (compose g h));
                                           exact (f_equal (fun W => compose f W) (sndd (UnitPol _ _)))
        end.
    + simpl.
      simple refine (TriangleABis _ _ _).
Defined.

Notation Unit p := (fstd (UnitPol p)).
Notation FreeTriangular p := (sndd (UnitPol p)).


Require Import ZF.

(** Fixpoint theorem about monotonic operators
 *)

(** * Construction of the fixpoint "from above" *)

Class inf_lattice (le : set->set->Prop) (inf : set -> set) := {
  lem :> Proper (eq_set==>eq_set==>iff) le;
  le_pre :> PreOrder le;
  le_anti : forall x y, le x y -> le y x -> x == y;
(*  infm : morph1 inf;*)
  inf_le : forall x z, z ∈ x -> le (inf x) z;
  inf_least : forall x w,
    (exists w0, w0 ∈ x) -> (forall z, z ∈ x -> le w z) -> le w (inf x)
}.

(** A is the top element of pA *)
Class rel_with_top (A pA:set) (le : set->set->Prop) :=
  is_powerA : forall x, le x A -> x ∈ pA.

(** The lattice of subsets *)

Instance inf_lattice_incl : inf_lattice incl_set inter.
split; auto with *; intros.
 apply incl_eq; trivial.

 red; intros.
 apply inter_elim with x; trivial.

 red; intros.
 apply inter_intro; intros; trivial.
 apply H0; trivial.
Qed.

Instance incl_with_top A : rel_with_top A (power A) incl_set.
intros x; apply power_intro.
Qed.

Section KnasterTarski.

Variable le : set -> set -> Prop.
Variable inf : set -> set.
Hypothesis ilat : inf_lattice le inf.
Infix "⊆" := le.

Variable A : set.
Variable pA : set.
Hypothesis topA : rel_with_top A pA le.

Let pA' := subset pA (fun x => x ⊆ A).
Let is_powerA' x : x ⊆ A <-> x ∈ pA'.
split; intros.
 apply subset_intro; trivial.
 apply is_powerA; trivial.

 apply subset_elim2 in H; destruct H.
 rewrite H; trivial.
Qed.

Let A_pA : A ∈ pA'.
apply is_powerA'; reflexivity.
Qed.

Variable F : set -> set.

Hypothesis Fmono : Proper (le==>le) F.
Hypothesis Ftyp : forall x, x ⊆ A -> F x ⊆ A.

Instance Fm : morph1 F.
do 2 red; intros.
apply le_anti; apply Fmono; rewrite H; reflexivity.
Qed.

Definition is_lfp x :=
  F x == x /\ forall y, (*y ⊆ A ->*) F y ⊆ y -> x ⊆ y.

Lemma lfp_elim x : is_lfp x -> F x == x.
intros h; apply h.
Qed.

Lemma is_lfp_unique x y :
  is_lfp x -> is_lfp y -> x == y.
intros.
apply le_anti.
 apply H.
 rewrite lfp_elim with (1:=H0); reflexivity.

 apply H0.
 rewrite lfp_elim with (1:=H); reflexivity.
Qed.

Definition pre_fix x := x ⊆ F x.
Definition post_fix x := F x ⊆ x.

Lemma post_fix_A : post_fix A.
red; intros.
apply Ftyp; auto with *.
Qed.

Definition M' := subset pA' post_fix.

Lemma member_A : A ∈ M'.
unfold M'.
apply subset_intro; trivial.
apply post_fix_A.
Qed.

Lemma post_fix1 x : x ∈ M' -> F x ⊆ x.
unfold M'; intros.
elim subset_elim2 with (1:=H); intros.
rewrite H0; trivial.
Qed.

Definition FIX := inf M'.

Lemma lower_bound x : x ∈ M' -> FIX ⊆ x.
unfold FIX, M'; intros.
apply inf_le; trivial.
Qed.

Lemma lfp_typ : FIX ⊆ A.
apply lower_bound.
apply member_A.
Qed.

Lemma post_fix2 x : x ∈ M' -> F FIX ⊆ F x.
intros.
apply Fmono.
apply lower_bound; trivial.
Qed.

Lemma post_fix_lfp : post_fix FIX.
red.
unfold FIX.
apply inf_least; intros.
 exists A; apply member_A.
transitivity (F z).
 apply post_fix2; trivial.
 apply post_fix1; trivial.
Qed.

Lemma incl_f_lfp : F FIX ∈ M'.
unfold M'; intros.
apply subset_intro.
 apply is_powerA'.
 apply Ftyp.
 apply lfp_typ.

 red.
 apply Fmono.
 apply post_fix_lfp.
Qed.

Lemma FIX_eqn : F FIX == FIX.
apply le_anti.
 apply post_fix_lfp.

 apply lower_bound.
 apply incl_f_lfp.
Qed.

Lemma knaster_tarski : is_lfp FIX.
split.
 apply FIX_eqn.

 intros.
 transitivity (inf (pair y A)).
 2:apply inf_le; apply pair_intro1.
 apply lower_bound.
 unfold M'.
 apply subset_intro; trivial.
  apply is_powerA'.
  apply inf_le; apply pair_intro2.

  red.
  apply inf_least; intros.
   exists y; apply pair_intro1.
  apply pair_elim in H0; destruct H0; rewrite H0.
   transitivity (F y); trivial.
   apply Fmono.
   apply inf_le; apply pair_intro1.

   apply Ftyp.
   apply inf_le; apply pair_intro2.
Qed.

Lemma FIX_ind : forall P,
  (forall X, X ⊆ FIX -> X ⊆ P -> F X ⊆ P) ->
  FIX ⊆ P.
intros.
transitivity (inf (pair P FIX)).
 apply knaster_tarski.
 apply inf_least.
  exists FIX; apply pair_intro2.
 intros.
 apply pair_elim in H0; destruct H0; rewrite H0.
  apply H.
   apply inf_le.
   apply pair_intro2.

   apply inf_le.
   apply pair_intro1.

  transitivity (F FIX).
   apply Fmono.
   apply inf_le.
   apply pair_intro2.

   apply post_fix_lfp.

 apply inf_le.
 apply pair_intro1.
Qed.

End KnasterTarski.

Instance FIX_morph_gen :
  Proper ((eq_set==>eq_set==>iff)==>(eq_set==>eq_set)==>eq_set==>eq_set==>(eq_set==>eq_set)==>eq_set)
    FIX.
do 6 red; intros.
unfold FIX.
apply H0.
unfold M'.
apply subset_morph.
 apply subset_morph; trivial.
 red; intros.
 apply H; auto with *.

 red; intros.
 unfold post_fix.
 apply H; auto with *.
Qed.


Require Import riscv.Proofs.DecodeEncodeProver.

Lemma decodeI64_encode: forall (inst: InstructionI64) (iset: InstructionSet),
    verify (I64Instruction inst) iset ->
    decode iset (encode (I64Instruction inst)) = I64Instruction inst.
Proof. prove_decode_encode. Qed.


From discprob.basic Require Import base order nify.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.rec Require Import karp quickselect_rec log_rec decreasing_rec.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From Coquelicot Require Import Derive.
From Coquelicot Require AutoDerive.
From Interval Require Import Interval_tactic.
Require Import Reals Fourier FunctionalExtensionality.
Require Import Psatz.
Require Import Coq.omega.Omega.
Require Import Ranalysis5.

Module recurrence_leader.
  Import log_rec.
  Module count_factor <: rec_factor.
    Definition alpha := 3/4.
    Lemma alpha_range: 1/2 < alpha < 1.
    Proof. rewrite /alpha.  split; nra. Qed.
    Lemma ln_alpha: -/ln alpha > 1 /alpha.
    Proof. rewrite /alpha. interval. Qed.
  End count_factor.

  Module rec_solution := recurrence_log (count_factor).
  Import rec_solution.

Section recurrence_leader_sec.
  Definition X := (nat * nat)%type.
  Variable A B : X → finType.
  Variable ΩT : ∀ x : X, distrib (A x).
  Variable Ωh : ∀ x : X, distrib (B x).
  Variable T: ∀ x: X, rrvar (ΩT x).
  Variable h: ∀ x: X, rvar (Ωh x) [eqType of X].
  Variable P: X → Prop.
  Variable hP: ∀ x n, P x → P (((h x) n)).
  Definition size (x: X) :=
    match fst x with
    | O => 0
    | _ => INR (snd x)
    end.
  Definition msr (x: X) := INR (fst x).
  Hypothesis T_non_neg: ∀ x n, (T x) n ≥ 0.
  Hypothesis hmsr_dec: ∀ x n, size x > 1 → msr ((h x) n) ≤ msr x - 1.
  Hypothesis hrange1: ∀ x n, size ((h x) n) ≤ size x.
  Hypothesis hrange2: ∀ x n, d < size x →  0 ≤ size ((h x) n).

  Hypothesis Tbelow: ∀ x e, size x ≤ d → (T x) e = 0.

  Hypothesis Trec:
    ∀ x r,  pr_gt (T x) r ≤ \big[Rplus/0]_(x' : imgT (h x))
                  ((pr_eq (h x) (sval x')) * pr_gt (T (sval x')) (r - a (size x))).

  Variable m_bound_Eh: ∀ x, Ex (rvar_comp (h x) size) ≤ m (size x).

  Lemma size_x_int x: size x > 1 → size x < 2 → False.
  Proof.
    rewrite /size.
    replace 2 with (INR 2) by auto.
    replace 1 with (INR 1) by auto.
    replace 0 with (INR 0) by auto.
    destruct x. rewrite /fst. destruct n; rewrite /snd;
    intros ?%INR_lt ?%INR_lt; omega.
  Qed.

  Theorem leader_bound x w:
    P x →
    size x > 1 →
    pr_gt (T x) ((k * ln (size x) + 1) + INR w) ≤ (3/4)^w.
  Proof.
    intros HP Hgt1.
    replace ((k * ln (size x) + 1)) with (u (size x)); last first.
    {  rewrite /u. destruct (Rle_dec); first nra. rewrite //=. }
    replace (INR w) with (INR w * a (size x)); last first.
    { rewrite /a.  destruct Rle_dec; try destruct Rlt_dec; try nra.
      exfalso; eapply size_x_int; eauto. }
    etransitivity; first
    eapply karp_bound_simple with
      (A := A)
      (B := B)
      (T := T)
      (h := h)
      (P := P)
      (umin := umin)
      (d := d)
      (u := u)
      (a := a)
      (m := m).
    - apply umin_non_neg.
    - cut (∀ x, umin ≤ u x).
      { intros Hcut x'. specialize (Hcut (m x')). intros. etransitivity; first eauto.
        specialize (urec0 x'). nra.
      }
      intros x'. destruct (Rle_dec x' d) as [Hle|Hnle%Rnot_le_gt].
      * rewrite /umin/u. move: Hle. rewrite /d. destruct (Rle_dec); nra.
      * rewrite -ud_umin. apply u_mono. fourier.
    - apply u_mono.
    - apply u_strict_inc.
    - apply u'_mono.
    - apply u'_pos.
    - apply u'u.
    - apply u'_inv_above.
    - apply u_inv_above.
    - apply ud_umin.
    - apply m_bound_Eh.
    - intros. apply u_cont.
    - intros. apply a_cont_pt. done.
    - intros. apply Trec; auto.
    - apply urec0.
    - intros. auto.
    - intros. apply hrange1; auto.
    - intros. apply hrange2. nra.
    - apply alower.
    - apply a_nonneg.
    - apply a_mono.
    - apply a_pos.
    - apply mnondec.
    - apply d_non_neg.
    - eapply decreasing_rec.decreasing_rec.hinf_0 with (msr := msr) (msr_cutoff := 0);
        rewrite /d; eauto using hmsr_dec, hrange1, hrange2.
      nra. rewrite /msr/size. intros (r, p) ? Hle. etransitivity; eauto.
      rewrite /size//=. rewrite //= in Hle.
      destruct r; try nra.
      rewrite S_INR in Hle. specialize (pos_INR r). nra.
    - intros. rewrite Tbelow // /umin. nra.
    - rewrite /m/count_factor.alpha. intros.
      destruct (Rlt_dec); nra.
    - auto.
    - done.
    - right. rewrite /id/m/count_factor.alpha. destruct Rlt_dec.
      { exfalso.  eapply size_x_int; first eauto. nra. }
      f_equal. field. nra.
  Qed.

End recurrence_leader_sec.
End recurrence_leader.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__NCdistinct.
Require Export lemma__NChelper.
Require Export lemma__NCorder.
Require Export lemma__betweennotequal.
Require Export lemma__collinearorder.
Require Export lemma__congruenceflip.
Require Export lemma__equalangleshelper.
Require Export lemma__equalanglesreflexive.
Require Export lemma__equalanglessymmetric.
Require Export lemma__equalanglestransitive.
Require Export lemma__inequalitysymmetric.
Require Export lemma__layoff.
Require Export lemma__parallelNC.
Require Export lemma__parallelflip.
Require Export lemma__parallelsymmetric.
Require Export lemma__ray4.
Require Export lemma__ray5.
Require Export lemma__rayimpliescollinear.
Require Export lemma__raystrict.
Require Export lemma__sameside2.
Require Export lemma__samesidereflexive.
Require Export lemma__samesidetransitive.
Require Export logic.
Require Export proposition__04.
Require Export proposition__07.
Require Export proposition__29B.
Definition lemma__Playfairhelper : forall A B C D E, (euclidean__defs.Par A B C D) -> ((euclidean__defs.Par A B C E) -> ((euclidean__defs.CR A D B C) -> ((euclidean__defs.CR A E B C) -> (euclidean__axioms.Col C D E)))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro H.
intro H0.
intro H1.
intro H2.
assert (exists M, (euclidean__axioms.BetS A M D) /\ (euclidean__axioms.BetS B M C)) as H3 by exact H1.
destruct H3 as [M H4].
destruct H4 as [H5 H6].
assert (exists m, (euclidean__axioms.BetS A m E) /\ (euclidean__axioms.BetS B m C)) as H7 by exact H2.
destruct H7 as [m H8].
destruct H8 as [H9 H10].
assert (* Cut *) (euclidean__axioms.neq B C) as H11.
- assert (* Cut *) ((euclidean__axioms.neq m C) /\ ((euclidean__axioms.neq B m) /\ (euclidean__axioms.neq B C))) as H11.
-- apply (@lemma__betweennotequal.lemma__betweennotequal B m C H10).
-- destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
exact H15.
- assert (* Cut *) (euclidean__axioms.BetS E m A) as H12.
-- apply (@euclidean__axioms.axiom__betweennesssymmetry A m E H9).
-- assert (* Cut *) (euclidean__axioms.BetS D M A) as H13.
--- apply (@euclidean__axioms.axiom__betweennesssymmetry A M D H5).
--- assert (* Cut *) (euclidean__axioms.Col B M C) as H14.
---- right.
right.
right.
right.
left.
exact H6.
---- assert (* Cut *) (euclidean__axioms.Col B m C) as H15.
----- right.
right.
right.
right.
left.
exact H10.
----- assert (* Cut *) (euclidean__axioms.Col C B M) as H16.
------ assert (* Cut *) ((euclidean__axioms.Col M B C) /\ ((euclidean__axioms.Col M C B) /\ ((euclidean__axioms.Col C B M) /\ ((euclidean__axioms.Col B C M) /\ (euclidean__axioms.Col C M B))))) as H16.
------- apply (@lemma__collinearorder.lemma__collinearorder B M C H14).
------- destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
exact H21.
------ assert (* Cut *) (euclidean__axioms.Col C B m) as H17.
------- assert (* Cut *) ((euclidean__axioms.Col m B C) /\ ((euclidean__axioms.Col m C B) /\ ((euclidean__axioms.Col C B m) /\ ((euclidean__axioms.Col B C m) /\ (euclidean__axioms.Col C m B))))) as H17.
-------- apply (@lemma__collinearorder.lemma__collinearorder B m C H15).
-------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H22.
------- assert (* Cut *) (euclidean__axioms.nCol B C E) as H18.
-------- assert (* Cut *) ((euclidean__axioms.nCol A B C) /\ ((euclidean__axioms.nCol A C E) /\ ((euclidean__axioms.nCol B C E) /\ (euclidean__axioms.nCol A B E)))) as H18.
--------- apply (@lemma__parallelNC.lemma__parallelNC A B C E H0).
--------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
exact H23.
-------- assert (* Cut *) (euclidean__axioms.nCol C B E) as H19.
--------- assert (* Cut *) ((euclidean__axioms.nCol C B E) /\ ((euclidean__axioms.nCol C E B) /\ ((euclidean__axioms.nCol E B C) /\ ((euclidean__axioms.nCol B E C) /\ (euclidean__axioms.nCol E C B))))) as H19.
---------- apply (@lemma__NCorder.lemma__NCorder B C E H18).
---------- destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exact H20.
--------- assert (* Cut *) (euclidean__axioms.nCol B C D) as H20.
---------- assert (* Cut *) ((euclidean__axioms.nCol A B C) /\ ((euclidean__axioms.nCol A C D) /\ ((euclidean__axioms.nCol B C D) /\ (euclidean__axioms.nCol A B D)))) as H20.
----------- apply (@lemma__parallelNC.lemma__parallelNC A B C D H).
----------- destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
exact H25.
---------- assert (* Cut *) (euclidean__axioms.nCol C B D) as H21.
----------- assert (* Cut *) ((euclidean__axioms.nCol C B D) /\ ((euclidean__axioms.nCol C D B) /\ ((euclidean__axioms.nCol D B C) /\ ((euclidean__axioms.nCol B D C) /\ (euclidean__axioms.nCol D C B))))) as H21.
------------ apply (@lemma__NCorder.lemma__NCorder B C D H20).
------------ destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
exact H22.
----------- assert (* Cut *) (euclidean__axioms.TS E C B A) as H22.
------------ exists m.
split.
------------- exact H12.
------------- split.
-------------- exact H17.
-------------- exact H19.
------------ assert (* Cut *) (euclidean__axioms.TS D C B A) as H23.
------------- exists M.
split.
-------------- exact H13.
-------------- split.
--------------- exact H16.
--------------- exact H21.
------------- assert (* Cut *) (euclidean__defs.Par C D A B) as H24.
-------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric A B C D H).
-------------- assert (* Cut *) (euclidean__defs.Par C E A B) as H25.
--------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric A B C E H0).
--------------- assert (* Cut *) (euclidean__defs.Par E C B A) as H26.
---------------- assert (* Cut *) ((euclidean__defs.Par E C A B) /\ ((euclidean__defs.Par C E B A) /\ (euclidean__defs.Par E C B A))) as H26.
----------------- apply (@lemma__parallelflip.lemma__parallelflip C E A B H25).
----------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
exact H30.
---------------- assert (* Cut *) (euclidean__defs.Par D C B A) as H27.
----------------- assert (* Cut *) ((euclidean__defs.Par D C A B) /\ ((euclidean__defs.Par C D B A) /\ (euclidean__defs.Par D C B A))) as H27.
------------------ apply (@lemma__parallelflip.lemma__parallelflip C D A B H24).
------------------ destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
exact H31.
----------------- assert (* Cut *) (euclidean__defs.CongA E C B C B A) as H28.
------------------ apply (@proposition__29B.proposition__29B E A C B H26 H22).
------------------ assert (* Cut *) (euclidean__defs.CongA D C B C B A) as H29.
------------------- apply (@proposition__29B.proposition__29B D A C B H27 H23).
------------------- assert (* Cut *) (euclidean__defs.CongA C B A D C B) as H30.
-------------------- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric D C B C B A H29).
-------------------- assert (* Cut *) (euclidean__defs.CongA E C B D C B) as H31.
--------------------- apply (@lemma__equalanglestransitive.lemma__equalanglestransitive E C B C B A D C B H28 H30).
--------------------- assert (* Cut *) (euclidean__axioms.neq C E) as H32.
---------------------- assert (* Cut *) ((euclidean__axioms.neq C B) /\ ((euclidean__axioms.neq B E) /\ ((euclidean__axioms.neq C E) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq E B) /\ (euclidean__axioms.neq E C)))))) as H32.
----------------------- apply (@lemma__NCdistinct.lemma__NCdistinct C B E H19).
----------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H37.
---------------------- assert (* Cut *) (euclidean__axioms.neq C D) as H33.
----------------------- assert (* Cut *) ((euclidean__axioms.neq C B) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq D B) /\ (euclidean__axioms.neq D C)))))) as H33.
------------------------ apply (@lemma__NCdistinct.lemma__NCdistinct C B D H21).
------------------------ destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H38.
----------------------- assert (* Cut *) (exists e, (euclidean__defs.Out C E e) /\ (euclidean__axioms.Cong C e C D)) as H34.
------------------------ apply (@lemma__layoff.lemma__layoff C E C D H32 H33).
------------------------ destruct H34 as [e H35].
destruct H35 as [H36 H37].
assert (* Cut *) (B = B) as H38.
------------------------- apply (@logic.eq__refl Point B).
------------------------- assert (* Cut *) (euclidean__axioms.neq C B) as H39.
-------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B C H11).
-------------------------- assert (* Cut *) (euclidean__defs.Out C B B) as H40.
--------------------------- apply (@lemma__ray4.lemma__ray4 C B B).
----------------------------right.
left.
exact H38.

---------------------------- exact H39.
--------------------------- assert (* Cut *) (euclidean__axioms.Cong C B C B) as H41.
---------------------------- apply (@euclidean__axioms.cn__congruencereflexive C B).
---------------------------- assert (* Cut *) (euclidean__axioms.nCol E C B) as H42.
----------------------------- assert (* Cut *) ((euclidean__axioms.nCol B C E) /\ ((euclidean__axioms.nCol B E C) /\ ((euclidean__axioms.nCol E C B) /\ ((euclidean__axioms.nCol C E B) /\ (euclidean__axioms.nCol E B C))))) as H42.
------------------------------ apply (@lemma__NCorder.lemma__NCorder C B E H19).
------------------------------ destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
exact H47.
----------------------------- assert (* Cut *) (euclidean__defs.CongA E C B E C B) as H43.
------------------------------ apply (@lemma__equalanglesreflexive.lemma__equalanglesreflexive E C B H42).
------------------------------ assert (* Cut *) (euclidean__defs.CongA E C B e C B) as H44.
------------------------------- apply (@lemma__equalangleshelper.lemma__equalangleshelper E C B E C B e B H43 H36 H40).
------------------------------- assert (* Cut *) (euclidean__defs.CongA e C B E C B) as H45.
-------------------------------- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric E C B e C B H44).
-------------------------------- assert (* Cut *) (euclidean__defs.CongA e C B D C B) as H46.
--------------------------------- apply (@lemma__equalanglestransitive.lemma__equalanglestransitive e C B E C B D C B H45 H31).
--------------------------------- assert (* Cut *) (euclidean__axioms.Col C E e) as H47.
---------------------------------- apply (@lemma__rayimpliescollinear.lemma__rayimpliescollinear C E e H36).
---------------------------------- assert (* Cut *) (C = C) as H48.
----------------------------------- apply (@logic.eq__refl Point C).
----------------------------------- assert (* Cut *) (euclidean__axioms.Col C E C) as H49.
------------------------------------ right.
left.
exact H48.
------------------------------------ assert (* Cut *) (euclidean__axioms.nCol C E B) as H50.
------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol C E B) /\ ((euclidean__axioms.nCol C B E) /\ ((euclidean__axioms.nCol B E C) /\ ((euclidean__axioms.nCol E B C) /\ (euclidean__axioms.nCol B C E))))) as H50.
-------------------------------------- apply (@lemma__NCorder.lemma__NCorder E C B H42).
-------------------------------------- destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
destruct H56 as [H57 H58].
exact H51.
------------------------------------- assert (* Cut *) (euclidean__axioms.neq C e) as H51.
-------------------------------------- apply (@lemma__raystrict.lemma__raystrict C E e H36).
-------------------------------------- assert (* Cut *) (euclidean__axioms.nCol C e B) as H52.
--------------------------------------- apply (@euclidean__tactics.nCol__notCol C e B).
----------------------------------------apply (@euclidean__tactics.nCol__not__Col C e B).
-----------------------------------------apply (@lemma__NChelper.lemma__NChelper C E B C e H50 H49 H47 H51).

--------------------------------------- assert (* Cut *) (euclidean__axioms.nCol e C B) as H53.
---------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol e C B) /\ ((euclidean__axioms.nCol e B C) /\ ((euclidean__axioms.nCol B C e) /\ ((euclidean__axioms.nCol C B e) /\ (euclidean__axioms.nCol B e C))))) as H53.
----------------------------------------- apply (@lemma__NCorder.lemma__NCorder C e B H52).
----------------------------------------- destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
exact H54.
---------------------------------------- assert (euclidean__axioms.Triangle e C B) as H54 by exact H53.
assert (* Cut *) (euclidean__axioms.nCol D C B) as H55.
----------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol B C D) /\ ((euclidean__axioms.nCol B D C) /\ ((euclidean__axioms.nCol D C B) /\ ((euclidean__axioms.nCol C D B) /\ (euclidean__axioms.nCol D B C))))) as H55.
------------------------------------------ apply (@lemma__NCorder.lemma__NCorder C B D H21).
------------------------------------------ destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
exact H60.
----------------------------------------- assert (euclidean__axioms.Triangle D C B) as H56 by exact H55.
assert (* Cut *) (euclidean__axioms.Cong e B D B) as H57.
------------------------------------------ assert (* Cut *) (forall A0 B0 C0 a b c, (euclidean__axioms.Cong A0 B0 a b) -> ((euclidean__axioms.Cong A0 C0 a c) -> ((euclidean__defs.CongA B0 A0 C0 b a c) -> (euclidean__axioms.Cong B0 C0 b c)))) as H57.
------------------------------------------- intro A0.
intro B0.
intro C0.
intro a.
intro b.
intro c.
intro __.
intro __0.
intro __1.
assert (* AndElim *) ((euclidean__axioms.Cong B0 C0 b c) /\ ((euclidean__defs.CongA A0 B0 C0 a b c) /\ (euclidean__defs.CongA A0 C0 B0 a c b))) as __2.
-------------------------------------------- apply (@proposition__04.proposition__04 A0 B0 C0 a b c __ __0 __1).
-------------------------------------------- destruct __2 as [__2 __3].
exact __2.
------------------------------------------- apply (@H57 C e B C D B H37 H41 H46).
------------------------------------------ assert (* Cut *) (euclidean__axioms.nCol B C E) as H58.
------------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol D C B) /\ ((euclidean__axioms.nCol D B A) /\ ((euclidean__axioms.nCol C B A) /\ (euclidean__axioms.nCol D C A)))) as H58.
-------------------------------------------- apply (@lemma__parallelNC.lemma__parallelNC D C B A H27).
-------------------------------------------- destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
exact H18.
------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol C B E) as H59.
-------------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol C B E) /\ ((euclidean__axioms.nCol C E B) /\ ((euclidean__axioms.nCol E B C) /\ ((euclidean__axioms.nCol B E C) /\ (euclidean__axioms.nCol E C B))))) as H59.
--------------------------------------------- apply (@lemma__NCorder.lemma__NCorder B C E H58).
--------------------------------------------- destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
destruct H63 as [H64 H65].
destruct H65 as [H66 H67].
exact H60.
-------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol B C D) as H60.
--------------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol D C B) /\ ((euclidean__axioms.nCol D B A) /\ ((euclidean__axioms.nCol C B A) /\ (euclidean__axioms.nCol D C A)))) as H60.
---------------------------------------------- apply (@lemma__parallelNC.lemma__parallelNC D C B A H27).
---------------------------------------------- destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
destruct H64 as [H65 H66].
exact H20.
--------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol C B D) as H61.
---------------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol C B D) /\ ((euclidean__axioms.nCol C D B) /\ ((euclidean__axioms.nCol D B C) /\ ((euclidean__axioms.nCol B D C) /\ (euclidean__axioms.nCol D C B))))) as H61.
----------------------------------------------- apply (@lemma__NCorder.lemma__NCorder B C D H60).
----------------------------------------------- destruct H61 as [H62 H63].
destruct H63 as [H64 H65].
destruct H65 as [H66 H67].
destruct H67 as [H68 H69].
exact H62.
---------------------------------------------- assert (* Cut *) (euclidean__defs.OS E D C B) as H62.
----------------------------------------------- exists A.
exists m.
exists M.
split.
------------------------------------------------ exact H17.
------------------------------------------------ split.
------------------------------------------------- exact H16.
------------------------------------------------- split.
-------------------------------------------------- exact H12.
-------------------------------------------------- split.
--------------------------------------------------- exact H13.
--------------------------------------------------- split.
---------------------------------------------------- exact H59.
---------------------------------------------------- exact H61.
----------------------------------------------- assert (* Cut *) (euclidean__axioms.nCol C B e) as H63.
------------------------------------------------ assert (* Cut *) ((euclidean__axioms.nCol C e B) /\ ((euclidean__axioms.nCol C B e) /\ ((euclidean__axioms.nCol B e C) /\ ((euclidean__axioms.nCol e B C) /\ (euclidean__axioms.nCol B C e))))) as H63.
------------------------------------------------- apply (@lemma__NCorder.lemma__NCorder e C B H54).
------------------------------------------------- destruct H63 as [H64 H65].
destruct H65 as [H66 H67].
destruct H67 as [H68 H69].
destruct H69 as [H70 H71].
exact H66.
------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col C C B) as H64.
------------------------------------------------- left.
exact H48.
------------------------------------------------- assert (* Cut *) (euclidean__defs.Out C e E) as H65.
-------------------------------------------------- apply (@lemma__ray5.lemma__ray5 C E e H36).
-------------------------------------------------- assert (* Cut *) (euclidean__defs.OS e e C B) as H66.
--------------------------------------------------- apply (@lemma__samesidereflexive.lemma__samesidereflexive C B e H63).
--------------------------------------------------- assert (* Cut *) (euclidean__defs.OS e E C B) as H67.
---------------------------------------------------- apply (@lemma__sameside2.lemma__sameside2 C C B e e E H66 H64 H65).
---------------------------------------------------- assert (* Cut *) (euclidean__defs.OS e D C B) as H68.
----------------------------------------------------- apply (@lemma__samesidetransitive.lemma__samesidetransitive C B e E D H67 H62).
----------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong e C D C) as H69.
------------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Cong e C D C) /\ ((euclidean__axioms.Cong e C C D) /\ (euclidean__axioms.Cong C e D C))) as H69.
------------------------------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip C e C D H37).
------------------------------------------------------- destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
exact H70.
------------------------------------------------------ assert (* Cut *) (e = D) as H70.
------------------------------------------------------- apply (@proposition__07.proposition__07 C B e D H39 H69 H57 H68).
------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col C E D) as H71.
-------------------------------------------------------- apply (@eq__ind__r euclidean__axioms.Point D (fun e0 => (euclidean__defs.Out C E e0) -> ((euclidean__axioms.Cong C e0 C D) -> ((euclidean__defs.CongA E C B e0 C B) -> ((euclidean__defs.CongA e0 C B E C B) -> ((euclidean__defs.CongA e0 C B D C B) -> ((euclidean__axioms.Col C E e0) -> ((euclidean__axioms.neq C e0) -> ((euclidean__axioms.nCol C e0 B) -> ((euclidean__axioms.nCol e0 C B) -> ((euclidean__axioms.Triangle e0 C B) -> ((euclidean__axioms.Cong e0 B D B) -> ((euclidean__axioms.nCol C B e0) -> ((euclidean__defs.Out C e0 E) -> ((euclidean__defs.OS e0 e0 C B) -> ((euclidean__defs.OS e0 E C B) -> ((euclidean__defs.OS e0 D C B) -> ((euclidean__axioms.Cong e0 C D C) -> (euclidean__axioms.Col C E D))))))))))))))))))) with (x := e).
---------------------------------------------------------intro H71.
intro H72.
intro H73.
intro H74.
intro H75.
intro H76.
intro H77.
intro H78.
intro H79.
intro H80.
intro H81.
intro H82.
intro H83.
intro H84.
intro H85.
intro H86.
intro H87.
exact H76.

--------------------------------------------------------- exact H70.
--------------------------------------------------------- exact H36.
--------------------------------------------------------- exact H37.
--------------------------------------------------------- exact H44.
--------------------------------------------------------- exact H45.
--------------------------------------------------------- exact H46.
--------------------------------------------------------- exact H47.
--------------------------------------------------------- exact H51.
--------------------------------------------------------- exact H52.
--------------------------------------------------------- exact H53.
--------------------------------------------------------- exact H54.
--------------------------------------------------------- exact H57.
--------------------------------------------------------- exact H63.
--------------------------------------------------------- exact H65.
--------------------------------------------------------- exact H66.
--------------------------------------------------------- exact H67.
--------------------------------------------------------- exact H68.
--------------------------------------------------------- exact H69.
-------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col C D E) as H72.
--------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col E C D) /\ ((euclidean__axioms.Col E D C) /\ ((euclidean__axioms.Col D C E) /\ ((euclidean__axioms.Col C D E) /\ (euclidean__axioms.Col D E C))))) as H72.
---------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C E D H71).
---------------------------------------------------------- destruct H72 as [H73 H74].
destruct H74 as [H75 H76].
destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
exact H79.
--------------------------------------------------------- exact H72.
Qed.


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

(* Instantiation of the Ring tactic for the naturals of Arith $*)

Require Import Bool.
Require Export LegacyRing.
Require Export Arith.
Require Import Eqdep_dec.

Open Local Scope nat_scope.

Fixpoint nateq (n m:nat) {struct m} : bool :=
  match n, m with
  | O, O => true
  | S n', S m' => nateq n' m'
  | _, _ => false
  end.

Lemma nateq_prop : forall n m:nat, Is_true (nateq n m) -> n = m.
Proof.
  simple induction n; simple induction m; intros; try contradiction.
  trivial.
  unfold Is_true in H1.
  rewrite (H n1 H1).
  trivial.
Qed.

Hint Resolve nateq_prop: arithring.

Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq.
  split; intros; auto with arith arithring.
(*  apply (fun n m p:nat => plus_reg_l m p n) with (n := n).
  trivial.*)
Defined.

Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ].

Goal forall n:nat, S n = 1 + n.
intro; reflexivity.
Save S_to_plus_one.

(* Replace all occurrences of (S exp) by (plus (S O) exp), except when
   exp is already O and only for those occurrences than can be reached by going
   down plus and mult operations  *)
Ltac rewrite_S_to_plus_term t :=
  match constr:t with
  | 1 => constr:1
  | (S ?X1) =>
      let t1 := rewrite_S_to_plus_term X1 in
      constr:(1 + t1)
  | (?X1 + ?X2) =>
      let t1 := rewrite_S_to_plus_term X1
      with t2 := rewrite_S_to_plus_term X2 in
      constr:(t1 + t2)
  | (?X1 * ?X2) =>
      let t1 := rewrite_S_to_plus_term X1
      with t2 := rewrite_S_to_plus_term X2 in
      constr:(t1 * t2)
  | _ => constr:t
  end.

(* Apply S_to_plus on both sides of an equality *)
Ltac rewrite_S_to_plus :=
  match goal with
  |  |- (?X1 = ?X2) =>
      try
       let t1 :=
       (**)  (**)
       rewrite_S_to_plus_term X1
       with t2 := rewrite_S_to_plus_term X2 in
       change (t1 = t2) in |- *
  |  |- (?X1 = ?X2) =>
      try
       let t1 :=
       (**)  (**)
       rewrite_S_to_plus_term X1
       with t2 := rewrite_S_to_plus_term X2 in
       change (t1 = t2) in |- *
  end.

Ltac ring_nat := rewrite_S_to_plus; ring.


Require Export Iron.Language.SystemF2.TyBase.
Require Export Iron.Language.SystemF2.TyLift.
Require Import Coq.Logic.FunctionalExtensionality.

(********************************************************************)
(* Substitution of Types in Types. *)
Fixpoint substTT (d: nat) (u: ty) (tt: ty) : ty
 := match tt with
    | TVar ix
    => match nat_compare ix d with
       | Eq => u
       | Gt => TVar (ix - 1)
       | _  => TVar  ix
       end

    |  TCon _
    => tt

    |  TForall t
    => TForall (substTT (S d) (liftTT 1 0 u) t)

    |  TApp t1 t2
    => TApp (substTT d u t1) (substTT d u t2)
  end.

(********************************************************************)
(* Substitution and type utils *)
Lemma substTT_getCtorOfType
 :  forall d t1 t2 t3
 ,  getCtorOfType t2                = Some t3
 -> getCtorOfType (substTT d t1 t2) = Some t3.
Proof.
 intros. gen d t1 t3.
 induction t2; try burn.
Qed.
Hint Resolve substTT_getCtorOfType.

Lemma substTT_makeTApps
 :  forall d t2 t1 ts
 ,  substTT d t2 (makeTApps t1 ts)
 =  makeTApps (substTT d t2 t1) (map (substTT d t2) ts).
Proof.
 intros. gen d t2 t1.
 induction ts; try burn.
Qed.
Hint Rewrite substTT_makeTApps : global.

Lemma liftTT_makeTApps
 :  forall d n t1 ts
 ,  liftTT n d (makeTApps t1 ts)
 =  makeTApps (liftTT n d t1) (map (liftTT n d) ts).
Proof.
 intros. gen d n t1.
 induction ts; burn.
Qed.
Hint Rewrite liftTT_makeTApps : global.

Lemma takeTCon_substTT
 :  forall ix t1 tc t2
 ,  takeTCon t1                 = TCon tc
 -> takeTCon (substTT ix t2 t1) = TCon tc.
Proof.
 intros. gen ix t2.
 induction t1; burn.
Qed.

(********************************************************************)
Lemma substTT_wfT
 :  forall d ix t t2
 ,  wfT d t
 -> substTT (d + ix) t2 t = t.
Proof.
 intros. gen d ix t2.
 induction t; intros; inverts H; simpl; try burn.
  Case "TVar".
   lift_cases; burn.
Qed.
Hint Resolve substTT_wfT.

Lemma substTT_closedT_id
 :  forall d t t2
 ,  closedT t
 -> substTT d t2 t = t.
Proof.
 intros.
 rw (d = d + 0). eauto.
Qed.
Hint Resolve substTT_closedT_id.

(********************************************************************)
(* If we lift at depth d, this creates an empty space and
   substituting into it doens't do anything. *)
Lemma substTT_liftTT
 :  forall d t1 t2
 ,  substTT d t2 (liftTT 1 d t1) = t1.
Proof.
 intros. gen d t2.
 induction t1; intros; simpl; try burn.

 Case "TVar".
  lift_cases; unfold substTT;
   fbreak_nat_compare; burn.
Qed.
Hint Rewrite substTT_liftTT : global.

(********************************************************************)
(* Lifting after substitution,
   with the lifting at a lower index. *)
Lemma liftTT_substTT_1
 :  forall n n' t1 t2
 ,  liftTT 1 n (substTT (n + n') t2 t1)
 =  substTT (1 + n + n') (liftTT 1 n t2) (liftTT 1 n t1).
Proof.
 intros. gen n n' t2.
 induction t1; intros; simpl; try burn.

 Case "TVar".
  repeat (simpl; fbreak_nat_compare;
          try lift_cases; try intros); burn.

 Case "TForall".
  rewrite (IHt1 (S n) n').
  rewrite (liftTT_liftTT_11 0 n).
  burn.
Qed.

Lemma liftTT_substTT
 :  forall m n n' t1 t2
 ,  liftTT m n (substTT (n + n') t2 t1)
 =  substTT (m + n + n') (liftTT m n t2) (liftTT m n t1).
Proof.
 intros. gen n n'.
 induction m; intros; simpl.
  burn.

  rw (S m = 1 + m).
  rewrite <- liftTT_plus.
  rs.
  rw (m + n + n' = n + (m + n')).
  rewrite liftTT_substTT_1.
  burn.
Qed.
Hint Rewrite <- liftTT_substTT : global.

(********************************************************************)
(* Lifting after substitution,
   with the ligting at a higher index *)
Lemma liftTT_substTT'
 :  forall n n' t1 t2
 ,  liftTT 1 (n + n') (substTT n t2 t1)
 =  substTT n (liftTT 1 (n + n') t2) (liftTT 1 (1 + n + n') t1).
Proof.
 intros. gen n n' t2.
 induction t1; intros; try burn.

 Case "TVar".
  repeat ( unfold liftTT; unfold substTT; fold liftTT; fold substTT
         ; try lift_cases
         ; try fbreak_nat_compare
         ; intros); burn.

 Case "TForall".
  simpl. rewrite (IHt1 (S n) n').
  simpl. rewrite (liftTT_liftTT_11 0 (n + n')).
  burn.
Qed.

(********************************************************************)
(* Commuting substitutions. *)
Lemma substTT_substTT
 :  forall n m t1 t2 t3
 ,  substTT (n + m) t3 (substTT n t2 t1)
 =  substTT n (substTT (n + m) t3 t2)
              (substTT (1 + n + m) (liftTT 1 n t3) t1).
Proof.
 intros. gen n m t2 t3.
 induction t1; intros; try burn.

 Case "TVar".
  repeat (simpl; fbreak_nat_compare); burn.

 Case "TForall".
  simpl.
  rewrite (IHt1 (S n) m).
  rewrite (liftTT_substTT_1 0 (n + m)).
  rewrite (liftTT_liftTT_11 0 n).
  burn.
Qed.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Reduction from:
    Uniform Boundedness of Deterministic Simple Stack Machines (DSSM_UB)
  to:
    Simple Semi-unification (SSemiU)
*)

Require Import List.
Import ListNotations.
Require Import PeanoNat Psatz.
Require Import Relations.Relation_Operators Relations.Operators_Properties.

Require Import ssreflect ssrfun ssrbool.

(* uniform boundedness of deterministic simple stack machines *)
From Undecidability.SM Require Import SSM_prelim DSSM_UB.
From Undecidability.SM.DSSM Require Import DSSM_facts.

(* simple semi-unification *)
From Undecidability.SemiU Require Import SemiU_prelim SSemiU.
From Undecidability.SemiU.SSemiU Require Import Enumerable Utils.

(* inject configuration into nat *)
Definition embed : config -> nat := to_nat.
Definition unembed : nat -> config := of_nat.
Definition embedP {X: config} : (unembed (embed X) = X) := enumP.

(* step relation to semi-unification constraints *)
Definition SM_to_SUcs (M: ssm) : list constraint :=
  map (fun '(x, y, a, b, d) =>
    if d then ((a, embed ([], x, [])), (embed ([], y, []), b)) (* ax -> yb *)
    else ((b, embed ([], y, [])), (embed ([], x, []), a)) (* xa -> by *)
    ) M.

Lemma arr_eqI {s t: bool -> term} : (forall (a: bool), s a = t a) ->
  arr (s false) (s true) = arr (t false) (t true).
Proof. move=> H. by rewrite ? H. Qed.

Section SM.

Context {M : ssm}.
Variable detM : deterministic M.

Notation equiv := (@equiv M).
Notation equiv_dec := (equiv_dec detM).
Notation narrow_dec := (narrow_dec detM).
Notation bounded' := (@bounded' M).

(* bounded (by i) search for normal form of X *)
Fixpoint nf_aux (i: nat) (X: config) : config :=
  match i with
  | 0 => X
  | S i => if equiv_dec (unembed i) X then nf_aux i (unembed i) else nf_aux i X
  end.

(* normal form, minimal (wrt. embed) Y such that equiv X Y *)
Definition nf (X: config) : config := nf_aux (embed X) X.

(* X is equivalent to its normal form *)
Lemma nf_equiv (X: config) : equiv X (nf X).
Proof.
  rewrite /nf. move: (embed X) => i. elim: i X.
    move=> X /=. by apply: equiv_refl.
  move=> i IH X /=.
  case: (equiv_dec (unembed i) X).
    move=> /equiv_sym H /=. apply: (equiv_trans detM H). by apply: IH.
  move=> /= _. by apply: IH.
Qed.

Lemma nf_equiv_eq_ind (X Y: config) (j: nat) : equiv X Y -> embed X < j -> nf_aux j Y = nf_aux (embed X) X.
Proof.
  elim: j X Y.
    move=> *. by lia.
  move=> i IH X Y HXY HXi /=.
  case: (equiv_dec (unembed i) Y)=> /=.
    move=> /equiv_sym HYi.
    have: (embed X = i \/ embed X < i) by lia. case.
      move=> /copy [+ ->]. move /(f_equal unembed). rewrite embedP. by move=> ->.
    move=> ?. apply: IH.
      apply: equiv_trans; by eassumption.
    done.
  move=> HiY. have: (embed X = i \/ embed X < i) by lia. case.
    move /(f_equal unembed). rewrite embedP. move=> ?. by subst X.
  move=> ?. by apply: IH.
Qed.

(* normal forms of equivalent configurations are equal *)
Lemma nf_equiv_eq (X Y: config) : equiv X Y -> nf X = nf Y.
Proof.
  have: (embed X = embed Y \/ embed X < embed Y \/ embed Y < embed X) by lia.
  case.
    move /(f_equal unembed). rewrite ? embedP. by move=> ->.
  case.
    move=> + H. move /nf_equiv_eq_ind. by move /(_ _ H).
  move=> + /equiv_sym H. move /nf_equiv_eq_ind. by move /(_ _ H).
Qed.

(* n is 1 + bound - length X.2 *)
Fixpoint ζ (n: nat) (X: config) : term :=
  match n with
  | 0 => atom (embed (nf X))
  | S n =>
      match X with
      | (A, x, B) =>
        if narrow_dec (A, x, B) then arr (ζ n (A, x, B++[false])) (ζ n (A, x, B++[true]))
        else atom (embed (nf X))
      end
  end.

Definition ψ (a: bool) (n: nat) (i: nat): term :=
  match unembed i with
  | (A, x, B) => ζ (n - length B) (A++[a], x, B)
  end.

Lemma ζ_nilP {n: nat} {x: state} : ζ (S n) ([], x, []) = arr (ζ n ([], x, [false])) (ζ n ([], x, [true])).
Proof.
  move=> /=. case: (narrow_dec ([], x, [])).
    done.
  move=> H. exfalso. apply: H. exists x, []. by apply: equiv_refl.
Qed.

Lemma ζ_0P {X: config} : ζ 0 X = atom (embed (nf X)).
Proof. done. Qed.

Lemma ζ_SnP {n: nat} {x: state} {A B: stack} : ζ (S n) (A, x, B) =
  if narrow_dec (A, x, B) then
    arr (ζ n (A, x, B++[false])) (ζ n (A, x, B++[true]))
  else atom (embed (nf (A, x, B))).
Proof. done. Qed.

Lemma SM_to_SUcsP {x y: state} {a b: symbol} : In (a, x, (y, b)) (SM_to_SUcs M) -> exists x' y',
  x = (embed ([], x', [])) /\
  y = (embed ([], y', [])) /\
  equiv ([a], x', []) ([], y', [b]).
Proof.
  rewrite /SM_to_SUcs in_map_iff. move=> [[[[[x' y'] a'] b'] d]]. case: d.
  - case. case=> <- <- <- <- H.
    exists x', y'. constructor; first done. constructor; first done.
    exists ([], y', [b']). constructor.
      apply: rt_step. by apply: step_l.
    by apply: rt_refl.
  - case. case=> <- <- <- <- H.
    exists y', x'. constructor; first done. constructor; first done.
    exists ([b'], y', []). constructor.
      by apply: rt_refl.
    apply: rt_step. by apply: step_r.
Qed.

Lemma ζ_equivP {n: nat} {x x': state} {A B A' B': stack} : bounded' n -> equiv (A, x, B) (A', x', B') ->
  ζ (S n - length B) (A, x, B) = ζ (S n - length B') (A', x', B').
Proof.
  move /(extend_bounded' detM) => Hn. move Hm: (S n - length B)=> m.
  elim: m A B A' B' Hm.
  - move=> A B A' B' HnB Hxx'.
    have: (S n - length B' = 0 \/ S n - length B' = (S (n - length B'))) by lia. case.
      move=> ->. rewrite ? ζ_0P. f_equal. f_equal. by apply: nf_equiv_eq.
    move=> HnB'. rewrite HnB' ζ_0P ζ_SnP.
    case: (narrow_dec (A', x', B')) => /=; first last.
      move=> _. f_equal. f_equal. by apply: nf_equiv_eq.
    move /equiv_sym in Hxx'.
    move /(narrow_equiv detM Hxx') /Hn => /=. by lia.
  - move=> m IH A B A' B' Hm Hxx'.
    have: (S n - length B' = 0 \/ S n - length B' = S (n - length B')) by lia. case.
      move=> HnB'. rewrite HnB' ζ_0P ζ_SnP.
      case: (narrow_dec (A, x, B)) => /=; first last.
        move=> _. f_equal. f_equal. by apply: nf_equiv_eq.
      move /(narrow_equiv detM Hxx') /Hn => /=. by lia.
    move=> ->. rewrite ? ζ_SnP.
    case: (narrow_dec (A, x, B)); case: (narrow_dec (A', x', B'))=> /=.
    + move=> _ _. apply: (arr_eqI (s := fun=> ζ _ _) (t := fun=> ζ _ _)).
      move=> b. have -> : n - length B' = S n - length (B' ++ [b]).
          rewrite app_length /length. by lia.
      apply: IH.
        rewrite app_length /length -/(length _). by lia.
      by apply: equiv_appR.
    + by move=> + /(narrow_equiv detM Hxx').
    + by move=> /(narrow_equiv detM ((iffLR equiv_sym) Hxx')).
    + move=> _ _. f_equal. f_equal. by apply: nf_equiv_eq.
Qed.

Lemma ψP {a: bool} {n: nat} {X: config} : ψ a n (embed X) =
  match X with
  | (A, x, B) => ζ (n - length B) (A++[a], x, B)
  end.
Proof. by rewrite /ψ embedP. Qed.

Lemma ψζP {n: nat} {x: state} {A B: stack} {a: bool} : bounded' n ->
  ζ (S n - length B) (A ++ [a], x, B) = substitute (ψ a (S n)) (ζ (S n - length B) (A, x, B)).
Proof.
  move=> Hn. move Hm: (S n - length B)=> m.
  elim: m x A B Hm.
  - move=> x A B Hm.
    rewrite ? ζ_0P => /=. rewrite ψP.
    move HAxB: (nf (A, x, B)) => [[A' x'] B'].
    have: S n - length B' = 0 \/ S n - length B' > 0 by lia. case.
      move=> ->. rewrite ζ_0P. f_equal. f_equal.
      apply: nf_equiv_eq. apply: equiv_appL.
      rewrite -HAxB. by apply: nf_equiv.
    move=> ?.
    have Hxx': equiv (A' ++ [a], x', B') (A ++ [a], x, B).
      apply: equiv_appL. rewrite equiv_sym -HAxB. by apply: nf_equiv.
    rewrite (ζ_equivP Hn Hxx').
    by rewrite Hm ζ_0P.
  - move=> m IH x A B Hm.
    rewrite ? ζ_SnP. case: (narrow_dec (A, x, B)).
    (* AxB is narrow *)
    + move=> /= /(narrow_appL (a := a)) => ?. case: (narrow_dec (A ++ [a], x, B)); last done.
      move=> _ /=. apply: (arr_eqI (s := fun => ζ _ _) (t := fun => substitute _ _)).
      move=> b. apply: IH. rewrite app_length /length -/(length _). by lia.
    + move=> _ /=. rewrite -(ζ_SnP (A := A ++ [a])).
      rewrite ψP. move HAxB: (nf (A, x, B)) => [[A' x'] B'].
      rewrite -Hm.
      have Hxx': equiv (A ++ [a], x, B) (A' ++ [a], x', B').
        apply: equiv_appL. rewrite -HAxB. by apply: nf_equiv.
      by rewrite (ζ_equivP Hn Hxx').
Qed.

End SM.

(* if M is uniformly bounded,
  then the constructed simple semi-unification instance has a solution *)
Lemma soundness {M: dssm} : DSSM_UB M -> SSemiU (SM_to_SUcs (proj1_sig M)).
Proof.
  Opaque ζ ψ.
  case: M=> M detM. rewrite /DSSM_UB /SSemiU. move /(boundedP detM) => /= [n HnM].
  exists (fun i => ζ detM (S n) (unembed i)), (ψ detM false (S n)), (ψ detM true (S n)).
  case=> [[a x]] => [[y b]] /=. move /SM_to_SUcsP => [x' [y' [? [?]]]].
  subst x y. move: x' y' => x y.
  move /equiv_sym => Hxy. rewrite ? embedP.
  rewrite ζ_nilP. rewrite (itebP (P := fun _ => ζ _ _ _)).
  have {1}-> : (n = S n - 1) by lia.
  rewrite (ζ_equivP _ HnM Hxy) => /=.
  rewrite (itebP (P := fun=> ψ _ _ _)).
  have {1 3}->: S n = S n - 0 by lia.
  have := (ψζP _ HnM (A := []) (B := [])). apply.
Qed.

(* reduction completeness *)

Fixpoint term_depth_bound (t: term) : nat :=
  match t with
  | atom _ => 1
  | arr s t => 1 + (term_depth_bound s) + (term_depth_bound t)
  end.

Fixpoint depth_bound (φ: valuation) (xs: list state) : nat :=
  match xs with
  | [] => 1
  | x :: xs => 1 + term_depth_bound (φ x) + depth_bound φ xs
  end.

Lemma depth_boundP {φ: valuation} {x: state} {xs: list state} : In x xs -> term_depth_bound (φ x) <= depth_bound φ xs.
Proof.
  elim: xs.
    done.
  move=> y xs IH /=. case.
    move=> ?. subst. by lia.
  move /IH. by lia.
Qed.

Fixpoint descend (t: term) (B: stack) {struct B} : option term :=
  match B with
  | [] => Some t
  | b :: B =>
    match t with
    | atom _ => None
    | arr s t => descend (if b then t else s) B
    end
  end.

Fixpoint ascend (ψ0 ψ1: valuation) (t: term) (A: stack) : term :=
  match A with
  | [] => t
  | a :: A => ascend ψ0 ψ1 (substitute (if a then ψ1 else ψ0) t) A
  end.

Lemma ascend_arr {ψ0 ψ1: valuation} {s t: term} {A: stack} :
  ascend ψ0 ψ1 (arr s t) A = arr (ascend ψ0 ψ1 s A) (ascend ψ0 ψ1 t A).
Proof.
  elim: A s t.
    done.
  move=> a A IH s t /=. by rewrite IH.
Qed.

(* interpret φ ψ0 ψ1 of s|p|q is πp (ψs (φ p)) *)
Definition interpret (φ ψ0 ψ1: valuation) (X: config) : option term :=
  match X with
  | (A, x, B) => descend (ascend ψ0 ψ1 (φ (embed ([], x, []))) A) B
  end.

(* reachabile configurations have the same interpretation  *)
Lemma interpretP {M: ssm} {X Y: config} {φ ψ0 ψ1: valuation} :
  Forall (models φ ψ0 ψ1) (SM_to_SUcs M) -> reachable M X Y -> interpret φ ψ0 ψ1 X = interpret φ ψ0 ψ1 Y.
Proof.
  move=> HM. elim.
  - move=> {}X {}Y. case.
    + move=> x y a b A B.
      move: HM. rewrite /SM_to_SUcs. rewrite Forall_mapP Forall_forall => HM.
      move /HM. rewrite /models /interpret.
      case: (φ (embed ([], y, []))); first done.
      move=> s t. case: a; case: b; move=> -> /=.
      all: by rewrite ascend_arr=> /=.
    + move=> x y a b A B.
      move: HM. rewrite /SM_to_SUcs. rewrite Forall_mapP Forall_forall => HM.
      move /HM. rewrite /models /interpret.
      case: (φ (embed ([], x, []))); first done.
      move=> s t. case: a; case: b; move=> -> /=.
      all: by rewrite ascend_arr=> /=.
  - done.
  - by move=> > ? ->.
Qed.

Lemma descendP {s t: term} {B: list symbol} : descend s B = Some t -> length B <= term_depth_bound s.
Proof.
  elim: B s t.
    move=> /= *. by lia.
  move=> b B IH. case=> /=; first done.
  move=> > /IH. case: b; by lia.
Qed.

(* if the constructed simple semi-unification instance has a solution,
  then M is uniformly bounded *)
Lemma completeness {M: dssm}: SSemiU (SM_to_SUcs (proj1_sig M)) -> DSSM_UB M.
Proof.
  case: M=> M detM /=. rewrite /SSemiU /DSSM_UB.
  move=> [φ [ψ0 [ψ1]]]. rewrite -Forall_forall => Hφ.
  pose f x := embed (([], x, []) : config).
  apply: (bounded_of_bounded' detM (n := depth_bound φ (map f (enum_states M)))).
  move=> /= Z x y A B Hx Hy.
  case: (In_dec _ y (enum_states M)); first by decide equality.
    move=> /(in_map f) /depth_boundP => /(_ φ) Hfy.
    move: Hy => /(interpretP Hφ). move: Hx => /(interpretP Hφ) <-.
    move=> /= /descendP. rewrite -/(f y).
    move: (length B) => ?. by lia.
  move: (Hy) Hx => /enum_states_reachable. case.
    move=> <- /enum_states_reachable. case.
      case=> *. subst=> /=. by lia.
    by move=> [+].
  by move=> [+].
Qed.


From mathcomp Require Import all_ssreflect all_algebra perm complex.
From mathcomp.analysis Require Import reals.
From mathcomp.real_closed Require Import complex.

Import Order.TTheory GRing.Theory Num.Theory ComplexField Num.Def complex.
Import Vector.InternalTheory.

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

Local Open Scope ring_scope.

Notation "x %:C" := (real_complex _ x)
  (at level 2, left associativity, format "x %:C") : ring_scope.
Notation "x %:VF" := (x : 'Hom(_,_))
  (at level 2, left associativity, format "x %:VF") : lfun_scope.
Notation "t ~_ i" := (tnth t i) (at level 3, i at level 2).

Section VecterInternalTheoryExtra.
Local Open Scope lfun_scope.

Lemma linearlfE (R : ringType) (U V : lmodType R) (f : U -> V) (lf: linear f) :
  f = Linear lf. Proof. by []. Qed.

Lemma can2_linearP (R : ringType) (U V : lmodType R) (f : U -> V) (f' : V -> U) :
  linear f -> cancel f f' -> cancel f' f -> linear f'.
Proof. move=>lf; rewrite (linearlfE lf); exact: can2_linear. Qed.

Lemma can2_bij (R : ringType) (U V : lmodType R) (f : U -> V) (f' : V -> U) :
  cancel f f' -> cancel f' f -> bijective f'.
Proof. by move=>fK f'K; exists f. Qed.

Lemma v2r_bij (R : ringType) (V : vectType R) : bijective (@v2r _ V).
Proof. exists (@r2v _ V). exact: v2rK. exact: r2vK. Qed.

Lemma r2v_bij (R : ringType) (V : vectType R) : bijective (@r2v _ V).
Proof. exists (@v2r _ V). exact: r2vK. exact: v2rK. Qed.

Lemma f2mxP (R : fieldType) (U V: vectType R) : linear (@f2mx _ U V).
Proof.
move=> a f g; have E: forall u, (a *: f + g) (r2v u) = a *: f (r2v u) + g (r2v u).
by move=> u; rewrite !lfunE /= !lfunE.
apply/eqP/mulmxP => u; move: (E u).
rewrite /fun_of_lfun unlock /= /fun_of_lfun_def /= !r2vK -linearP /=.
by rewrite -linearZ /= -mulmxDr; apply r2v_inj.
Qed.
Canonical f2mx_linear (R : fieldType) (U V: vectType R) := Linear (@f2mxP R U V).

Lemma vecthomP (R : fieldType) (U V: vectType R) : linear (@Vector.Hom _ U V).
Proof. by move=>c x y; apply/lfunP=>z; rewrite unlock/= !linearP. Qed.
Canonical vecthom_linear (R : fieldType) (U V: vectType R) := Linear (@vecthomP R U V).

Lemma f2mxK (R : fieldType) (U V : vectType R) : cancel (@f2mx _ U V) (Vector.Hom).
Proof. move=>x; by apply/val_inj. Qed.

Lemma vecthomK (R : fieldType) (U V : vectType R) : cancel (Vector.Hom) (@f2mx _ U V).
Proof. by move=>x. Qed.

Lemma f2mx_inj (R : fieldType) (U V: vectType R) : injective (@f2mx _ U V).
Proof. exact: (can_inj (@f2mxK _ _ _)). Qed.

Lemma vecthom_inj (R : fieldType) (U V: vectType R) : injective (@Vector.Hom _ U V).
Proof. exact: (can_inj (@vecthomK _ _ _)). Qed.

Lemma comp_f2mx (R : ringType) (H G K: vectType R) (f: 'Hom(H,G)) (g: 'Hom(K,H)) :
  f2mx (f \o g)%VF = f2mx g *m f2mx f.
Proof.
rewrite /comp_lfun /fun_of_lfun unlock /= /fun_of_lfun_def /= unlock.
apply/matrixP=> i j. rewrite /lin1_mx !mxE /comp !r2vK /mulmxr -mulmxA /mulmx mxE.
rewrite (bigD1 i) //= big1.
by move=>k /negPf P; rewrite /delta_mx !mxE P mul0r.
by rewrite /delta_mx !mxE !eqxx mul1r addr0.
Qed.

Lemma f2mx1 (R : ringType) (G: vectType R) : f2mx (\1%VF : 'End(G)) = 1%:M.
Proof.
suff: (\1%VF : 'End(G)) = Vector.Hom 1%:M. by move/(f_equal f2mx).
apply/lfunP=>u; rewrite !lfunE/= /fun_of_lfun unlock /=.
by rewrite /fun_of_lfun_def /= mulmx1 v2rK.
Qed.

Lemma f2mx0 (R : fieldType) (G: vectType R) : f2mx (0%VF : 'End(G)) = 0.
Proof. exact: linear0. Qed.

Lemma f2mx_comp (R: ringType) (U V W: vectType R) (f : 'Hom(U,V)) (g: 'Hom(W,U)) :
  f2mx (f \o g) = f2mx g *m f2mx f.
Proof.
rewrite /comp_lfun unlock/=. apply/matrixP=>i j.
rewrite ![LHS]mxE/= unlock/= !r2vK -mulmxA mxE (bigD1 i)//= big1.
by move=>k /negPf nki; rewrite !mxE nki andbF mul0r.
by rewrite mxE !eqxx mul1r addr0.
Qed.

Lemma f2mx_bij (R : fieldType) (U V : vectType R) : bijective (@f2mx _ U V).
Proof. exists (@Vector.Hom _ U V). exact: f2mxK. exact: vecthomK. Qed.

Lemma vecthom_bij (R : fieldType) (U V : vectType R) : bijective (@Vector.Hom _ U V).
Proof. exists (@f2mx _ U V). exact: vecthomK. exact: f2mxK. Qed.

End VecterInternalTheoryExtra.

Arguments v2r_bij {R V}.
Arguments r2v_bij {R V}.
Arguments f2mx_bij {R U V}.
Arguments vecthom_bij {R U V}.

Section MxCast.
Variable (R: ringType).

Lemma castmx_mul p q r p' q' r' (eqq : q = q') (eqp : p = p') (eqr : r = r')
  (A : 'M[R]_(p,q)) (B : 'M[R]_(q,r)) :
  (castmx (eqp,eqq) A) *m (castmx (eqq,eqr) B) = (castmx (eqp,eqr) (A *m B)).
Proof. by case: p' / eqp A; case: q' / eqq B;
case: r' / eqr=>A B; rewrite !castmx_id. Qed.

Lemma castmx_mulr m n p p' (eqp: p = p')
  (A: 'M[R]_(m,n)) (B: 'M_(n,p)) :
  A *m castmx (erefl _, eqp) B = castmx (erefl _,eqp) (A *m B).
Proof. by case: p' / eqp; rewrite !castmx_id. Qed.

Lemma castmx_mull m n p p' (eqp : p = p')
  (A: 'M[R]_(p,m)) (B: 'M_(m,n)) :
  castmx (eqp, erefl _) A *m B = castmx (eqp, erefl _) (A *m B).
Proof. by case: p' / eqp; rewrite !castmx_id. Qed.

Lemma castmx_inj T p q p' q' (eqpq : (p = p') * (q = q')) :
  injective (@castmx T _ _ _ _ eqpq).
Proof.
by case: eqpq=>eqp eqq; case: p' / eqp; case: q' / eqq=>x y; rewrite !castmx_id.
Qed.

Lemma castrv_qualifier T p p' (eqp : p = p') (P : forall p, qualifier 0 'rV[T]_p)
  (A : 'rV[T]_p) : A \is P p <-> castmx (erefl _, eqp) A \is P p'.
Proof. by case: p' / eqp A P =>A P; rewrite castmx_id. Qed.

Lemma castmx_qualifier T p q p' q' (eqpq : (p = p') * (q = q'))
  (P : forall p q, qualifier 0 'M[T]_(p,q)) (A : 'M[T]_(p,q)) :
  A \is P p q <-> castmx eqpq A \is P p' q'.
Proof. by case: eqpq=>eqp eqq; case : p' / eqp P A;
case: q' / eqq=>P A; rewrite castmx_id. Qed.

Lemma diagmx_cast p p' (eqp : p = p') (A : 'rV[R]_p) :
  diag_mx (castmx (erefl _, eqp) A) = castmx (eqp, eqp) (diag_mx A).
Proof. by case: p' / eqp A =>A; rewrite castmx_id. Qed.

Lemma castmx_is_linear p q p' q' (eqpq : (p = p') * (q = q')) :
  linear (@castmx R p q p' q' eqpq).
Proof. by case: eqpq=>eqp eqq; case: p' / eqp;
case: q' / eqq => a A B; rewrite !castmx_id. Qed.

Canonical castmx_linear p q p' q' (eqpq : (p = p') * (q = q')) :=
  Linear (@castmx_is_linear p q p' q' eqpq).

Lemma scalemx0 n : (0%:M : 'M[R]_n) = 0.
Proof. by apply/matrixP=>i j; rewrite !mxE mul0rn. Qed.

Lemma const_mx0 m n : (const_mx 0 : 'M[R]_(m,n)) = 0.
Proof. by apply/matrixP=>i j; rewrite !mxE. Qed.

Lemma mulmx_rowcol p q (A : 'M[R]_(p,q)) (B : 'M[R]_(q,p)) i j :
  (A *m B) i j = (row i A *m col j B) 0 0.
Proof. by rewrite !mxE; apply eq_bigr=>k _; rewrite !mxE. Qed.

Lemma col_diag_mul {T : comRingType} n (D : 'rV[T]_n) p (A : 'M[T]_(p,n)) i : col i (A *m diag_mx D) = D 0 i *: col i A.
Proof.
apply/matrixP=>j k; rewrite !mxE (bigD1 i)//= big1;
last by rewrite mxE eqxx mulr1n addr0 mulrC.
by move=>l /negPf nli; rewrite !mxE nli mulr0n mulr0.
Qed.

Lemma delta_mx_cast m n m' n' (eqmn : (m = m') * (n = n')) (i : 'I_m) (j : 'I_n) :
  castmx eqmn (delta_mx i j : 'M[R]__) = delta_mx (cast_ord eqmn.1 i) (cast_ord eqmn.2 j).
Proof.
by case: eqmn=> eqm eqn; case: m' / eqm i; case: n' / eqn j=>i j;
rewrite castmx_id !cast_ord_id.
Qed.

End MxCast.

Section Etrans.
Variable (T : eqType).
Implicit Type (p q r t: T).

Lemma esym_erefl p : erefl p = esym (erefl p). Proof. by []. Qed.

Lemma etrans_esym p q (eqpq : p = q) :
  etrans eqpq (esym eqpq) = erefl p.
Proof. by case: q / eqpq=>/=. Qed.

Lemma etrans_erefl p q (eqpq : p = q) :
  etrans (erefl _) eqpq = eqpq.
Proof. by case: q / eqpq=>/=. Qed.

Lemma etrans_ereflV p q (eqpq : p = q) :
  etrans eqpq (erefl _) = eqpq.
Proof. by case: q / eqpq=>/=. Qed.

Lemma etrans_esymV p q (eqpq : p = q) :
  etrans (esym eqpq) eqpq = erefl q.
Proof. by case: q / eqpq=>/=. Qed.

Lemma esym_etrans p q r (eqpq : p = q) (eqqr : q = r) :
  esym (etrans eqpq eqqr) = etrans (esym eqqr) (esym eqpq).
Proof. by case: r / eqqr; case: q /eqpq. Qed.

Definition etransE := (etrans_esym, etrans_esymV, etrans_ereflV, etrans_erefl, esymK).

Lemma etransA p q r t (eqpq : p = q) (eqqr : q = r) (eqrt : r = t) :
  etrans eqpq (etrans eqqr eqrt) = etrans (etrans eqpq eqqr) eqrt.
Proof. apply: eq_irrelevance. Qed.

End Etrans.

Lemma nth_tnth (R: ringType) n (t: n.-tuple R) i (ltin : (i < n)%N) :
  t`_i = t~_(Ordinal ltin).
Proof. by rewrite (tnth_nth 0). Qed.

Lemma tnth_bigE (R: Type) (idx: R) (op: R->R->R) (I: ringType) (n : nat)
  (X : n.-tuple I) P (F: 'I_n -> I -> R) :
  \big[op/idx]_(i < n | P i) F i (X`_i) = \big[op/idx]_(i | P i) F i X~_i.
Proof.
rewrite (eq_bigr (fun i => F i X~_i)) // => i _.
by apply f_equal; rewrite (tnth_nth 0).
Qed.

Lemma pair_neq (T1 T2: eqType) (d d' : T1 * T2) :
  d != d' -> d.1 == d'.1 = false \/ d.2 == d'.2 = false.
Proof.
by destruct d=>/=; rewrite -pair_eqE /pair_eq/=
  negb_and=>/orP[/negPf->|/negPf->]; [left|right].
Qed.

Lemma tuple_neqP (T : eqType) n (s t : n.-tuple T) :
  reflect (exists i, s~_i != t~_i) (s != t).
Proof.
apply/(iffP idP)=>[P|[i Pi]]; last by move: Pi; apply contraNN=>/eqP->.
apply/existsP; move: P; apply/contra_neqT; rewrite negb_exists=>/forallP P.
by apply eq_from_tnth=>x; move: (P x); rewrite negbK=>/eqP.
Qed.

Lemma dffun_neqP (I : finType) (J : forall i : I, eqType)
  (f g : {dffun forall i, J i}) :
  reflect (exists i, f i != g i) (f != g).
Proof.
apply/(iffP idP)=>[P|[i Pi]]; last by move: Pi; apply contraNN=>/eqP->.
apply/existsP; move: P; apply/contra_neqT; rewrite negb_exists=>/forallP P.
by apply/ffunP=>x; move: (P x); rewrite negbK=>/eqP.
Qed.

Lemma ffun_neqP (I : finType) (J : eqType) (f g : {ffun I -> J}) :
  reflect (exists i, f i != g i) (f != g).
Proof. exact: dffun_neqP. Qed.

Lemma neq0_lt0n (m : nat) : (m == 0)%N <> true -> (0 < m)%N.
Proof. by move/negP; rewrite lt0n. Qed.

(* similar to %:C, inject real number to imaginary number *)
Definition im_complex_def (F : ringType) (phF : phant F) (x : F) :=
  Complex 0 x.
Notation im_complex F := (@im_complex_def _ (Phant F)).
Notation "x %:Ci" := (im_complex _ x)
  (at level 2, left associativity, format "x %:Ci")  : ring_scope.
Lemma im_complex_is_additive (R: ringType) : additive (im_complex R).
Proof. by move=>a b; simpc. Qed.
Definition im_complex_additive (R: ringType) :=
  Additive (@im_complex_is_additive R).
Lemma complex_split (R: ringType) (x : R[i]) : (Re x)%:C + (Im x)%:Ci = x.
Proof. by simpc; destruct x. Qed.

Section complex_extra.
Implicit Type (F:ringType) (R:rcfType).
Lemma re_realid F (x:F) : Re (x%:C) = x.
Proof. by simpc. Qed.
Lemma im_imid F (x:F) : Im (x%:Ci) = x.
Proof. by simpc. Qed.
Lemma im_real0 F (x:F) : Im (x%:C) = 0.
Proof. by simpc. Qed.
Lemma re_im0 F (x:F) : Re (x%:Ci) = 0.
Proof. by simpc. Qed.
Lemma normc_real R (x:R) : `|x%:C| = `|x|%:C.
Proof.
by rewrite normc_def im_real0 expr0n addr0 re_realid Num.Theory.sqrtr_sqr.
Qed.
Lemma normc_im R (x:R) : `|x%:Ci| = `|x|%:C.
Proof.
by rewrite normc_def re_im0 expr0n add0r im_imid Num.Theory.sqrtr_sqr.
Qed.
Lemma cgt0_real R (e : R[i]) : 0 < e -> (Re e)%:C = e.
Proof.
rewrite -{3}(complex_split e) ltcE=>/andP[/eqP ->]/=; by rewrite addr0.
Qed.
Lemma real_gt0 R (e : R[i]) : 0 < e -> 0 < Re e.
by rewrite ltcE/==>/andP[ _].
Qed.
Lemma normc_ge_Im R (x : R[i]): `|Im x|%:C <= `|x|.
Proof.
by case: x => a b; simpc=>/=; rewrite -Num.Theory.sqrtr_sqr
  Num.Theory.ler_wsqrtr // Num.Theory.ler_addr Num.Theory.sqr_ge0.
Qed.
End complex_extra.

Section RealC.
Variable (R : realType).
Implicit Type (x y : R).
Notation C := R[i].

(* for convert conjc and conjC *)
Lemma conjcC : (@conjc R) = conjC. Proof. by []. Qed.
Lemma conjCc : (@conjC _ : R[i] -> R[i]) = (@conjc R). Proof. by []. Qed.
Lemma conjC_inj (x y : R[i]) : x^* = y^* -> x = y.
Proof. by move=> P; rewrite -(conjcK x) P conjcK. Qed.

Lemma natrC n : n%:R%:C = n%:R :> C. Proof. exact: raddfMn. Qed.
Lemma realcN x : (- x)%:C = - x%:C. Proof. exact: raddfN. Qed.
Lemma realcD x y : (x + y)%:C = x%:C + y%:C. Proof. exact: raddfD. Qed.
Lemma realcM x y : (x * y)%:C = x%:C * y%:C. Proof. exact: rmorphM. Qed.
Lemma realcB x y : (x - y)%:C = x%:C - y%:C. Proof. exact: raddfB. Qed.
Lemma realcMn x n : (x *+ n)%:C = x%:C *+ n. Proof. exact: raddfMn. Qed.
Lemma realcMNn x n : (x *- n)%:C = x%:C *- n. Proof. exact: raddfMNn. Qed.
Lemma realcI x : ((x^-1)%:C = x%:C^-1)%R.
Proof.
rewrite {2}/GRing.inv/= expr0n/= mul0r addr0 expr2 invfM mulrA.
case E: (x == 0). by move: E=>/eqP->; rewrite invr0 mulr0 oppr0.
by rewrite mulfV ?E// mul1r; simpc.
Qed.
Lemma realcX x n : (x^+n)%:C = x%:C^+n. Proof. exact: rmorphX. Qed.
Lemma realcXN x n : (x^-n)%:C = x%:C^-n. Proof. by rewrite realcI realcX. Qed.
Lemma realc_sum (I : Type) (r : seq I) (P : pred I) (F : I -> R) :
  (\sum_(i <- r | P i) F i)%:C = \sum_(i <- r | P i) (F i)%:C.
Proof. exact: rmorph_sum. Qed.
Lemma realc_prod (I : Type) (r : seq I) (P : pred I) (F : I -> R) :
  (\prod_(i <- r | P i) F i)%:C = \prod_(i <- r | P i) (F i)%:C.
Proof. exact: rmorph_prod. Qed.
Lemma realc_norm (r : R) : `|r|%:C = `|r%:C|.
Proof. by rewrite {2}/Num.norm/= expr0n/= addr0 sqrtr_sqr. Qed.
Lemma eqcR x y : (x%:C == y%:C) = (x == y).
Proof. by rewrite (inj_eq (@complexI _)). Qed.
Lemma realc_eq1 x : (x%:C == 1) = (x == 1). Proof. exact: eqcR. Qed.
Lemma realc_eq0 x : (x%:C == 0) = (x == 0). Proof. exact: eqcR. Qed.
Lemma lecR0 x : (x%:C <= 0) = (x <= 0). Proof. exact: lecR. Qed.
Lemma lec0R x : (0 <= x%:C) = (0 <= x). Proof. exact: lecR. Qed.
Lemma lecR1 x : (x%:C <= 1) = (x <= 1). Proof. exact: lecR. Qed.
Lemma lec1R x : (1 <= x%:C) = (1 <= x). Proof. exact: lecR. Qed.
Lemma ltcR0 x : (x%:C < 0) = (x < 0). Proof. exact: ltcR. Qed.
Lemma ltc0R x : (0 < x%:C) = (0 < x). Proof. exact: ltcR. Qed.
Lemma ltcR1 x : (x%:C < 1) = (x < 1). Proof. exact: ltcR. Qed.
Lemma ltc1R x : (1 < x%:C) = (1 < x). Proof. exact: ltcR. Qed.
Lemma natc_inj (a b : nat) : ((a%:R : C) = b%:R) -> a = b.
Proof. by move=>/eqP; rewrite eqr_nat=>/eqP. Qed.
Lemma eqc_nat (a b : nat) : ((a%:R : C) == b%:R) = (a == b).
Proof. exact: eqr_nat. Qed.

Lemma conjcM (x y : C) : (x * y)^* = x^* * y^*.
Proof. exact: rmorphM. Qed.
Lemma invcM (x y : C) : x^-1 * y^-1 = (x * y)^-1.
Proof. by rewrite invfM. Qed.
Lemma divcM1 (x y z : C) : x / y / z = x / (y * z).
Proof. by rewrite -mulrA invfM. Qed.
Lemma divcM2 (x y z : C) : x / y * z = x * z / y.
Proof. by rewrite -mulrA [_ * z]mulrC mulrA. Qed.
Lemma divcM3 (x y : C) : x^-1 * y = y * x^-1.
Proof. by rewrite mulrC. Qed.
Lemma divcM4 (x y z : C) : x * (y / z) = x * y / z.
Proof. by rewrite mulrA. Qed.
Lemma conjc_inv_ (x : C) : (x^-1)^* = x^*^-1.
Proof. exact: conjc_inv. Qed.
Lemma conjc_sqrt (x : nat) : (sqrtC (x%:R : C))^* = sqrtC x%:R.
Proof. by rewrite conj_Creal// ger0_real// sqrtC_ge0 ler0n. Qed.

Lemma sqrtcMK (x : nat) : sqrtC (x%:R : C) * sqrtC x%:R = x%:R.
Proof. by rewrite -expr2 sqrtCK. Qed.

Definition divc_simp := (invcM, divcM1, divcM2, divcM3, divcM4,
  conjcM, conjc_inv_, conjc_sqrt, sqrtcMK).

Lemma conjCN1 : (-1 : C)^* = -1. Proof. by rewrite rmorphN conjC1. Qed.
Lemma oppcK (x : C) : - (- x) = x. Proof. exact: opprK. Qed.
Definition sign_simp := (conjC0, conjC1, conjCN1, mulN1r, mulrN1,
  mulNr, mulrN, mulr1, mul1r, invrN, oppcK, addNr, addrN).
Lemma split2c (x : C) : x / 2%:R + x / 2%:R = x.
Proof. by rewrite -mulr2n -mulr_natr mulfVK// pnatr_eq0. Qed.
Lemma split21 : (2%:R : C)^-1 + (2%:R : C)^-1 = 1.
Proof. by rewrite -[RHS]split2c mul1r. Qed.
Definition split2 := (split21, split2c).

Lemma sqrtCV_nat (x : nat) n :
  (sqrtC ((x%:R : C) ^+ n)) ^-1 = sqrtC (x%:R ^-n).
Proof. by case: n=>[|n]; rewrite rootCV// exprn_ge0// ler0n. Qed.

Lemma sqrtCNV_nat (x : nat) n :
  (sqrtC ((x%:R : C) ^- n)) ^-1 = sqrtC (x%:R ^+n).
Proof. by rewrite -sqrtCV_nat invrK. Qed.

Lemma sqrtCX_nat (x : nat) n :
  sqrtC ((x%:R : C) ^+ n) = sqrtC x%:R ^+ n.
Proof. by case: n=>[|n]; rewrite ?expr0 ?sqrtC1// rootCX// ler0n. Qed.

Lemma sqrtCNX_nat (x : nat) n :
  sqrtC ((x%:R : C) ^- n) = sqrtC x%:R ^- n.
Proof. by rewrite rootCV// ?sqrtCX_nat// exprn_ge0// ler0n. Qed.

Lemma invf_prod (F : fieldType) I (r : seq I) (P : pred I) (f : I -> F) :
  ((\prod_(i <- r | P i) (f i))^-1 = \prod_(i <- r | P i) (f i)^-1)%R.
Proof. by elim/big_rec2: _=>[|i x y _ <-]; rewrite ?invr1// invfM. Qed.

Lemma normr_prod (F : numDomainType) I (r : seq I) (P : pred I) (f : I -> F) :
  `|(\prod_(i <- r | P i) (f i))| = \prod_(i <- r | P i) `|(f i)|.
Proof. by elim/big_rec2: _=>[|i x y _ <-]; rewrite ?normr1// normrM. Qed.

Lemma sqrt_prod (F : numClosedFieldType) I (r : seq I) (P : pred I) (f : I -> F) :
  (forall i, P i -> f i >= 0) ->
  sqrtC (\prod_(i <- r | P i) (f i)) = \prod_(i <- r | P i) sqrtC (f i).
Proof.
move=>P1; rewrite (eq_bigr (fun i=> `|f i|)) -?normr_prod.
by move=>i /P1 P2; rewrite ger0_norm.
elim/big_rec2: _=>[|i x y Pi <-]; rewrite ?normr1 ?sqrtC1//; apply/eqP.
by rewrite -(@eqr_expn2 _ 2%N)// ?mulr_ge0// ?sqrtC_ge0// ?P1//
  exprMn !sqrtCK normrM ger0_norm// P1.
Qed.

Lemma sqrtC_inv (F : numClosedFieldType) (x : F) :
  0 <= x -> ((sqrtC x)^-1 = sqrtC (x^-1))%R.
Proof.
by move=>Px; apply/eqP; rewrite -(@eqr_expn2 _ 2%N)// ?invr_ge0
  ?sqrtC_ge0// ?invr_ge0// exprVn !sqrtCK.
Qed.

End RealC.

Section EnumOrd.
Variable (n : nat) (F : finType).

Lemma enum_ord_eq  (eqt : #|F| = n) j t :
(enum_val (cast_ord (esym eqt) j) == t) = (j == cast_ord eqt (enum_rank t)).
Proof.
case: eqP=>[ <-|]; last case: eqP=>// ->.
1,2: by rewrite ?enum_valK cast_ord_comp cast_ord_id ?eqxx// enum_rankK.
Qed.

Lemma bij_enum_ord (eqt : n = #|F|) (P : pred F) :
{on P, bijective (fun x : 'I_n => enum_val (cast_ord eqt x))}.
Proof.
exists (fun x : F => cast_ord (esym eqt) (enum_rank x))=>t _;
rewrite ?enum_valK cast_ord_comp cast_ord_id// enum_rankK//.
Qed.

Lemma bij_ord_enum (eqt : #|F| = n) :
{on [pred: 'I_n | true], bijective (fun x : F => cast_ord eqt (enum_rank x))}.
Proof.
exists (fun x : 'I_n => enum_val (cast_ord (esym eqt) x))=>t _;
rewrite ?enum_valK cast_ord_comp cast_ord_id// enum_rankK//.
Qed.

End EnumOrd.

Section big_distr_big_dffun.
Variable R : Type.
Variables zero one : R.

Local Notation "0" := zero.
Local Notation "1" := one.
Variable times : Monoid.mul_law 0.
Local Notation "*%M" := times (at level 0).
Local Notation "x * y" := (times x y).
Variable plus : Monoid.add_law 0 *%M.
Local Notation "+%M" := plus (at level 0).
Local Notation "x + y" := (plus x y).

Lemma big_mlaw_absord_seq (I : eqType) (r : seq I) (P : pred I) (i : I) (F : I -> R) :
  P i -> F i = 0 -> i \in r -> \big[*%M/1]_(i <- r | P i) F i = 0.
Proof.
move=>Pi Fi; elim: r=>[//|x r IH].
rewrite inE big_cons; case E: (P x)=>/orP[/eqP|]//.
by move=><-; rewrite Fi Monoid.mul0m.
by move=>/IH->; rewrite Monoid.mulm0.
by move=>xi; move: E; rewrite -xi Pi.
Qed.

Lemma big_mlaw_absord (I : finType) (i : I) (F : I -> R) :
  F i = 0 -> \big[*%M/1]_(i : I) F i = 0.
Proof. by move=>Fi; apply: (big_mlaw_absord_seq _ Fi). Qed.

Lemma big_distr_big_dffun
 (I  : finType)
 (J  : I -> finType)
 (PJ : forall i : I, pred (J i))
 (F  : forall i : I, J i -> R)
:
    \big[*%M/1]_(i : I)
      \big[+%M/0]_(j : J i| PJ i j) F i j
  = \big[+%M/0]_(f : {dffun forall i : I, J i} | f \in family_mem (fun i : I => Mem (PJ i)))
        \big[*%M/1]_(i : I) F i (f i).
Proof.
case/boolP: [forall i, (#|J i| > 0)%N]; last first.
- rewrite negb_forall => /existsP[] i; rewrite -eqn0Ngt => h.
  rewrite (@big_mlaw_absord _ i).
  - rewrite big_pred0 // => j; have/fintype0 := j.
    by rewrite (eqP h).
  - rewrite big_pred0 //= => f; have /fintype0 := f i.
    by rewrite (eqP h).
move=> /forallP ibh; have {}ibh : forall i, J i.
- by move=> i; move/(_ i)/card_gt0P/xchoose: ibh; apply.
pose T := { i : I & J i }.
pose G (i : I) (x : T) :=
  if tag x =P i is ReflectT h then
    F i (ecast z (J z) h (tagged x))
  else 0.
pose Q (i : I) (x : T) :=
  if tag x =P i is ReflectT h then
    PJ i (ecast z (J z) h (tagged x))
  else false.
transitivity (\big[*%M/1]_i \big[+%M/0]_(j | Q i j) G i j).
- apply: eq_bigr=> i _; rewrite [RHS](eq_bigr (fun x => F _ (tagged x))).
  - by case=> i' j'; rewrite /Q /G; case: eqP => //=; case: _ /.
 pose Z (x : T) := pred1 i (tag x) && PJ _ (tagged x).
  rewrite (eq_bigl Z) /Z /Q; first case=> i0 j0 /=.
  - by case: eqP => //=; case: _ /.
  - by rewrite -sig_big_dep (big_pred1 i).
rewrite bigA_distr_big_dep.
pose h (f : {dffun forall i : I, J i}) := [ffun i => existT J i (f i)].
rewrite (reindex h); last first.
- apply: congr_big => //=.
  - move=> g; apply/idP/idP.
    - move/familyP=> hg; apply/forallP=> i; have := hg i.
      rewrite /Q /h /in_mem /= ffunE; case: eqP => //= eq.
      by rewrite eq_axiomK.
    - move/forallP=> hg; apply/familyP=> i; have := hg i.
      rewrite /Q /h /in_mem ffunE /=; case: eqP=> // eq.
      by rewrite eq_axiomK.
  - move=> g hg; apply: eq_bigr=> i _; rewrite /G /h ffunE /=.
    case: eqP; last first.
    - by move/forallP: hg => /(_ i); rewrite /Q /in_mem /=; case: eqP.
    - by move=> eq; rewrite eq_axiomK.
- pose hI (f : {ffun I -> T}) : {dffun forall i : I, J i} :=
    [ffun i : I =>
      if i =P tag (f i) is ReflectT h then
        eq_rect_r (fun z => J z) (tagged (f i)) h
      else ibh i].
  exists hI.
  - move=> f; rewrite inE => /familyP fQ; rewrite /hI /h.
    apply/ffunP=> i; rewrite !ffunE; case: eqP => //=.
    by move=> eq; rewrite eq_axiomK.
  - move=> f; rewrite inE => /familyP fQ; rewrite /hI /h.
    apply/ffunP=> i; rewrite ffunE /=; have := fQ i.
    rewrite /Q /in_mem /= ffunE; case: eqP => //=.
    move=> eq _; apply/eqP; rewrite /eq_op /=.
    rewrite /tag_eq /= {1}eq eqxx andTb /=.
    by rewrite /tagged_as; case: eqP.
Qed.

Lemma big_distr_dffun
(I : finType) (J : forall i : I, finType)
  (F : forall i : I, J i -> R) :
  \big[times/one]_(i : I) \big[plus/zero]_(j : J i) F i j =
     \big[plus/zero]_(f : {dffun forall i : I, J i})
        \big[times/one]_(i : I) F i (f i).
Proof.
rewrite big_distr_big_dffun; apply eq_bigl=>x/=.
by rewrite /in_mem/=; apply/forallP.
Qed.

End big_distr_big_dffun.

Lemma pair_bigV (R : Type) (idx : R) (op : Monoid.com_law idx)
(I J : finType) (P : pred (I * J)) (F : I * J -> R) :
  \big[op/idx]_(p | P p) F p =
    \big[op/idx]_(i : I) \big[op/idx]_(j | P (i,j)) F (i, j).
Proof.
rewrite pair_big_dep/=.
by apply eq_big=>[i|i _]; rewrite -surjective_pairing.
Qed.

Lemma big_negb_all (I : Type) (r : seq I) (P B : pred I) :
  ~~ (\big[andb/true]_(i <- r | P i) B i) =
  \big[orb/false]_(i <- r | P i) (~~ B i).
Proof.
elim: r=>[|r x IH]; rewrite ?big_nil// !big_cons.
case: (P r)=>//; by rewrite negb_and IH.
Qed.

Lemma big_negb_or (I : Type) (r : seq I) (P B : pred I) :
  ~~ (\big[orb/false]_(i <- r | P i) B i) =
  \big[andb/true]_(i <- r | P i) (~~ B i).
Proof.
rewrite -[RHS]negbK big_negb_all; f_equal.
by apply eq_bigr=>i _; rewrite negbK.
Qed.

Lemma leq_ord n (i : 'I_n.+1) : (i <= n)%N.
Proof. by destruct i. Qed.

Lemma ltn_neq (m n : nat) : (m < n)%N -> m != n.
Proof. by move=>/ltn_eqF->. Qed.

Section WidenOrd.
Variable (n : nat).

Lemma widen_lift (i : 'I_n) :
  widen_ord (leqnSn n) i = fintype.lift ord_max i.
Proof. by apply/ord_inj; rewrite lift_max/=. Qed.

Lemma widen_ord_neq (i : 'I_n) :
  (widen_ord (leqnSn n) i) != ord_max.
Proof. by rewrite -(inj_eq val_inj); case: i=>/= m/ltn_neq. Qed.

Lemma lift_max_neq (i : 'I_n) :
  (fintype.lift ord_max i) != ord_max.
Proof. by rewrite -widen_lift widen_ord_neq. Qed.

Lemma widen_ord_inj : injective (widen_ord (leqnSn n)).
Proof. move=>i j; rewrite !widen_lift; exact: lift_inj. Qed.

Variant widen_spec : 'I_n.+1 -> Type :=
  | widenR : widen_spec ord_max
  | widenL (x : 'I_n) : widen_spec (widen_ord (leqnSn n) x).

Lemma widenP i : widen_spec i.
Proof.
case E: (ord_max == i). move: E=>/eqP <-; constructor.
move: E=>/eqP/eqP/unlift_some[j -> _].
rewrite -widen_lift. constructor.
Qed.

Variant lift_ord0_spec : 'I_n.+1 -> Type :=
  | liftord0L : lift_ord0_spec ord0
  | liftord0R (x : 'I_n) : lift_ord0_spec (fintype.lift ord0 x).

Lemma lift0P i : lift_ord0_spec i.
Proof.
case E: (ord0 == i). move: E=>/eqP <-; constructor.
move: E=>/eqP/eqP/unlift_some[j -> _]; constructor.
Qed.

End WidenOrd.

Arguments widen_ord_inj {n}.
Arguments widenP {n}.
Arguments lift0P {n}.

Lemma notin_in_neq (T : eqType) (s : seq T) x y :
    x \notin s -> y \in s -> x != y.
Proof. by move=>+P1; move=>/memPnC/(_ _ P1). Qed.

Section SeqTuple.

Variables (n m : nat) (T U rT : Type).
Implicit Type t : n.-tuple T.

Definition tlast (u : n.+1.-tuple T) := tnth u ord_max.
Definition tfirst (s : seq T) := take (size s).-1 s.
Lemma tfirst_tupleP (u : n.+1.-tuple T) : size (tfirst u) == n.
Proof. by rewrite size_take size_tuple ltnSn. Qed.
Canonical tfirst_tuple u := Tuple (tfirst_tupleP u).
Lemma tfirst_rcons x (u : seq T) : tfirst (rcons u x) = u.
Proof.
rewrite /tfirst size_rcons/=.
by elim: u x=>[x//|y u IH x]; rewrite /= IH.
Qed.

Lemma tnthN x t : tnth [tuple of rcons t x] ord_max = x.
Proof. by rewrite (tnth_nth x)/= nth_rcons size_tuple ltnn eqxx. Qed.

Lemma tnthNS x t i : tnth [tuple of rcons t x] (widen_ord (leqnSn n) i) = tnth t i.
Proof.
rewrite !(tnth_nth x)/= nth_rcons size_tuple.
by case: i=>i /= Pi; rewrite Pi.
Qed.

Lemma tnthNS_lift x t i : tnth [tuple of rcons t x] (fintype.lift ord_max i) = tnth t i.
Proof. by rewrite -widen_lift tnthNS. Qed.

Variant tupleN_spec : n.+1.-tuple T -> Type :=
  TupleNspec x t : tupleN_spec [tuple of rcons t x].

Lemma tupleNP u : tupleN_spec u.
Proof.
case: u=>u; case/lastP: u=>[//|s x Pi].
have Ps: size s == n by move: Pi; rewrite size_rcons.
pose t := @Tuple n _ s Ps.
by rewrite (_ : Tuple _ = [tuple of rcons t x])//; apply/val_inj.
Qed.
(* usage: case/tupleNP : ... *)
Lemma tupleN_eta (t : n.+1.-tuple T) : t = [tuple of rcons (tfirst t) (tlast t)].
Proof.
by case/tupleNP: t=>x t; apply: val_inj; rewrite /=/tlast tnthN tfirst_rcons.
Qed.

End SeqTuple.

Lemma uphalfE m : uphalf m = (m.+1)./2. Proof. by []. Qed.
Lemma uphalf_half_split m : (uphalf m + half m = m)%N.
Proof. by rewrite uphalf_half -[RHS]odd_double_half -addnA addnn. Qed.
Lemma sub_uphalf m : (m - uphalf m = half m)%N.
Proof. by rewrite -{1}(uphalf_half_split m) addnC addnK. Qed.
Lemma sub_half m : (m - half m = uphalf m)%N.
Proof. by rewrite -{1}(uphalf_half_split m) addnK. Qed.
Lemma half_leqn m : (half m <= m)%N.
Proof. by rewrite -{2}(uphalf_half_split m) leq_addl. Qed.
Lemma uphalf_leqn m : (uphalf m <= m)%N.
Proof. by rewrite -{2}(uphalf_half_split m) leq_addr. Qed.
Lemma eq_uphalf_half_odd m : odd m -> uphalf m = (half m).+1.
Proof. by move=>P; rewrite uphalf_half P add1n. Qed.
Lemma eq_uphalf_half_even m : ~~ odd m -> uphalf m = half m.
Proof. by move=>/negPf P; rewrite uphalf_half P add0n. Qed.

Lemma uphalf_ord_subproof (m : nat) : (uphalf m < m.+1)%N.
Proof. by rewrite ltnS uphalf_leqn. Qed.
Definition uphalf_ord (m : nat) := Ordinal (uphalf_ord_subproof m).
Lemma uphalf_ord_odd_rev (m : nat) :
  ~~(odd m) -> rev_ord (uphalf_ord m) = uphalf_ord m.
Proof.
by move=>/negPf P; apply/val_inj=>/=; rewrite subSS uphalf_half
  -{1}(odd_double_half m) P/= !add0n -addnn addnK.
Qed.
Lemma uphalf_ord_neq m (i : 'I_m.+1) : (i < uphalf m)%N -> uphalf_ord m != i.
Proof. by move=>P1; apply/eqP=>P2; move: P1; rewrite -P2/= ltnn. Qed.
Lemma rev_ord_neq m (i : 'I_m.+1) : (i < uphalf m)%N -> rev_ord i != i.
Proof.
move=>P1; apply/eqP=>P2; move: P2=>/(f_equal val)/=/(f_equal (addn i)).
rewrite subSS addnC subnK ?leq_ord// =>P2; move: P1.
by rewrite {2}P2 addnn uphalf_double ltnn.
Qed.

Lemma big_ord_rev (T : Type) (idx : T) (op : Monoid.com_law idx)
  n P (F : 'I_n -> T) :
  \big[op/idx]_(i < n | P i) F i
     = \big[op/idx]_(i < n | P (rev_ord i)) F (rev_ord i).
Proof. by apply: reindex; exists (@rev_ord n)=>i _; rewrite rev_ordK. Qed.

Lemma big_half_split (T : Type) (idx : T) (op : Monoid.com_law idx)
  n (F : 'I_n.+1 -> T) :
  \big[op/idx]_(i < n.+1) F i =
  op (\big[op/idx]_(i : 'I_n.+1 | (i < uphalf n)%N) (op (F i) (F (rev_ord i))))
  (if odd n then idx else F (uphalf_ord n)).
Proof.
case E: (odd n).
rewrite (bigID (fun i : 'I_n.+1=> i < uphalf n)%N)/= big_split Monoid.mulm1; f_equal.
by rewrite big_ord_rev; apply eq_bigl=>i/=; rewrite subSS -leqNgt leq_subCr
  ?leq_ord// ?uphalf_leqn// sub_uphalf eq_uphalf_half_odd.
rewrite (bigD1 (uphalf_ord n))// Monoid.mulmC/=; f_equal.
rewrite (bigID (fun i : 'I_n.+1=> i < uphalf n)%N)/= big_split; f_equal.
apply eq_bigl=>i; symmetry; rewrite eq_sym; case: eqP=>//=;
by apply contraPF=>/uphalf_ord_neq/eqP.
move: E=>/negbT E; rewrite big_ord_rev; apply eq_bigl=>i/=.
by rewrite subSS -leqNgt leq_subCr ?leq_ord// ?uphalf_leqn// sub_uphalf eq_uphalf_half_even//
  ltn_neqAle (inv_eq rev_ordK) uphalf_ord_odd_rev// -(inj_eq val_inj)/= eq_uphalf_half_even.
Qed.

Lemma tnth_rev T n (t : n.-tuple T) i :
  [tuple of rev t] ~_ i = t ~_ (rev_ord i).
Proof.
case: n t i=>[? i|n t i]; first by case: i.
by pose t0 := t ~_ ord0; rewrite !(tnth_nth t0)/= nth_rev size_tuple.
Qed.

Lemma big_setE (T : Type) (idx : T) (op : T -> T -> T)
  (F : finType) (P : pred F) (f : F -> T):
    \big[op/idx]_(i | P i) f i = \big[op/idx]_(i in [set x | P x]) f i.
Proof. by apply: eq_bigl=>y; rewrite inE. Qed.

Lemma big_setT (T : Type) (idx : T) (op : T -> T -> T)
  (F : finType) (f : F -> T):
    \big[op/idx]_i f i = \big[op/idx]_(i in setT) f i.
Proof. by rewrite big_setE/=. Qed.

Lemma big_setEV (T : Type) (idx : T) (op : T -> T -> T)
  (F : finType) (B : {set F}) (f : F -> T):
    \big[op/idx]_(i in B) f i = \big[op/idx]_(i | i \in B) f i.
Proof. by rewrite big_setE/=. Qed.

Lemma big_setIDx (T : Type) (idx : T) (aop : Monoid.com_law idx)
  (F : finType) (B : {set F}) (f : F -> T):
  \big[aop/idx]_i f i =
     aop (\big[aop/idx]_(i in B ) f i)
         (\big[aop/idx]_(i in ~: B) f i).
Proof. by rewrite big_setT (big_setID B) setTI setTD. Qed.
Global Arguments big_setIDx [T idx aop F] B.

Lemma big_rcons (T : Type) (idx : T) (op : Monoid.law idx)
    I i r (P : pred I) F :
    let x := \big[op/idx]_(j <- r | P j) F j in
  \big[op/idx]_(j <- rcons r i | P j) F j = if P i then op x (F i) else x.
Proof.
rewrite/=; elim: r.
by rewrite big_nil/= unlock/= Monoid.mulm1 Monoid.mul1m.
move=>a r IH. rewrite rcons_cons !big_cons; case: (P a)=>//.
by rewrite IH; case: (P i)=>//; rewrite Monoid.mulmA.
Qed.