Require Import String.
Require Import CoherenceBasicBD.
Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSetInterface.
Require Import Arith.
Require Import Setoid.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.

Module Semantics
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Module CBD := CoherenceBasicBiDi(VarTyp)(set).
Import CBD.

Inductive typing : ST.context PTyp -> PExp -> PTyp -> Prop :=
  | TyVar' : forall Gamma x ty,
               ST.ok Gamma ->
               List.In (x, ty) Gamma ->
               WFTyp ty ->
               typing Gamma (PFVar x) ty
  | TyLit' : forall Gamma i,
               ST.ok Gamma ->
               typing Gamma (PLit i) PInt
  | TyLam' : forall L Gamma t A B,
               (forall x, ~ ST.M.In x L ->
                     typing (ST.extend x A Gamma) (open_source t (PFVar x)) B) ->
               WFTyp A ->
               typing Gamma (PLam t) (Fun A B)
  | TyApp' : forall Gamma A B t1 t2,
               typing Gamma t1 (Fun A B) ->
               typing Gamma t2 A ->
               typing Gamma (PApp t1 t2) B
  | TyMerge' : forall Gamma A B t1 t2,
                 typing Gamma t1 A ->
                 typing Gamma t2 B ->
                 OrthoS A B ->
                 typing Gamma (PMerge t1 t2) (And A B)
  | TySub' : forall Gamma t A B,
               typing Gamma t A ->
               Sub A B ->
               WFTyp B ->
               typing Gamma t B.

Inductive In : PExp -> PTyp -> Prop :=
  | InInt : forall n, In (PAnn CT (PLit n) PInt) PInt
  | InFun : forall e A B, In (PAnn CT (PLam e) (Fun A B)) (Fun A B)
  | InAnd : forall v1 v2 A B, In v1 A ->
                         In v2 B ->
                         In (PMerge v1 v2) (And A B).

Inductive bidityping : ST.context PTyp -> PExp -> Dir -> PTyp -> Prop :=
  | ATyVar' : forall (Gamma : ST.context PTyp) (x : ST.var) (ty : PTyp),
                ST.ok Gamma ->
                List.In (x, ty) Gamma ->
                WFTyp ty ->
                bidityping Gamma (PFVar x) Inf ty
  | ATyLit' : forall (Gamma : ST.context PTyp) (x : nat),
                ST.ok Gamma ->
                bidityping Gamma (PLit x) Inf PInt
  | ATyApp' : forall (Gamma : ST.context PTyp) (A B : PTyp) (t1 t2 : PExp),
                bidityping Gamma t1 Inf (Fun A B) ->
                bidityping Gamma t2 Chk A ->
                bidityping Gamma (PApp t1 t2) Inf B
  | ATyMerge' : forall (Gamma : ST.context PTyp) (A B : PTyp) (t1 t2 : PExp),
                  bidityping Gamma t1 Inf A ->
                  bidityping Gamma t2 Inf B ->
                  OrthoS A B ->
                  bidityping Gamma (PMerge t1 t2) Inf (And A B)
  | ATyAnnCT' : forall (Gamma : ST.context PTyp) (t1 : PExp) (A : PTyp),
                  bidityping Gamma t1 Chk A ->
                  bidityping Gamma (PAnn CT t1 A) Inf A
  | ATyAnnRT' : forall (Gamma : ST.context PTyp) (t1 : PExp) (A : PTyp),
                  bidityping Gamma t1 Chk A ->
                  bidityping Gamma (PAnn RT t1 A) Inf A
  | ATyLam' : forall (L : ST.M.t) (Gamma : ST.context PTyp)
                (t : PExp) (A B : PTyp),
                (forall x : ST.M.elt,
                   ~ ST.M.In x L ->
                   bidityping (ST.extend x A Gamma) (open_source t (PFVar x)) Chk B) ->
                WFTyp A ->
                bidityping Gamma (PLam t) Chk (Fun A B)
  | ATySub' : forall (Gamma : ST.context PTyp) (t : PExp)
                (A B : PTyp) (C : ST.Exp),
                bidityping Gamma t Inf A ->
                sub A B C ->
                WFTyp B ->
                bidityping Gamma t Chk B.

Inductive red : PExp -> PExp -> Prop :=
  | Red_Int : forall n, red (PLit n) (PAnn CT (PLit n) PInt)
  | Red_App1 : forall e1 e2 e3,
                 red e1 e3 ->
                 red (PApp e1 e2) (PApp e3 e2)
  | Red_App2 : forall e1 e2 v A B,
                 In v (Fun A B) ->
                 red e1 e2 ->
                 red (PApp v e1) (PApp v e2)
  | Red_App3 : forall A B C v1 v2,
                 In v1 (Fun A B) ->
                 In v2 C ->
                 A <> C ->
                 red (PApp v1 v2) (PApp v1 (PAnn CT v2 C))
  | Red_App4 : forall A B e v,
                 In v A ->
                 red (PApp (PAnn CT (PLam e) (Fun A B)) v)
                     (PAnn CT (open_source e v) B)
  | Red_Merge1 : forall e1 e2 e3,
                   red e1 e3 ->
                   red (PMerge e1 e2) (PMerge e3 e2)
  | Red_Merge2 : forall e1 e2 v A B,
                   In v (And A B) ->
                   red e1 e2 ->
                   red (PMerge v e1) (PMerge v e2)
  | Red_Ann1 : forall e1 e2 A,
                 ~ (In (PAnn CT e1 A) A) ->
                 red e1 e2 ->
                 red (PAnn CT e1 A) (PAnn CT e2 A)
  | Red_Ann2 : forall v,
                 In v PInt ->
                 red (PAnn CT v PInt) v
  | Red_Ann3 :
      forall e A B C D,
        red (PAnn CT (PAnn CT (PLam e) (Fun A B)) (Fun C D))
            (PAnn CT (PLam (PAnn CT (PApp (PAnn CT (PLam e) (Fun A B))
                                          (PAnn CT (PBVar 0) A)) D))
                  (Fun C D))
  | Red_Ann4 : forall v1 v2 A B C,
                    Sub B A ->
                    Atomic A ->
                    In (PMerge v1 v2) (And B C) ->
                    red (PAnn CT (PMerge v1 v2) A)
                        (PAnn CT v1 A)
  | Red_Ann5 : forall v1 v2 A B C,
                 Sub C A ->
                 Atomic A ->
                 In (PMerge v1 v2) (And B C) ->
                 red (PAnn CT (PMerge v1 v2) A)
                     (PAnn CT v2 A)
  | Red_Ann6 : forall v A B C D,
                 In v (And C D) ->
                 red (PAnn CT v (And A B))
                     (PMerge (PAnn CT v A) (PAnn CT v B)).

Hint Constructors typing bidityping In WFTyp red.

(** Soundness and Completeness wrt to the elaborating biditypecheker **)

Theorem has_type_source_alg_rename :
  forall L Gamma A B t1 c m y,
    has_type_source_alg (ST.extend y A Gamma) (open_source t1 (PFVar y)) B m
                        (ST.open c (ST.STFVar _ y)) ->
    (forall x, ~ ST.M.In x L ->
          has_type_source_alg (ST.extend x A Gamma) (open_source t1 (PFVar x)) B m
                              (ST.open c (ST.STFVar _ x))).
Proof.
  intros.
  (* subst_typ_source_intro *)
Admitted.

Theorem soundness : forall Gamma e A m, bidityping Gamma e A m -> has_ty Gamma e A m.
Proof.
  intros Gamma e A m H; unfold has_ty.
  induction H; destruct_conjs; eauto.
  - ST.pick_fresh x.
    destruct (H0 _ Fr) as [c H2].
    exists (ST.STLam' _ c).
    apply_fresh ATyLam as z; auto.
    apply has_type_source_alg_rename with (L := L) (y := x).
    admit. (* missing the good old renaming lemma... *)
    ST.not_in_L z.
Admitted.

Theorem completeness :
  forall Gamma A m d e, has_type_source_alg Gamma e A m d -> bidityping Gamma e A m.
Proof. intros Gamma A m d e H; induction H; eauto; destruct m; auto. Qed.

Hint Resolve soundness completeness.

(** Some necessary properties about bidityping, which are lifted from
    the elaborated version **)

Theorem bityping_ok : forall Gamma t A m, bidityping Gamma t m A -> ST.ok Gamma.
Proof.
  intros; apply soundness in H as [c H]; eapply typing_alg_ok_env; eauto.
Qed.

Theorem bityping_wf : forall Gamma t A m, bidityping Gamma t m A -> WFTyp A.
Proof.
  intros; apply soundness in H as [c H]; eapply typing_wf_source_alg; eauto.
Qed.

Theorem bityping_term : forall Gamma e A m, bidityping Gamma e m A -> PTerm e.
Proof.
  intros; apply soundness in H as [c H]; eapply type_correct_alg_terms; eauto.
Qed.

Theorem bityping_weaken:
  forall G E F t T dir, bidityping (E ++ G) t dir T ->
                   ST.ok (E ++ F ++ G) ->
                   bidityping (E ++ F ++ G) t dir T.
Proof.
  intros; apply soundness in H as [c H].
  assert (Ha := typing_weaken_alg _ _ _ _ _ _ _ H H0); eauto.
Qed.

Theorem bityping_strengthen:
  forall z U E F e dir A,
    not (ST.M.In z (fv_source e)) ->
    bidityping (E ++ ((z,U) :: nil) ++ F) e dir A ->
    bidityping (E ++ F) e dir A.
Proof.
  intros z U E F e dir A H1 H2; apply soundness in H2 as [c H2].
  assert (Ha := typing_strengthen_alg _ _ _ _ _ _ _ _ H1 H2); eauto.
Qed.

(* We didn't prove this before?! See: Pfenning *)
Theorem sub_trans : forall A B, Sub A B -> forall C, Sub B C -> Sub A C. Admitted.

Hint Resolve bityping_ok bityping_wf bityping_term bityping_weaken
     reflex sub_trans.
Hint Unfold Sub.

(*
Theorem bityping_ann_sub :
  forall Gamma t A B m1 m2, bidityping Gamma (PAnn m1 t A) m2 B -> Sub A B.
Proof. intros Gamma t A B m1 m2 Htyping; dependent induction Htyping; eauto. Qed.

Theorem bityping_ann :
  forall Gamma t A B m1 m2, bidityping Gamma (PAnn m1 t A) B m2 -> bidityping Gamma t Chk A.
Proof. intros Gamma t A B m1 m2 Htyping; dependent induction Htyping; eauto. Qed.
*)

(** Properties mixing "Sub", "In" and the type-system. **)

Theorem In_Ann_inv : forall v A B, In (PAnn CT v A) B -> A = B.
Proof. intros v A B H1; dependent induction H1; auto. Qed.

(*Hint Resolve bityping_ann_sub bityping_ann.*)
Hint Resolve In_Ann_inv.
Hint Unfold erase.

Theorem In_bityping_eq :
  forall A v, In v A -> forall B Gamma, bidityping Gamma v Inf B -> A = B.
Proof.
  intros A v HIn.
  induction HIn; eauto 3.
  - intros; inversion H; subst; eauto.
  - intros; inversion H; subst; eauto.
  - intros. dependent induction H.
    clear IHbidityping1 IHbidityping2.
    apply IHHIn1 in H.
    apply IHHIn2 in H0.
    now subst.
Qed.

Hint Resolve In_bityping_eq.

Theorem In_bityping_sub :
  forall A v, In v A -> forall B Gamma m, bidityping Gamma v m B -> Sub A B.
Proof.
  intros A v HIn.
  induction HIn.
  - intros; inversion H; subst; auto.
    inversion H0; subst; eauto.
  - intros; inversion H; subst; auto.
    inversion H0; subst; eauto.
  - intros; dependent induction H; [ clear IHbidityping1 IHbidityping2 | eauto 5 ].
    apply sand1; [ apply sand2 | apply sand3 ]; eauto.
Qed.

Hint Resolve In_bityping_sub.

Theorem bityping_inf_chk :
  forall Gamma e A,
    bidityping Gamma e Inf A -> bidityping Gamma e Chk A.
Proof.
  intros Gamma e A Htyping.
  assert (Ha : Sub A A) by eauto; destruct Ha.
  eapply ATySub' with (A := A); eauto.
Qed.

Hint Resolve bityping_inf_chk.

(** Defining body. (getting ready for subject reduction) **)

Definition body_bityping Gamma t A B m :=
  exists L, forall x, not (ST.M.In x L) ->
            bidityping (ST.extend x A Gamma) (open_source t (PFVar x)) m B.

Hint Unfold body_bityping.

Lemma abs_to_body_bityping : forall A B e Gamma m,
  bidityping Gamma (PLam e) m (Fun A B) -> body_bityping Gamma e A B m.
Proof. intros; inversion H; subst; eauto; inversion H0. Qed.

Lemma bityping_subst : forall Gamma A B e u m x,
                         List.In (x,B) Gamma ->
                         bidityping Gamma e m A ->
                         bidityping Gamma u Inf B ->
                         bidityping Gamma (subst_source x u e) m A.
Proof.
  intros Gamma A B e u m x HIn H1 H2.
  induction H1; simpl; eauto.
  - remember (eqb x0 x) as Heq; destruct Heq; auto.
    symmetry in HeqHeq; apply eqb_eq in HeqHeq; subst.
    assert (Ha : B = ty) by (eapply ok_unique_type; eauto); now subst.
  - apply_fresh ATyLam' as x; auto.
    rewrite subst_source_open_var; eauto.
    apply H0.
    ST.not_in_L y.
    right; simpl; assumption.
    rewrite <- app_nil_l with (l := (ST.extend y A Gamma)).
    apply bityping_weaken; simpl; auto.
    apply ST.Ok_push; eauto.
    ST.not_in_L y.
    ST.not_in_L y.
    ST.not_in_L x.
Qed.

Lemma open_body_bityping :
  forall e A B u Gamma m, body_bityping Gamma e A B m -> bidityping Gamma u Inf A ->
                 bidityping Gamma (open_source e u) m B.
Proof.
  intros e A B u Gamma m H1 H2; destruct H1. pick_fresh y.
  assert (Ha : not (ST.M.In y x)) by ST.not_in_L y; apply H in Ha.
  rewrite <- app_nil_l with (l := Gamma).
  eapply bityping_strengthen with (z := y) (U := A).
  ST.not_in_L y; apply fv_source_distr in H3; apply MSetProperties.Dec.F.union_1 in H3.
  inversion H3; contradiction.
  rewrite subst_source_intro with (x := y).
  apply bityping_subst with (B := A).
  simpl; left; auto.
  rewrite app_nil_l; auto.
  apply bityping_weaken; simpl; auto.
  apply ST.Ok_push; eauto.
  ST.not_in_L y.
  ST.not_in_L y.
  eauto.
Qed.

(** Theorem 1. Subject reduction **)

Theorem subject_reduction :
  forall Gamma e1 A m, bidityping Gamma e1 m A ->
              forall e2, red e1 e2 ->
                    bidityping Gamma e2 m A.
Proof.
  intros Gamma e1 A m Htyping e2 Hred;
  generalize dependent A; generalize dependent Gamma; generalize dependent m.
  induction Hred; intros; try now (dependent induction Htyping; subst; eauto).
  - (* R_App3 *)
    dependent induction Htyping; subst; eauto; clear IHHtyping1 IHHtyping2.
    inversion H; subst; inversion Htyping1; subst.
    apply ATyApp' with (A := A0); auto.
    inversion Htyping2; subst.
    inversion H0.
    assert (Ha : C = A) by eauto; subst.
    eapply ATySub' with (A := A); eauto.
  - (* R_App4 *)
    dependent induction Htyping; subst; eauto.
    clear IHHtyping1 IHHtyping2.
    inversion Htyping1; subst.
    apply ATyAnnCT'; clear Htyping1.
    apply open_body_bityping with (A := A0); eauto.
    inversion H4; subst; eauto.
    inversion H0.
    dependent induction Htyping2; subst; eauto.
    inversion H2.
    assert (B = A) by eauto; now subst.
  - (* R_Ann2 *)
    dependent induction Htyping; eauto; subst; clear IHHtyping.
    dependent induction Htyping; eauto.
    inversion H1; subst; eauto.
  - (* R_AnnAbs *)
    dependent induction Htyping; subst; eauto; clear IHHtyping.
    inversion Htyping; subst.
    inversion H; subst.
    inversion H1; subst.
    apply ATyAnnCT'.
    apply_fresh ATyLam' as x; auto.
    unfold open_source; simpl.
    assert (Ha : Sub D D) by apply reflex; destruct Ha.
    assert (Ha : WFTyp A) by
        (now assert (Ha := bityping_wf _ _ _ _ H); inversion Ha).
    eapply ATySub' with (A := D); eauto 2.
    apply ATyAnnCT'.
    inversion H0; subst; clear H0.
    eapply ATySub' with (A := B); eauto 2.
    eapply ATyApp' with (A := A).
    + apply ATyAnnCT'.
      change (PLam (open_rec_source 1 (PFVar x) e)) with
             ((open_rec_source 0 (PFVar x) (PLam e))).
      rewrite <- open_rec_source_term; eauto 3.
      rewrite <- app_nil_l with (l := (ST.extend x C Gamma)).
      apply bityping_weaken; simpl; auto.
      apply ST.Ok_push; eauto.
      ST.not_in_L x.
    + assert (Ha1 : Sub A A) by apply reflex; destruct Ha1.
      eapply ATySub' with (A := A); eauto 2.
      apply ATyAnnCT'.
      eapply ATySub' with (A := C); eauto 2.
      apply ATyVar'; auto.
      apply ST.Ok_push; eauto.
      ST.not_in_L x.
      now left.
  - (* R_Ann4 *)
    dependent induction Htyping; subst; eauto; clear IHHtyping.
    destruct H.
    inversion Htyping; subst.
    inversion H2; inversion H1; subst.
    assert (B = A1) by eauto; subst; eauto.
  - (* R_Ann5 *)
    dependent induction Htyping; subst; eauto; clear IHHtyping.
    destruct H.
    inversion Htyping; subst.
    inversion H2; inversion H1; subst.
    assert (C = B0) by eauto; subst; eauto.
  - (* R_Ann6 *)
    dependent induction Htyping; subst; eauto; clear IHHtyping.
    inversion Htyping; subst.
    inversion H1; subst; try now inversion H4.
    assert (Ha : WFTyp (And A B)) by eauto; inversion Ha; subst.
    assert (Ha2 : Sub A0 A) by eauto.
    assert (Ha3 : Sub A0 B) by eauto.
    destruct Ha2, Ha3.
    apply ATyMerge'; eauto.
Qed.

(** Theorem 2. Reduction is deterministic **)

Hint Extern 1 =>
  match goal with
    | [ H : red (PLam ?e2) ?e1 |- _ ] => inversion H
    | [ H : In (PLam ?e) ?A |- _ ] => inversion H
    | [ H : In (PInt ?e) ?A |- _ ] => inversion H
  end.

Lemma value_not_red : forall e1 e2 A, In e1 A -> red e1 e2 -> False.
Proof.
  intros e1 e2 A Hin Hred. generalize dependent A.
  induction Hred; intros; inversion Hin; subst; eauto; inversion H.
Qed.

Hint Extern 1 =>
  match goal with
    | [ H1 : In ?e1 ?A,
        H2 : red ?e1 ?e2 |- _ ] => exfalso; apply (value_not_red _ _ _ H1 H2)
  end.

Lemma In_unique : forall v A B, In v A -> In v B -> A = B.
Proof.
  intros v A B HIn1 HIn2. generalize dependent B.
  induction HIn1; intros; inversion HIn2; subst; auto.
  apply IHHIn1_1 in H1; apply IHHIn1_2 in H3; now subst.
Qed.

Hint Rewrite In_unique.

(*
Lemma value_ann_red_id :
  forall v A e, In v A -> red (PAnn CT v A) e -> v = e.
Proof.
  intros v A e Hin Hred.
  dependent induction Hred; eauto.
  - inversion Hin; subst; exfalso. now apply H.
  - inversion Hin; subst; inversion H0.
  - inversion Hin; subst; inversion H0.
  - inversion Hin; subst.
    assert (Ha : And C D = And A0 B) by (eapply In_unique; eauto).
    inversion Ha; subst; contradiction.
Qed.

Hint Rewrite value_ann_red_id.
*)

Theorem red_unique :
  forall e1 e2, red e1 e2 -> forall e3, red e1 e3 -> forall Gamma A m, bidityping Gamma e1 m A -> e2 = e3.
Proof.
  intros e1 e2 Hred.
  induction Hred; intros.
  - inversion H; subst; auto.
  - inversion H; subst; auto.
    + dependent induction H0; subst; eauto; clear IHbidityping1 IHbidityping2.
      eapply IHHred in H4; subst; eauto.
    + inversion Hred; subst; auto.
  - inversion H0; subst.
    inversion H1; subst; auto.
    + dependent induction H1; eauto. clear IHbidityping1 IHbidityping2.
      eapply IHHred in H6; subst; eauto.
    + dependent induction H1; eauto.
    + dependent induction H1; eauto.
  - inversion H2; subst; auto.
    + assert (Ha : C = C0) by (eapply In_unique; eauto); subst; auto.
    + assert (Ha : Fun A1 B0 = Fun A B) by (eapply In_unique; eauto).
      inversion Ha; subst.
      assert (Ha1 : A = C) by (eapply In_unique; eauto); subst.
      exfalso; apply H1; auto.
  - inversion H0; subst; auto.
    + inversion H5; subst; auto.
    + inversion H4; subst.
      assert (Ha1 : A1 = C) by (eapply In_unique; eauto); subst.
      exfalso; apply H7; auto.
  - inversion H; subst; auto.
    + dependent induction H0; eauto; clear IHbidityping1 IHbidityping2.
      eapply IHHred in H4; subst; eauto.
  - inversion H; subst.
    dependent induction H1; eauto; clear IHbidityping1 IHbidityping2.
    inversion H; inversion H0; subst; auto.
    eapply IHHred in H14; subst; eauto.
  - dependent induction H0; eauto.
    clear IHred.
    dependent induction H2; eauto 3; clear IHbidityping.
    eapply IHHred in H0; subst; eauto.
    inversion H1; subst; inversion Hred; subst; auto.
  - inversion H0; subst; auto; inversion H.
  - dependent induction H; eauto.
    assert (Ha : In (PAnn CT (PLam e) (Fun A B)) (Fun A B)) by auto.
    apply (value_not_red _ _ _ Ha) in H0; exfalso; auto.
  - inversion H1; subst.
    dependent induction H2; subst; auto.
    inversion H2; subst; inversion H0.
    dependent induction H5; subst; eauto 3; clear IHbidityping.
    assert (Ha : And B C = And B0 C0) by (eapply In_unique; eauto); inversion Ha; subst.
    inversion H5; subst.
    assert (Ha1 : A0 = And B0 C0) by (symmetry; eauto); subst.
    inversion H6; subst.
    assert (Ha1 : ~ (Sub C0 A /\ Sub B0 A)) by eauto.
    exfalso; apply Ha1; split; assumption.
    inversion H0.
  - inversion H1; subst.
    dependent induction H2; subst; auto.
    inversion H2; subst; inversion H0.
    dependent induction H5; subst; eauto 3; clear IHbidityping.
    assert (Ha : And B C = And B0 C0) by (eapply In_unique; eauto); inversion Ha; subst.
    inversion H5; subst.
    assert (Ha1 : A0 = And B0 C0) by (symmetry; eauto); subst.
    inversion H6; subst.
    assert (Ha1 : ~ (Sub C0 A /\ Sub B0 A)) by eauto.
    exfalso; apply Ha1; split; assumption.
    inversion H0.
  - inversion H0; subst.
    inversion H0; subst; auto.
    inversion H5.
    inversion H5.
    reflexivity.
Qed.

(** Theorem 3. All typeable terms can reduce **)

Theorem typeable_terms_reduce :
  forall e1 A m, bidityping nil e1 m A -> (exists e2, red e1 e2) \/ In e1 A.
Proof.
  intros e1 A m H.
  dependent induction H; eauto.
  - inversion H0.
  - left.
    assert (Ha1 : (exists e2 : PExp, red t1 e2) \/ In t1 (Fun A B)) by eauto.
    destruct Ha1.
    destruct H1; eauto.
    assert (Ha2 : (exists e2, red t2 e2) \/ In t2 A) by eauto.
    destruct Ha2.
    destruct H2.
    inversion H1; subst.
    admit. (* *)
    admit.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
Admitted.

End Semantics.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e140m27_3limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e198m17_4limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e383m31_6limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e235m15_8limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Lists.List. Import ListNotations.
From Coq Require Import Strings.String.
Require Import NewMaps.
Require Import Smallstep.
Hint Constructors multi.

(* Language *)

Inductive ty : Type :=
| Bool : ty
| Arrow : ty -> ty -> ty
| Prod : ty -> ty -> ty
.

Notation "t1 '⇒' t2" := (Arrow t1 t2) (at level 40).

Inductive tm : Type :=
| var : string -> tm
| app : tm -> tm -> tm
| abs : string -> ty -> tm -> tm
| pair : tm -> tm -> tm
| fst : tm -> tm
| snd : tm -> tm
| tru : tm
| fls : tm
| test : tm -> tm -> tm -> tm
.

Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | var y => if eqb_string x y then s else t
  | abs y T t1 =>
      abs y T (if eqb_string x y then t1 else (subst x s t1))
  | app t1 t2 => app (subst x s t1) (subst x s t2)
  | pair t1 t2 => pair (subst x s t1) (subst x s t2)
  | fst t1 => fst (subst x s t1)
  | snd t1 => snd (subst x s t1)
  | tru => tru
  | fls => fls
  | test t0 t1 t2 =>
      test (subst x s t0) (subst x s t1) (subst x s t2)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(* Reduction *)

Inductive value : tm -> Prop :=
| v_abs : forall x T11 T12,
    value (abs x T11 T12)
| v_pair : forall v1 v2,
    value v1 ->
    value v2 ->
    value (pair v1 v2)
| v_tru : value tru
| v_fls : value fls
.

Hint Constructors value.

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
| ST_AppAbs : forall x T11 t12 v2,
    value v2 ->
    (app (abs x T11 t12) v2) --> [x := v2] t12
| ST_App1 : forall t1 t1' t2,
    t1 --> t1' ->
    (app t1 t2) --> (app t1' t2)
| ST_App2 : forall v1 t2 t2',
    value v1 ->
    t2 --> t2' ->
    (app v1 t2) --> (app v1 t2')
| ST_Pair1 : forall t1 t1' t2,
    t1 --> t1' ->
    (pair t1 t2) --> (pair t1' t2)
| ST_Pair2 : forall v1 t2 t2',
    value v1 ->
    t2 --> t2' ->
    (pair v1 t2) --> (pair v1 t2')
| ST_Fst : forall t1 t1',
    t1 --> t1' ->
    (fst t1) --> (fst t1')
| ST_FstPair : forall v1 v2,
    value v1 ->
    value v2 ->
    (fst (pair v1 v2)) --> v1
| ST_Snd : forall t1 t1',
    t1 --> t1' ->
    (snd t1) --> (snd t1')
| ST_SndPair : forall v1 v2,
    value v1 ->
    value v2 ->
    (snd (pair v1 v2)) --> v2
| ST_TestTrue : forall t1 t2,
    (test tru t1 t2) --> t1
| ST_TestFalse : forall t1 t2,
    (test fls t1 t2) --> t2
| ST_Test : forall t0 t0' t1 t2,
    t0 --> t0' ->
    (test t0 t1 t2) --> (test t0' t1 t2)
where "t1 '-->' t2" := (step t1 t2).

Notation multistep := (multi step).

Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Hint Constructors step.

Notation step_normal_form := (normal_form step).

Lemma value_normal : forall t, value t -> step_normal_form t.
Proof.
  intros.
  induction H; intros [t' ST]; inversion ST; eauto.
Qed.

(* Typing *)

Definition context := partial_map ty.

Inductive has_type : context -> tm -> ty -> Prop :=
| T_Var : forall Γ x T,
    Γ x = Some T ->
    has_type Γ (var x) T
| T_Abs : forall Γ x T11 T12 t12,
    has_type (update Γ x T11) t12 T12 ->
    has_type Γ (abs x T11 t12) (T11 ⇒ T12)
| T_App : forall T1 T2 Γ t1 t2,
    has_type Γ t1 (T1 ⇒ T2) ->
    has_type Γ t2 T1 ->
    has_type Γ (app t1 t2) T2
| T_Pair : forall Γ t1 t2 T1 T2,
    has_type Γ t1 T1 ->
    has_type Γ t2 T2 ->
    has_type Γ (pair t1 t2) (Prod T1 T2)
| T_Fst : forall Γ t T1 T2,
    has_type Γ t (Prod T1 T2) ->
    has_type Γ (fst t) T1
| T_Snd : forall Γ t T1 T2,
    has_type Γ t (Prod T1 T2) ->
    has_type Γ (snd t) T2
| T_True : forall Γ,
    has_type Γ tru Bool
| T_False : forall Γ,
    has_type Γ fls Bool
| T_Test : forall Γ t0 t1 t2 T,
    has_type Γ t0 Bool ->
    has_type Γ t1 T ->
    has_type Γ t2 T ->
    has_type Γ (test t0 t1 t2) T
.

Hint Constructors has_type.

Hint Extern 2 (has_type _ (app _ _) _) => eapply T_App; auto.

Hint Extern 2 (_ = _) => compute; reflexivity.

(* Context Invariance *)

Inductive appears_free_in : string -> tm -> Prop :=
| afi_var : forall x,
    appears_free_in x (var x)
(* Why two rules, instead of a single rule that requires free both in t1 and t2*)
| afi_app1 : forall x t1 t2,
    appears_free_in x t1 ->
    appears_free_in x (app t1 t2)
| afi_app2 : forall x t1 t2,
    appears_free_in x t2 ->
    appears_free_in x (app t1 t2)
| afi_abs : forall x y T11 t12,
    y <> x ->
    appears_free_in x t12 ->
    appears_free_in x (abs y T11 t12)
| afi_pair1 : forall x t1 t2,
    appears_free_in x t1 ->
    appears_free_in x (pair t1 t2)
| afi_pair2 : forall x t1 t2,
    appears_free_in x t2 ->
    appears_free_in x (pair t1 t2)
| afi_fst : forall x t,
    appears_free_in x t ->
    appears_free_in x (fst t)
| afi_snd : forall x t,
    appears_free_in x t ->
    appears_free_in x (snd t)
| afi_test0 : forall x t0 t1 t2,
    appears_free_in x t0 ->
    appears_free_in x (test t0 t1 t2)
| afi_test1 : forall x t0 t1 t2,
    appears_free_in x t1 ->
    appears_free_in x (test t0 t1 t2)
| afi_test2 : forall x t0 t1 t2,
    appears_free_in x t2 ->
    appears_free_in x (test t0 t1 t2)
.

Hint Constructors appears_free_in.

Definition closed (t : tm) :=
  forall x, ~ appears_free_in x t.

Lemma context_invariance : forall Γ Γ' t S,
    has_type Γ t S ->
    (forall x, appears_free_in x t -> Γ x = Γ' x) ->
    has_type Γ' t S.
Proof.
  intros. generalize dependent Γ'.
  induction H; intros Γ' Heq; eauto.
  - (* T_Var *)
    apply T_Var. rewrite <- H. symmetry. eauto.
  - (* T_Abs *)
    apply T_Abs. apply IHhas_type. intros y Hafi.
    unfold update, t_update. destruct (eqb_stringP x y).
    reflexivity. eapply Heq. eauto.
  - (* T_Pair *)
    apply T_Pair. eauto. eauto.
  - eapply T_Test. eauto. eauto. eauto.
Qed.

Lemma free_in_context : forall x t T Γ,
    appears_free_in x t ->
    has_type Γ t T ->
    exists T', Γ x = Some T'.
Proof.
  intros x t T Γ Hafi Htp.
  induction Htp; inversion Hafi; eauto; subst.
  - (* T_Abs *)
    destruct IHHtp as [T' Hctx]. eapply H4.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string in Hctx.
    exists T'. apply Hctx. apply H2.
Qed.

Corollary typable_empty_closed : forall t T,
    has_type empty t T ->
    closed t.
Proof.
  intros. unfold closed.
  intros x H1.
  destruct (free_in_context _ _ _ _ H1 H).
  inversion H0.
Qed.

(* Preservation *)

Lemma subst_preserves_typing : forall Γ x U v t S,
    has_type (update Γ x U) t S ->
    has_type empty v U ->
    has_type Γ ([x := v]t) S.
Proof with eauto.
  intros Γ x U v t S Htypt Htypv.
  generalize dependent Γ. generalize dependent S.
  induction t; intros S Γ Htypt; simpl; inversion Htypt; subst; eauto...
  - (* var *)
    rename s into y. unfold update, t_update in H1.
    destruct (eqb_stringP x y).
    + (* x = y *)
      inversion H1. subst.
      eapply context_invariance. apply Htypv.
      intros. destruct (free_in_context _ _ _ _ H Htypv). inversion H0.
    + (* x ≠ y *)
      eapply T_Var. apply H1.
  - (* abs *)
    rename s into y.
    apply T_Abs. destruct (eqb_stringP x y).
    + (* x = y *)
      eapply context_invariance.
      eapply H4. intros. unfold update, t_update. subst.
      destruct (eqb_string y x0). eauto. eauto.
    + (* x ≠ y *)
      apply IHt. eapply context_invariance. apply H4.
      intros. unfold update, t_update.
      destruct (eqb_stringP y x0). subst.
      rewrite false_eqb_string. reflexivity.
      apply n. reflexivity.
Qed.

Theorem preservation : forall t t' T,
    has_type empty t T ->
    t --> t' ->
    has_type empty t' T.
Proof with eauto.
  intros t t' T HT. remember (@empty ty) as Γ.
  generalize dependent HeqΓ. generalize dependent t'.
  induction HT; intros t' HeqΓ HE; subst; inversion HE; subst...
  - (* app *)
    inversion HE; subst...
    + apply subst_preserves_typing with T1...
      inversion HT1...
  - inversion HT...
  - inversion HT...
Qed.

(* Determinisitc *)

Lemma step_deterministic : deterministic step.
Proof.
Admitted.

(* Normalization *)

Definition halts (t : tm) : Prop :=
  exists t', t -->* t' /\ value t'.

Lemma value_halts : forall v, value v -> halts v.
Proof.
  intros v H. unfold halts.
  exists v. split.
  eauto. auto.
Qed.

(* Key in SN: find a strong enough inductive hypothesis
   For each type T, define a set R_T of closed terms of type T.
   Use a relation R and write R T t when t is in R_T.
   The sets R_T are sometimes called saturated sets or reducibility candidates.
 *)

(* strict positivity requirement:
   For inductive definitions, the type being defined must not occur to the
   left of an arrow in the type of a constructor argument.

Inductive R : ty -> tm -> Prop :=
| R_Bool : forall t, has_type empty t Bool ->
                halts t ->
                R Bool t
| R_Arrow : forall T1 T2 t, has_type empty t (T1 ⇒ T2) ->
                       halts t ->
                       (forall s, R T1 s -> R T2 (app t s)) ->
                       R (T1 ⇒ T2) t
.
 *)

Fixpoint R (T : ty) (t : tm) {struct T} : Prop :=
  has_type empty t T /\ halts t /\
  (match T with
   | Bool => True
   | (T1 ⇒ T2) => (forall s, R T1 s -> R T2 (app t s))
   | Prod T1 T2 => forall t1 t2, R T1 t1 /\ R T2 t2
   end).

Lemma R_halts : forall {T} {t}, R T t -> halts t.
Proof.
  intros. unfold R in H. destruct T.
  - inversion H. inversion H1. assumption.
  - inversion H. inversion H1. assumption.
  - inversion H. inversion H1. assumption.
Qed.

Lemma R_typable_empty : forall {T} {t}, R T t -> has_type empty t T.
Proof.
  intros.
  unfold R in H.
  destruct T; inversion H; inversion H1; assumption.
Qed.

(* Sketch:
   Need to show that every well-typed term of type T is an element of R_T;
   and R_T implies halts.
 *)

(* Membership in R_T is invariant under reduction *)

Lemma step_preserves_halting : forall t t',
    (t --> t') ->
    (halts t <-> halts t').
Proof.
  intros. split; intros; unfold halts in *.
  - destruct H0. destruct H0.
    inversion H0; subst.
    + exfalso. apply value_normal in H1.
      unfold normal_form in H1. apply H1.
      exists t'. apply H.
    + rewrite (step_deterministic _ _ _  H H2).
      exists x. eauto.
  - destruct H0. destruct H0.
    exists x. split; eauto.
Qed.

Lemma step_preserves_R : forall T t t',
    (t --> t') ->
    R T t ->
    R T t'.
Proof.
  induction T; intros; destruct H0 as [H1 [H2 H3]]; unfold R.
  - split. eapply preservation. apply H1.
    apply H. split. eapply (step_preserves_halting _ _ H).
    apply H2. apply H3.
  - fold R. split. eapply preservation. apply H1.
    apply H. split. eapply (step_preserves_halting _ _ H).
    apply H2. intros. eapply IHT2.
    apply ST_App1. apply H. apply H3.
    apply H0.
  - fold R. split. eapply preservation. apply H1.
    apply H. split. eapply (step_preserves_halting _ _ H).
    apply H2. apply H3.
Qed.

Lemma multistep_preservers_R : forall T t t',
    (t -->* t') ->
    (R T t) ->
    (R T t').
Proof.
  intros T t t' STM.
  induction STM; intros.
  - apply H.
  - apply IHSTM. eapply step_preserves_R. apply H. apply H0.
Qed.

Lemma step_preserves_R_rev : forall T t t',
    has_type empty t T ->
    (t --> t') ->
    R T t' ->
    R T t.
Proof.
  induction T; intros; unfold R in *; destruct H1; destruct H2.
  - split. apply H.
    split. eapply (step_preserves_halting _ _ H0). apply H2. apply H3.
  - fold R in *. split. apply H.
    split. eapply (step_preserves_halting _ _ H0). apply H2.
    intros. eapply IHT2. eapply T_App.
    apply H. apply R_typable_empty. apply H4. apply ST_App1. apply H0.
    apply H3. apply H4.
  - fold R in *. split. apply H.
    split. apply (step_preserves_halting _ _ H0). apply H2.
    apply H3.
Qed.

Lemma multistep_preserves_R_rev : forall T t t',
    has_type empty t T ->
    (t -->* t') ->
    R T t' ->
    R T t.
Proof.
  intros T t t' HST MST.
  induction MST.
  - eauto.
  - intros. eapply step_preserves_R_rev.
    apply HST. apply H. apply IHMST. eapply preservation.
    apply HST. apply H. apply H0.
Qed.

(* Closed instances of Term of Type T Belong to R_T *)

(* Multisubstitutions, Multi-Extensions, and Instantiations *)

(* multisubstitution *)

Definition env := list (string * tm).

Fixpoint msubst (ss : env) (t : tm) {struct ss} : tm :=
  match ss with
  | nil => t
  | (x, s)::ss' =>
    msubst ss' ([x := s] t)
  end.

(* type assignment *)

Definition tass := list (string * ty).

Fixpoint mupdate (Γ : context) (xts : tass) : context :=
  match xts with
  | nil => Γ
  | (x, v)::xts' => update (mupdate Γ xts') x v
  end.

Fixpoint lookup {X : Set} (k : string) (l : list (string * X)) {struct l} : option X :=
  match l with
  | nil => None
  | (j, x)::l' =>
    if eqb_string j k then Some x else lookup k l'
  end.

Fixpoint drop {X : Set} (n : string) (nxs : list (string * X)) {struct nxs} : list (string * X) :=
  match nxs with
  | nil => nil
  | (n', x)::nxs' =>
    if eqb_string n' n then drop n nxs'
    else (n', x) :: (drop n nxs')
  end.

(* Instantiations *)

Inductive instantiation : tass -> env -> Prop :=
| V_nil : instantiation nil nil
| V_cons : forall x T v c e,
    value v ->
    R T v ->
    instantiation c e ->
    instantiation ((x, T)::c) ((x, v)::e)
.

(* Some facts of substitution *)

Lemma vacuous_subst : forall t x,
    ~ appears_free_in x t ->
    forall t', [x := t'] t = t.
Proof.
Admitted.

Lemma subst_closed : forall t,
    closed t ->
    forall x t', [x := t']t = t.
Proof.
Admitted.

Lemma subst_not_afi : forall t x v,
    closed v -> ~ appears_free_in x ([x := v] t).
Proof.
Admitted.

Lemma duplicate_subst : forall t' x t v,
    closed v -> [x:=t]([x:=v]t') = [x:=v]t'.
Proof.
Admitted.

Lemma swap_subst : forall t x x1 v v1,
    x <> x1 ->
    closed v ->
    closed v1 ->
    [x1:=v1]([x:=v]t) = [x:=v]([x1:=v1]t).
Proof.
Admitted.

(* Properties of Multi-substitution *)

Lemma msubst_closed : forall t,
    closed t ->
    forall ss, msubst ss t = t.
Proof.
  induction ss.
  - reflexivity.
  - simpl. destruct a.
    rewrite subst_closed. apply IHss. apply H.
Qed.

Fixpoint closed_env (ρ : env) {struct ρ} :=
  match ρ with
  | nil => True
  | (x, t) :: ρ' => closed t /\ closed_env ρ'
  end.

Lemma subst_msubst : forall env x v t,
    closed v ->
    closed_env env ->
    msubst env ([x := v]t) = [x := v](msubst (drop x env) t).
Proof.
  induction env0; intros; auto.
  destruct a. simpl.
  inversion H0.
  destruct (eqb_stringP s x).
  - subst. rewrite duplicate_subst; auto.
  - simpl. rewrite swap_subst; eauto.
Qed.

Lemma msubst_var : forall ss x,
    closed_env ss ->
    msubst ss (var x) =
    match lookup x ss with
    | Some t => t
    | None => var x
    end.
Proof.
  induction ss; intros.
  - reflexivity.
  - destruct a. simpl.
    destruct (eqb_stringP s x).
    apply msubst_closed.
    inversion H. apply H0.
    apply IHss. inversion H. apply H1.
Qed.

Lemma msubst_abs: forall ss x T t,
  msubst ss (abs x T t) = abs x T (msubst (drop x ss) t).
Proof.
  induction ss; intros.
  reflexivity. destruct a.
  simpl. destruct (eqb_string s x); simpl; auto.
Qed.

Lemma msubst_app : forall ss t1 t2,
    msubst ss (app t1 t2) = app (msubst ss t1) (msubst ss t2).
Proof.
Admitted.

Lemma msubst_pair : forall ss t1 t2,
    msubst ss (pair t1 t2) = app (msubst ss t1) (msubst ss t1).
Proof.
Admitted.

(* Properties of Multi-extensions *)

Lemma mupdate_lookup : forall (c : tass) (x : string),
    lookup x c = (mupdate empty c) x.
Proof.
Admitted.

Lemma mupdate_drop : forall (c : tass) Γ x x',
    mupdate Γ (drop x c) x' =
    if eqb_string x x' then Γ x' else mupdate Γ c x'.
Proof.
Admitted.

(* Properties of Instantiations *)

Lemma instantiation_domains_match : forall {c} {e},
    instantiation c e ->
    forall {x} {T},
      lookup x c = Some T -> exists t, lookup x e = Some t.
Proof.
Admitted.

Lemma instantiation_env_closed : forall c e,
    instantiation c e -> closed_env e.
Proof. Admitted.

Lemma instantiation_R : forall c e,
    instantiation c e ->
    forall x t T,
      lookup x c = Some T ->
      lookup x e = Some t -> R T t.
Proof.
Admitted.

Lemma instantiation_drop : forall c env,
    instantiation c env ->
    forall x, instantiation (drop x c) (drop x env).
Proof. Admitted.

(* Congruence Lemmas on Multistep *)

Lemma multistep_App2 : forall v t t',
    value v ->
    (t -->* t') ->
    (app v t) -->* (app v t').
Proof.
  intros.
  induction H0.
  - constructor.
  - eapply multi_step.
    eapply ST_App2. apply H. apply H0. apply IHmulti.
Qed.

(* The R Lemma *)

Lemma msubst_preserves_typing : forall c e,
    instantiation c e ->
    forall G t S,
      has_type (mupdate G c) t S ->
      has_type G (msubst e t) S.
Proof.
Admitted.

Lemma msubst_R : forall c env t T,
    has_type (mupdate empty c) t T ->
    instantiation c env ->
    R T (msubst env t).
Proof.
Admitted.

(* The normalization theorem *)

Theorem normalization : forall t T,
    has_type empty t T ->
    halts t.
Proof.
  intros.
  replace t with (msubst nil t) by reflexivity.
  eapply R_halts.
  eapply (msubst_R nil). simpl. apply H.
  constructor.
Qed.


Require Export Basics.

Generalizable All Variables.

(* Even though we have the Category class in Category.v, the Functors
   and Monads I'm interested in reasoning about are all endofunctors on
   Coq, so there is no reason to carry around that extra machinery. *)

Class Functor (F : Type -> Type) :=
{ fobj := F
; fmap : forall {X Y}, (X -> Y) -> F X -> F Y

; fun_identity : forall {X}, fmap (@id X) = id
; fun_composition : forall {X Y Z} (f : Y -> Z) (g : X -> Y),
    fmap f ∘ fmap g = fmap (f ∘ g)
}.

Arguments fmap            [F] [Functor] [X] [Y] f g.
Arguments fun_identity    [F] [Functor] [X].
Arguments fun_composition [F] [Functor] [X] [Y] [Z] f g.

Notation "f <$> g" := (fmap f g) (at level 28, left associativity).

Notation "fmap[ M ]  f" := (@fmap M _ _ _ f) (at level 28).
Notation "fmap[ M N ]  f" := (@fmap (fun X => M (N X)) _ _ _ f) (at level 26).
Notation "fmap[ M N O ]  f" := (@fmap (fun X => M (N (O X))) _ _ _ f) (at level 24).

Coercion fobj : Functor >-> Funclass.

Lemma fun_irrelevance `(F : Functor)
  : ∀ (f g : ∀ {X Y}, (X -> Y) → (F X -> F Y))
      i i' c c',
  @f = @g →
  {| fmap := @f
   ; fun_identity    := i
   ; fun_composition := c |} =
  {| fmap := @g
   ; fun_identity    := i'
   ; fun_composition := c' |}.
Proof.
  intros. subst. f_equal.
  apply proof_irrelevance.
  apply proof_irrelevance.
Qed.

Section Functors.

  Variable F : Type -> Type.
  Context `{Functor F}.

  Theorem fun_identity_x : forall {X} (x : F X), fmap id x = id x.
  Proof.
    intros.
    rewrite fun_identity.
    reflexivity.
  Qed.

  Theorem fun_composition_x
    : forall {X Y Z} (f : Y -> Z) (g : X -> Y) (x : F X),
    f <$> (g <$> x) = (f ∘ g) <$> x.
  Proof.
    intros.
    rewrite <- fun_composition.
    reflexivity.
  Qed.

End Functors.

(* Functions are trivial functors. *)

(*
#[export]
Program Instance Hom_Functor {A} : Functor (fun X => A -> X) :=
{ fmap := fun X Y f g => f ∘ g
}.
*)

Class Natural `(Functor F) `(Functor G) := {
    transport  : ∀ {X}, F X -> G X;
    naturality : ∀ {X Y} (f : X -> Y),
      fmap f ∘ transport = transport ∘ fmap f
}.

Notation "transport/ N" := (@transport _ _ _ _ N _) (at level 24).
Notation "F ⟾ G" := (Natural F G) (at level 90, right associativity).

Lemma nat_irrelevance `(F : Functor) `(G : Functor)
  : ∀ (f g : ∀ {X}, F X -> G X) n n',
  @f = @g ->
  {| transport := @f; naturality := n |} =
  {| transport := @g; naturality := n' |}.
Proof.
  intros. subst. f_equal.
  apply proof_irrelevance.
Qed.

Class Full `(F : Functor) := {
    full_prop : ∀ {X Y} (g : F X -> F Y) (f : X -> Y), g = fmap f
}.

Class Faithful `(F : Functor) := {
    faithful_prop : ∀ {X Y} (f1 f2 : X -> Y), fmap f1 = fmap f2 -> f1 = f2
}.

Class FullyFaithful `(F : Functor) := {
    is_full :> Full F;
    is_faithful :> Faithful F;

    unfmap : ∀ {X Y}, (F X -> F Y) -> (X -> Y)
}.

#[export]
Program Instance Hom (A : Type) : Functor (fun X => A -> X) := {
    fmap := @compose _
}.

Definition hom_irrelevance : forall {A X}, (A -> X) -> Hom A X.
Proof. auto. Defined.

Definition hom_irrelevance_r : forall {A} X, Hom A X -> (A -> X).
Proof. auto. Defined.

(* Open Scope nat_scope. *)

(* Theorem distributive : forall n m o : nat, *)
(*   (n + m) * (n + o) = n * n + m * n + m * o + n * o. *)
(* Proof. *)
(*   intros. induction n; simpl. *)
(*     omega. *)
(*   rewrite Mult.mult_succ_r. *)
(*   rewrite IHn. *)
(*   repeat rewrite <- Plus.plus_assoc. *)
(*   rewrite (Plus.plus_comm o). *)
(*   rewrite (Plus.plus_comm o). *)
(*   rewrite Mult.mult_succ_r. *)
(*   rewrite Mult.mult_succ_r. *)
(*   omega. *)
(* Qed. *)

#[export]
Program Instance Hom_Full (A : Type) : Full (Hom A).
Obligation 1.
Admitted.

#[export]
Program Instance Hom_Faithful (A : Type) : Faithful (Hom A).
Obligation 1.
Admitted.

#[export]
Program Instance Hom_FullyFaithful (A : Type) : FullyFaithful (Hom A).
Obligation 1.
  pose (@full_prop _ (Hom A) _ X Y X0).
  pose (@faithful_prop _ (Hom A) _ X Y).
  apply (X0 (const X1)).
Admitted.

#[export]
Program Instance option_Functor : Functor option := {
    fmap := fun _ _ f x => match x with
      | None => None
      | Some x => Some (f x)
      end
}.
Obligation 1. extensionality x. destruct x; auto. Qed.
Obligation 2. extensionality x. destruct x; auto. Qed.

#[export]
Program Instance list_Functor : Functor list := {
    fmap := List.map
}.
Obligation 1.
  extensionality l.
  induction l; auto.
  simpl. rewrite IHl.
  reflexivity.
Qed.
Obligation 2.
  extensionality l.
  induction l; auto.
  simpl. rewrite <- IHl.
  reflexivity.
Qed.


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

Require Import List Arith Wellfounded.

Require Import wf_incl.

Set Implicit Arguments.

Section lex_sincl.

  Variable (X Y : Type) (f : X -> list Y) (R : X -> X -> Prop) (HR : well_founded R).

  Definition lex_sincl (x1 x2 : X) := sincl (f x1) (f x2) \/ incl (f x1) (f x2) /\ R x1 x2.

  Let lex_prop l : forall x, incl (f x) l -> Acc lex_sincl x.
  Proof.
    induction l as [ l IHl ] using (well_founded_induction wf_sincl).
    induction x as [ x IHx ] using (well_founded_induction HR).
    intros Hx.
    constructor.
    intros y [ (H1 & z & H2 & H3) | (H1 & H2) ].
    apply IHl with (f y).
    split.
    intros ? ?; apply Hx, H1; trivial.
    exists z; split; auto.
    apply incl_refl.
    apply IHx; auto.
    revert Hx; apply incl_tran; auto.
  Qed.

  Theorem wf_lex_sincl : well_founded lex_sincl.
  Proof.
    intros x; apply lex_prop with (f x), incl_refl.
  Qed.

End lex_sincl.

Section lex_sincl_measure.

  Variable (X Y : Type) (f : X -> list Y) (m : X -> nat).

  Definition lex_sincl_measure (x1 x2 : X) := sincl (f x1) (f x2) \/ incl (f x1) (f x2) /\ m x1 < m x2.

  Corollary wf_lex_sincl_measure : well_founded lex_sincl_measure.
  Proof.
    apply wf_lex_sincl with (R := fun x y => m x < m y), wf_inverse_image, lt_wf.
  Qed.

End lex_sincl_measure.


(* --------------------------------------------------------------------
 * (c) Copyright 2011--2012 Microsoft Corporation and Inria.
 * (c) Copyright 2012--2014 Inria.
 * (c) Copyright 2012--2014 IMDEA Software Institute.
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect ssrnat ssrbool eqtype seq.
From mathcomp Require Import fintype choice fingroup tuple perm zmodp.
From mathcomp Require Import ssrfun bigop ssralg ssrint ssrnum.
From mathcomp Require Import generic_quotient.

Require Import xseq xmatrix polyall polydec polyfrac.
Require Import fraction fracfield SsrMultinomials.freeg.
Require Import ec ecpoly eceval ecorder ecdiv ecpolyfrac.

(* -------------------------------------------------------------------- *)
Import GRing.Theory.
Import Num.Theory.
Import fraction.FracField.
Import fracfield.FracField.
Import FracInterp.

Local Open Scope ring_scope.

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

Local Notation simpm := Monoid.simpm.

(* -------------------------------------------------------------------- *)
Local Notation "n %:I" := (inord n) (at level 2, format "n %:I").

Local Notation "A ^+m n" := (map_mx ((@GRing.exp _)^~ n) A) (at level 2).
Local Notation "A %:MP"  := (map_mx polyC A) (at level 2, format "A %:MP").

(* -------------------------------------------------------------------- *)
Section BigOpToNat.
  Import Monoid.

  Lemma big_ord_to_nat
    (R : Type) (idx : R) (op : Monoid.law idx) (n : nat) (F : 'I_n.+1 -> R):
      \big[op/idx]_(i < n.+1) F i = \big[op/idx]_(0 <= i < n.+1) F i%:I.
  Proof.
    elim: n F => [|n IH] F.
      rewrite big_ord1 big_nat_recr //big_geq // mul1m.
      by congr (F _); apply/eqP; rewrite eqE /= inordK.
    rewrite big_nat_recr // big_ord_recr IH; congr (op _ _); last first.
      by congr (F _); apply/eqP; rewrite eqE /= inordK.
      rewrite !big_nat; apply: eq_bigr=> i /andP [_ le_i]; congr (F _).
    by apply/eqP; rewrite eqE /= !inordK // (ltn_trans le_i).
  Qed.
End BigOpToNat.

(* -------------------------------------------------------------------- *)
Section ECRR_2_39.
  Variable K : closedFieldType.

  Hypothesis chiN2: 2 \notin [char K].

  Local Notation simpm := Monoid.simpm.
  Local Notation sizep := (size : {poly _} -> _).

  Local Notation "x ~ i" := (x i%:I 0) (at level 8, format "x ~ i").

  Lemma L_2_39 (A : 'M[K]_(4, 2)) (b : 'cV[{poly K}]_2) (c : 'cV[{poly K}]_4):
    let: p := b~0 in
    let: q := b~1 in
         (forall (i j : 'I_4), i != j -> row_free (rows [tuple i; j] A))
      -> A%:MP *m b = c ^+m 2
      -> coprimep p q
      -> (size p <= 1)%N && (size q <= 1)%N.
  Proof.
    have:
      let: p := b~0 in
      let: q := b~1 in
           (forall (i j : 'I_4), i != j -> row_free (rows [tuple i; j] A))
        -> (exists c, A%:MP *m b = c ^+m 2)
        -> coprimep p q
        -> (size p <= 1)%N && (size q <= 1)%N;
      last by move=> H A2rfree eq_Ab_c2 cop_pq; apply: H=> //; by exists c.

    move: {-2}(b~0) (erefl (b~0)) => p Ep.
    move: {-2}(b~1) (erefl (b~1)) => q Eq.
    case: (leqP (maxn (size p) (size q)) 1).
      move=> sz_pq_1 _ _ _; apply/andP; split.
      + by apply: (leq_trans (leq_maxl (size p) (size q))).
      + by apply: (leq_trans (leq_maxr (size p) (size q))).
    move=> sz_pq; rewrite [X in X && _]leqNgt [X in _ && X]leqNgt.
    rewrite -negb_or -leq_max sz_pq /=.
    move: {2}(maxn _ _) (leqnn (maxn (size p) (size q))) sz_pq => sz.

    elim: sz A b p Ep q Eq=> [|sz IH] A b _ -> _ ->.
      by rewrite leqn0 => /eqP ->.

    move=> {c}; wlog: A b / (size (b~0) <= size (b~1))%N.
      set p := (b~0); set q := (b~1).
      move=> wlog sz_pq Ncpq A2rfree eq_Ab_c2 cop_pq.
      case: (leqP (size p) (size q)).
        by move=> leq_sz_pq; apply: (wlog A b).
      pose A' := col_perm (tperm 0%:I 1%:I) A.
      pose b' := row_perm (tperm 0%:I 1%:I) b.
      move/ltnW=> leq_sz_qp; move: (wlog A' b').
      rewrite !mxE ?(tpermL, tpermR); apply=> //; last 2 first.
      + case: eq_Ab_c2 => [c eq_Ab_c2]; exists c.
        by rewrite map_col_perm mul_col_perm -row_permM mulVg row_perm1.
      + by rewrite coprimep_sym.
      + by rewrite maxnC.
      + by rewrite maxnC.
      move=> i j ne_ij; rewrite /A' col_permE rows_mul.
      rewrite /row_free mxrankMfree; first by apply: A2rfree.
      by rewrite row_free_unit unitmx_perm.

    set p := (b~0); set q := (b~1) => le_sz_pq sz_pq Nc_pq.
    move=> A2rfree [c eq_Ab_c2] cop_pq.

    pose a (i1 i2 j : 'I_4) :=
      let M := A *m (rows [tuple i1; i2] A)^-1 in
        (sqrt (M j 0%:I), sqrt (- (M j 1%:I))).

    have fact1 (i j : 'I_4): i != j -> coprimep (c i 0) (c j 0).
      move=> ne_ij; set u := (c i 0); set v := (c j 0).
      apply/Pdiv.ClosedField.coprimepP=> x root_x_ci.
      rewrite -rootE; apply/negP=> root_x_cj.
      have root_x_c: forall k, root (c (tnth [tuple i; j] k) 0) x.
        move=> k; move: (mem_ord k); rewrite mem_seq2.
        by case/orP=> /eqP ->; rewrite (tnth_nth 0) inordK.
      move/(congr1 (rows [tuple i; j])): eq_Ab_c2.
      rewrite rows_mul; set M := (rows _ _).
      move/(congr1 (mulmx M^-1)); rewrite mulmxA mulVmx; last first.
        by rewrite /M -map_rows map_unitmx -row_free_unit A2rfree.
      rewrite mul1mx; move=> eq_b; have: forall k, root (b k 0) x.
        move=> k; move/matrixP/(_ k 0)/(congr1 (horner^~ x)): eq_b.
        rewrite !mxE big_ord_to_nat unlock /= !mxE !hornerE /=.
        by rewrite !(rootP (root_x_c _)) !simpm rootE => /eqP.
      move=> root_b_x; move/Pdiv.ClosedField.coprimepP: cop_pq.
      by move=> /(_ x (root_b_x 0%:I)); rewrite -rootE root_b_x.

    have fact2 (i j : 'I_4):
      (size (c i 0%R) <= 1 -> size (c j 0%R) <= 1 -> i = j)%N.
      move=> /size1_polyC ciE /size1_polyC cjE.
      apply/eqP; have [//|/eqP ne_ij] := (i =P j).
      move/(congr1 (rows [tuple i; j])): eq_Ab_c2.
      rewrite rows_mul -!map_rows; set M := rows _ _.
      move/(congr1 (mulmx (M^-1)%:MP)); rewrite mulmxA.
      rewrite -map_mxM /= mulVmx ?(map_mx1, mul1mx); last first.
        by rewrite -row_free_unit A2rfree.
      move/matrixP/(_~1); rewrite !mxE big_ord_to_nat /=.
      rewrite unlock /= addr0 !mxE !(tnth_nth 0) !inordK //=.
      rewrite ciE cjE -!(rmorphX, rmorphM, rmorphD).
      move: (_ + _) => z /= qE; have := Nc_pq.
      rewrite maxnC /maxn [(size _ < _)%N]ltnNge le_sz_pq /=.
      by rewrite /q qE size_polyC; case: (_ == _).

    have fact3 (i j : 'I_4): i != j -> ~~(c i 0 %= c j 0).
      move=> ne_ij; apply/negP=> eqp_ij.
      case root_ci: (hasroot (c i 0)).
        move/root1_root: root_ci=> root_ci.
        move/Pdiv.ClosedField.coprimepP: (fact1 _ _ ne_ij) => /(_ _ root_ci).
        by rewrite -rootE -(eqp_root eqp_ij) root_ci.
      move/negbT: root_ci; rewrite hasroot_size_neq1 negbK.
      move/eqp_size: eqp_ij=> size_ij size_ci.
      have := size_ci; rewrite eqn_leq andbC=> /andP [_ /fact2].
      move/(_ j); rewrite -size_ij (eqP size_ci) => /(_ (erefl true)).
      by move=> eq_ij; rewrite eq_ij eqxx in ne_ij.

    have fact4 (i : 'I_4): c i 0 != 0.
      have: exists j : 'I_4, (i != j).
        case: i=> i lt_i4; rewrite eqE /=.
        by case: i lt_i4=> [|i]; [exists 1|exists 0].
      case=> j ne_ij; apply/negP=> /eqP z_ci.
      have sz_cj: (size (c j 0%R) > 1)%N.
        rewrite ltnNge; apply/negP=> /fact2 -/(_ i).
        rewrite z_ci size_poly0 => /(_ (erefl true)).
        by move=> eq_ji; rewrite eq_ji eqxx in ne_ij.
      have/root1_root root_cj: hasroot (c j 0).
        by rewrite hasroot_size_neq1 eqn_leq leqNgt sz_cj.
      move/Pdiv.ClosedField.coprimepP: (fact1 _ _ ne_ij) => /(_ (root1 (c j 0))).
      rewrite rootE z_ci horner0 eqxx => /(_ (erefl true)).
      by rewrite -rootE root_cj /=.

    have fact5 (i1 i2 j : 'I_4) (a1 a2 : K):
         uniq [:: i1; i2; j]
      -> (c j 0) ^+ 2 = a1 *: (c i1 0) ^+ 2 + a2 *: (c i2 0) ^+ 2
      -> a1 * a2 != 0.
      move=> uq_ids eq; rewrite mulf_eq0; apply/negP=> z_a.
      wlog: i1 i2 a1 a2 z_a uq_ids eq / a1 == 0.
        move=>wlog; have/orP := z_a; case.
          by move/wlog=> /(_ i1 i2 a2 z_a uq_ids).
        move/wlog=> /(_ i2 i1 a1); rewrite addrC; apply=> //.
          by rewrite orbC.
        set s := [:: _; _; _]; have: perm_eq [:: i1; i2; j] s.
          by apply/perm_eqP=> /= P; ring.
        by move/perm_eq_uniq=> <-.
      move/eqP=> z_a1; move: eq; rewrite z_a1 scale0r add0r.
      have [->|/eqP nz_a2 eq] := (a2 =P 0).
        by move/eqP; rewrite scale0r expf_eq0 /= (negbTE (fact4 j)).
      move/eqP: eq; rewrite -[a2]sqr_sqrt -mul_polyC polyC_exp -exprMn.
      rewrite -subr_eq0 subr_sqr mulf_eq0 subr_eq0 addr_eq0.
      rewrite mul_polyC -scaleNr => eq.
      have: exists b:bool, c j 0 = ((-1) ^+ b * (sqrt a2)) *: (c i2 0).
        case/orP: eq=> eq; [exists false|exists true].
        + by rewrite expr0 mul1r; apply/eqP.
        + by rewrite expr1 mulN1r; apply/eqP.
      case=> s cjE; have: c j 0 %= c i2 0.
        apply/eqpP; exists (1, (-1) ^+ s * (sqrt a2))=> /=.
          rewrite oner_eq0 /= mulf_eq0 expf_eq0 oppr_eq0 oner_eq0.
          by rewrite andbF /= sqrt_eq0.
        by rewrite scale1r.
      move=> eqp_ji2; have/fact3: (j != i2).
        by rewrite (@nth_uniq _ 0 _ 2 1 _ _ uq_ids).
      by rewrite eqp_ji2.

    have fact6 (i1 i2 j : 'I_4):
      uniq [:: i1; i2; j] ->
        (c j 0)^+2 =   ((a i1 i2 j).1 *: (c i1 0))^+2
                     - ((a i1 i2 j).2 *: (c i2 0))^+2.
      pose ids := [:: i1; i2; j] => uq_idx.
      pose M := rows [tuple i1; i2] A.
      have/(congr1 (rows [tuple i1; i2])) := eq_Ab_c2.
      rewrite rows_mul -!map_rows -/M => /(congr1 (mulmx (M^-1)%:MP)).
      rewrite mulmxA -map_mxM /= mulVmx; last first.
        by rewrite -row_free_unit A2rfree // (@nth_uniq _ 0 ids 0 1).
      rewrite map_mx1 mul1mx => eq_b; move/matrixP/(_ j 0): eq_Ab_c2.
      rewrite eq_b mulmxA; rewrite -map_mxM /=; set N := (A *m _).
      move: N=> N; rewrite !mxE big_ord_to_nat unlock /= addr0.
      rewrite !mxE !(tnth_nth 0) !inordK //= => <-.
      by rewrite !exprZn !mul_polyC !sqr_sqrt scaleNr opprK.

    have fact7 (i1 i2 j : 'I_4): uniq [:: i1; i2; j] ->
        (a i1 i2 j).1 * (a i1 i2 j).2 != 0.
      move=> uq; have/fact6 := uq; case: (a i1 i2 j)=> a1 a2 /=.
      rewrite !exprZn -scaleNr => /fact5 -/(_ uq).
      by rewrite mulf_eq0 oppr_eq0 !expf_eq0 /= mulf_eq0.

    have fact8 (i1 i2 j : 'I_4): uniq [:: i1; i2; j] ->
      let (a1, a2) := a i1 i2 j in
        coprimep
          (a1 *: (c i1 0) + a2 *: (c i2 0))
          (a1 *: (c i1 0) - a2 *: (c i2 0)).

      move=> uq; case aE: (a _ _ _)=> [a1 a2] /=.
      move: (fact7 _ _ _ uq); rewrite aE /= mulf_eq0=> /norP [nz_a1 nz_a2].
      apply/Pdiv.ClosedField.coprimepP=> x; rewrite rootE !hornerE => root_x_s1.
      case root_x_ci2: (root (c i2 0) x).
        have := root_x_ci2; rewrite rootE => /eqP ->; rewrite mulr0 subr0.
        rewrite mulf_eq0 (negbTE nz_a1) /=.
        apply/(Pdiv.ClosedField.coprimepP (c i2 0))=> //.
        by apply: fact1; rewrite (@nth_uniq _ 0 _ 1 0 _ _ uq).
      rewrite -(eqP root_x_s1); apply/negP=> /eqP /addrI.
      move/esym/eqP; rewrite -addr_eq0 -mulr2n -mulr_natl.
      have := chiN2; rewrite !mulf_eq0 inE /= => /negbTE -> /=.
      by rewrite (negbTE nz_a2) /= -rootE root_x_ci2.

    pose u := c~0; pose v := c~1.

    pose A' :=
      \matrix_(i < 4, j < 2)
        let: (a1, a2) := a 0%:I 1%:I (2 + i./2)%:I in
          [:: a1; (-1)^+(odd i) * a2]`_j.
    pose b' := [col u; v].

    have uniqD_r (k : 'I_2):
      uniq ([:: 0%:I; 1%:I; (2 + k)%:I] : seq 'I_4).
      by case: k => k lt_k2; rewrite -(map_inj_uniq val_inj) /= !inordK.

    apply: (IH A' b' u _ v _); last 2 first.
    + have H (k : 'I_2) (sg : bool):
        let: a := a 0%:I 1%:I (2 + k)%:I in
          exists r : {poly K}, a.1 *: u + ((-1)^+sg * a.2) *: v == r ^+ 2.
        case aE: (a _ _ _) => [a1 a2]; move: (fact6  _ _ _ (uniqD_r k)).
        rewrite aE /= subr_sqr mulrC => eq_c2; case: (cf_copsqr _ _ eq_c2).
        + by rewrite fact4.
        + by move: (fact8 _ _ _ (uniqD_r k)); rewrite aE.
        have := eq_c2; rewrite mulrC; case/(cf_copsqr _ _).
        + by rewrite fact4.
        + by move: (fact8 _ _ _ (uniqD_r k)); rewrite coprimep_sym aE.
        move=> r2 /esym r2E r1 /esym r1E; case: sg.
        + by exists r2; rewrite expr1 mulN1r scaleNr r2E.
        + by exists r1; rewrite expr0 mul1r r1E.
        pose c' := \col_(i < 4) xchoose (H (i./2)%:I (odd i)); exists c'.
        apply/matrixP=> i j; rewrite !mxE big_ord_to_nat unlock /= addr0.
        rewrite ![b' _ _]mxE ord1 !(tnth_nth [tuple 0]) 2?inordK /tnth //=.
        rewrite ![A'%:MP _ _]mxE ![A' _ _]mxE; case aE: (a _ _ _) => [a1 a2].
        rewrite ![_ _%:I]inordK //=; move: (xchooseP (H (i./2)%:I (odd i))).
        move/eqP=> <-; rewrite !inordK ?aE //=; last first.
          by rewrite ltnS (half_leq (n := 3)) // -ltnS.
        by rewrite !mul_polyC.
    + by apply: fact1; rewrite eqE /= !inordK.
    + by rewrite !mxE !(tnth_nth [tuple 0]) !inordK.
    + by rewrite !mxE !(tnth_nth [tuple 0]) !inordK.
    + have szc i: (size (c i 0%R) < (maxn (size p) (size q)))%N.
        rewrite maxnC /maxn [(size q < _)%N]ltnNge le_sz_pq /=.
        rewrite -ltn_double -[X in (X < _)%N]prednK; last first.
          by rewrite double_gt0 lt0n size_poly_eq0 fact4.
        rewrite -addnn -size_mul ?fact4 // -expr2.
        move/matrixP/(_ i 0)/(congr1 sizep)/esym: eq_Ab_c2.
        rewrite mxE=> ->; rewrite !mxE big_ord_to_nat unlock /=.
        rewrite addr0 -/p -/q; case sz_q: (size q) => [|szq].
          move: le_sz_pq Nc_pq; rewrite sz_q leqn0 => /eqP ->.
          by rewrite maxnn.
        rewrite doubleS /= !ltnS; apply: (leq_trans (size_add _ _)).
        apply: (@leq_trans (maxn (size p) (size q))).
          rewrite geq_max !leq_max ![_%:MP _ _]mxE !mul_polyC.
          by rewrite !size_scale_leq !simpm.
        rewrite maxnC /maxn [(size q < _)%N]ltnNge le_sz_pq /= sz_q.
        rewrite -addnn -{1}[szq]add0n ltn_add2r lt0n.
        apply/negP=> /eqP z_szq; move: le_sz_pq Nc_pq.
        by rewrite sz_q z_szq maxnC /maxn [(1 < size p)%N]ltnNge => ->.
      by rewrite geq_max -![(_ <= sz)%N]ltnS !(leq_trans (szc _)).
    + rewrite ltnNge geq_max; apply/negP=> /andP [Cu Cv].
      by move/eqP: (fact2 _ _ Cu Cv); rewrite eqE /= !inordK.
    + move=> i j ne_ij; rewrite row_free_unit unitmxE unitfE.
      rewrite det2 !mxE; set cf := a _ _; rewrite [cf]lock.
      rewrite !(tnth_nth 0) !inordK //= -lock /cf => {cf}.
      case: (i./2 =P j./2)=> [eq_div2_ij|/eqP ne_div2_ij].
      * rewrite -eq_div2_ij; case aE: (a _ _ _) => [a1 a2].
        have ->: (-1) ^+ (odd j) = -(-1) ^+ (odd i) :> K.
          case: (odd i =P odd j) => [eq_odd_ij|/eqP ne_odd_ij].
            move: (odd_double_half (val j)); rewrite -eq_odd_ij -eq_div2_ij.
            by move/eqP; rewrite odd_double_half (inj_eq val_inj) (negbTE ne_ij).
          move: ne_odd_ij; rewrite negb_add => /eqP <-.
          by rewrite signrN.
        rewrite mulrCA -mulrA [a2 * a1]mulrC -mulrBl !mulf_eq0.
        move: (fact7 _ _ _ (uniqD_r (i./2)%:I)).
          rewrite inordK; last first.
            by rewrite ltnS (half_leq (n := 3)) // -ltnS.
          rewrite aE /= mulf_eq0 => /norP [/negbTE-> /negbTE->].
          rewrite !simpm -opprB oppr_eq0 opprK -mulr2n -mulr_natl.
          have := chiN2; rewrite mulf_eq0 inE /= => /negbTE -> /=.
          by rewrite expf_eq0 oppr_eq0 oner_eq0 andbF.
      * case aE: (a _ _ _) => [a1 a2]; case a'E: (a _ _ _) => [a'1 a'2].
        rewrite subr_eq0; apply/negP=> /eqP /(congr1 (fun x => x^+2)).
        rewrite !exprMn !sqrr_sign !mul1r => eqa.
        have id2_ord2: (i./2 < 2)%N by rewrite ltnS (half_leq (n := 3)) // -ltnS.
        have jd2_ord2: (j./2 < 2)%N by rewrite ltnS (half_leq (n := 3)) // -ltnS.
        have := fact7 _ _ _ (uniqD_r (Ordinal id2_ord2)).
        have := fact7 _ _ _ (uniqD_r (Ordinal jd2_ord2)).
        rewrite aE a'E /= !mulf_eq0=> /norP [_ nz_a2] /norP [_ nz_a'2].
        have: (c (2 + i./2)%:I 0) ^+ 2 %= (c (2 + j./2)%:I 0) ^+ 2.
          apply/eqpP; exists (a'2 ^+ 2, a2 ^+ 2).
            by rewrite !expf_eq0 /= nz_a2 nz_a'2.
          move: (fact6 _ _ _ (uniqD_r (Ordinal id2_ord2))).
          move: (fact6 _ _ _ (uniqD_r (Ordinal jd2_ord2))).
          rewrite aE a'E /= => -> ->; rewrite !exprZn.
          by rewrite !scalerBr !scalerA ![a'2 ^+ 2 * _]mulrC eqa.
        move=> cij_prop; have: c (2 + i./2)%:I 0 %= c (2 + j./2)%:I 0.
          case/eqpP: cij_prop=> [[z1 z2] /= nz_z].
          rewrite -[z1]sqr_sqrt -[z2]sqr_sqrt -!exprZn.
          case/sqr_eqr_sign=> s; rewrite -polyC_opp -polyC_exp.
          rewrite mul_polyC scalerA => eqc; apply/eqpP.
          exists (sqrt z1, (-1) ^+ s * (sqrt z2))=> //=.
          by rewrite mulf_eq0 expf_eq0 oppr_eq0 oner_eq0 !sqrt_eq0 andbF.
        by apply/negP; rewrite fact3 // eqE /= !inordK ?(leq_add2l 2).
  Qed.
End ECRR_2_39.

(* -------------------------------------------------------------------- *)
Module DetFree.
Section ModuleSec.
  Variable K : fieldType.
  Variable p : nat.

  Variable cs : p.-tuple K.
  Variable c  : K.

  Hypothesis uniq_cs: uniq cs.
  Hypothesis nz_c : c != 0.

  Local Notation "n %:I" := (inord n) (at level 2, format "n %:I").

  Definition A :=
    let t := [tuple [tuple 1; tnth cs i] | i < p] in
      mxdefE [tuple of rcons t [tuple 0; c]].

  Lemma detfree:
    forall (i j : 'I_p.+1), i != j -> row_free (rows [tuple i; j] A).
  Proof.
    pose B :=
      \matrix_(i < p.+1, j < 2)
        (if (i < p)%N then [:: 1; cs`_i] else [:: 0; c])`_j.
    have eq_AB: A = B.
      apply/matrixP; case=> i lt_iSp j; rewrite !mxE.
      rewrite !(tnth_nth [tuple 0; 0]) !(tnth_nth 0) /=.
      rewrite nth_rcons size_map size_enum_ord.
      move: lt_iSp; rewrite ltnS leq_eqVlt; case/orP.
        by move/eqP=> ->; rewrite ltnn eqxx.
      move=> lt_ip; rewrite lt_ip (nth_map (Ordinal lt_ip)); last first.
        by rewrite size_enum_ord.
      by rewrite (tnth_nth 0) nth_enum_ord.
    move=> i j; wlog: i j / (i < j)%N.
      move=> wlog; case cmp_ij: (i < j)%N; first by apply: wlog.
      move=> ne_ij; have: (j < i)%N; last move=> lt_ji.
        by rewrite ltn_neqAle eq_sym ne_ij leqNgt cmp_ij.
      have: (row_free (rows [tuple j; i] A)).
        by apply: wlog; rewrite ?[j == i]eq_sym.
      set s : 'S_2 := tperm 0%:I 1%:I; rewrite /row_free.
      rewrite -(mxrank_row_perm s) row_perm_rows.
      move/eqP=> rkpermA; rewrite -[X in _ == X]rkpermA => {rkpermA}.
      apply/eqP; congr (\rank (rows _ A)); apply: eq_from_tnth.
      move=> k; have: ((k == 0%:I) || (k == 1%:I)).
        by case: k=> [[|[|k //]] /= lt_k2]; rewrite eqE /= !inordK.
      case/orP=> /eqP -> {k}; rewrite tnth_mktuple !(tnth_nth 0);
        by rewrite /s ?(tpermL, tpermR) !inordK.
    move=> lt_ij ne_ij; rewrite row_free_unit unitmxE unitfE det2 !rowsE.
    rewrite !(tnth_nth 0) !inordK //= eq_AB !mxE !inordK //.
    have lt_ip: (i < p)%N.
      by rewrite (leq_trans lt_ij) // -ltnS.
    case: (ltnP j p) => [lt_jp|].
      rewrite lt_ip /= mul1r mulr1 subr_eq0.
      by rewrite eq_sym nth_uniq ?size_tuple.
    by move=> _; rewrite lt_ip /= mulr0 mul1r subr0.
  Qed.
End ModuleSec.
End DetFree.

Lemma MA_E (K : fieldType) (a b c k : K):
  let A := [matrix [:: 1; a]; [:: 1; b]; [:: 1; c]; [:: 0; k]] in
  let p := [tuple a; b; c] in
    DetFree.A p k = A.
Proof.
  move=> A p; apply/matrixP=> k1 k2.
  rewrite /DetFree.A /A /mxdefE !mxE ; congr (tnth (tnth _ _) _) => {k1 k2}.
  apply/eqP; rewrite eqE /=; pose f (i : nat) := [tuple 1; p`_i].
  rewrite (iffLR (eq_in_map _ (f \o val) _)); last first.
    by move=> m _ /=; rewrite (tnth_nth 0).
  by rewrite /f map_comp val_enum_ord.
Qed.

Lemma row_freeA:
  forall (K : fieldType) (a b c k : K), uniq [:: a; b; c] -> k != 0 ->
    let A := [matrix [:: 1; a]; [:: 1; b]; [:: 1; c]; [:: 0; k]] in
      forall (i j : 'I_4), i != j -> row_free (rows [tuple i; j] A).
Proof.
  move=> K a b c k uq nz_k A i j ne_ij; set p := [tuple a; b; c].
  have uq_p: uniq p by apply: uq. move: (DetFree.detfree uq_p nz_k ne_ij).
  by have ->: DetFree.A p k = A by apply MA_E.
Qed.

(* -------------------------------------------------------------------- *)
Section ECRR_2_38.
  Variable K : ecuDecFieldType.
  Variable E : ecuType K.

  Notation Xpoly   := (@Xpoly K E).
  Notation ecpoly  := (@ecpoly K E).
  Notation oncurve := (@oncurve K E).

  Notation "f .[ x , y ]" := (eceval f x y).
  Notation "p %:E" := (ECPoly E (0, p)).

  Local Notation "n %:I" := (inord n) (at level 2, format "n %:I").

  Implicit Types f : ecpoly.

  Hypothesis closedK : GRing.ClosedField.axiom K.

  Local Notation clK := (ClosedFieldType K closedK).

  Import PreClosedField.

  Local Notation PEF := (@tofrac _ \o ((ecX E) \o polyC)).
  Local Notation "x %:PEF" := (PEF x) (at level 2).

  Local Notation "x %:F"  := (tofrac x).
  Local Notation "x // y" := (x%:F / y%:F) (at level 50, no associativity).

  Local Notation sizep := (size : {poly _} -> _).

  Local Notation "p ^:F" := (map_poly (@tofrac _ \o polyC) p)
    (at level 2, format "p ^:F") : ring_scope.

  Import fraction.

  Lemma L_2_38 (p q u v: {poly K}):
    (size p > 1)%N || (size q > 1)%N ->
    (size u > 1)%N || (size v > 1)%N ->
    coprimep p q -> coprimep u v ->
    q \is monic -> v \is monic ->
      u^+2 * q^+3 != v^+2 * (p^+3 + (E #a)*:p * q^+2 + (E #b)*: q^+3).
  Proof.
    move=> sz_p sz_u cop_pq cop_uv q_monic v_monic.
    set J := (_ + _); apply/negP=> /eqP eq; have: v^+2 %= q^+3.
      rewrite /eqp -(Gauss_dvdpr _ (q := u ^+ 2)); last first.
        by rewrite !(coprimep_expr, coprimep_expl) 1?coprimep_sym.
      rewrite eq dvdp_mulIl /= -(Gauss_dvdpl _ (q := J)).
        by rewrite -eq dvdp_mulIr.
      rewrite coprimep_expl // /J; apply/(@Pdiv.ClosedField.coprimepP clK)=> x.
        rewrite rootE !(horner_exp, hornerE) => /eqP root_q_x /=.
        rewrite root_q_x !simpm expf_eq0 /=; apply/negP=> root_p_x.
        move/(@Pdiv.ClosedField.coprimepP clK)/(_ _ root_p_x): cop_pq.
        by rewrite root_q_x eqxx.
    move=> v2E; have/eqpfP := v2E; rewrite !lead_coef_exp (eqP q_monic) (eqP v_monic).
    rewrite !expr1n !scale1r => /esym q3E.
    have h: forall x, \mu_x (q^+3) = \mu_x (v^+2).
      by move=> x; move/(congr1 (fun r => \mu_x r)): q3E.
    have {h} h: forall x, ~~ (odd (\mu_x q)).
      move=> x; apply/negP => odd_muqx; have: odd (3 * \mu_x q)%N.
        by rewrite odd_mul odd_muqx.
      by rewrite -mulnC -mu_exp h mu_exp muln2 odd_double.
    have: q = (\prod_(c <- undup (roots q)) ('X - c%:P)^+(\mu_c q)./2)^+2.
      rewrite {1}[q]PolyClosed.roots_factor_theorem_mu_f //.
      rewrite (eqP q_monic) scale1r expr2 -big_split /=.
      apply: eq_bigr => c _; rewrite -exprD addnn.
      move: (odd_double_half (\mu_c q)); rewrite (negbTE (h _)) add0n.
      by move=> {1}<-.
    move: (\prod_(_ <- _) _) => qsrt qE.
    case/eqpf_eq: v2E=> c nz_c v2E; move: eq; rewrite v2E => /eqP {v2E}.
    rewrite -mul_polyC [X in _ == X]mulrAC (inj_eq (mulIf _)); last first.
      by rewrite expf_eq0 /= monic_neq0.
    rewrite /J; wlog: u c nz_c sz_u cop_uv / (c == 1).
      move=> wlog /eqP /(congr1 ( *%R (c^-1)%:P)).
      rewrite [X in _ = X]mulrA -polyC_mul mulVf //.
      rewrite -[c^-1](@sqr_sqrt clK) polyC_exp -exprMn.
      move/eqP/wlog; apply; rewrite ?oner_eq0 // mul_polyC.
        by rewrite size_scale // (@sqrt_eq0 clK) invr_eq0.
      by rewrite coprimep_scalel // (@sqrt_eq0 clK) invr_eq0.
      move/eqP=> ->; rewrite mul1r -/J.
      move: (Xpoly_factor E closedK); case=> cs uq_cs.
    pose csn i := tnth cs i; rewrite (big_nth 0) size_tuple => eq_Xpoly {c nz_c}.
    have (i j : 'I_3): i != j -> coprimep (p - (csn i) *: q) (p - (csn j) *: q).
      move=> ne_ij; apply/(@Pdiv.ClosedField.coprimepP clK)=> k; move=> root_i.
      apply/negP; rewrite -rootE => root_j.
      have := root_j; have := root_i; rewrite !rootE !hornerE.
      rewrite subr_eq0 => /eqP ->; rewrite -mulrBl mulf_eq0.
      rewrite subr_eq0 /csn !(tnth_nth 0) nth_uniq ?size_tuple //.
      rewrite (inj_eq val_inj) (negbTE ne_ij) /= => root_q.
      have := root_i; rewrite rootE !hornerE (eqP root_q) mulr0 subr0.
      move=> root_p; move/(@Pdiv.ClosedField.coprimepP clK): cop_pq => /(_ k).
      by rewrite rootE root_p root_q /= => /(_ (erefl true)).
    move=> cop_p_sub_iq eq; have (i : 'I_3): exists r, (p - (csn i) *: q) == r^+2.
      pose P1 := \prod_(c <- cs | c != csn i) (p - c *: q).
      case: (@cf_copsqr clK u (p - (csn i) *: q) P1).
      + apply/eqP=> z_u; move: (cop_uv); rewrite z_u coprime0p.
        rewrite -size_poly_eq1 => /eqP sz_v; move: sz_u.
        by rewrite sz_v ltnn orbF z_u size_poly0.
      + rewrite /P1 -big_filter -(big_map (fun i => (p - i *: q)) xpredT id).
        rewrite coprimep_prod; apply/allP=> r /mapP [c].
        rewrite mem_filter => /andP [ne_ci c_in_cs] -> {r} /=.
        case/(nthP 0): c_in_cs=> j j_lt_sz cE; move: (cop_p_sub_iq i (inord j)).
        rewrite /csn !(tnth_nth 0) inordK -?(size_tuple cs) // -cE.
        apply; rewrite eqE /= inordK -?(size_tuple cs) //.
        rewrite -(@nth_uniq _ 0 _ i j _ _ uq_cs) // ?size_tuple //.
        by move: ne_ci; rewrite cE eq_sym /csn !(tnth_nth 0).
      + rewrite /P1 -(bigD1_seq (csn i)) //=; last by rewrite /csn mem_tnth.
        rewrite (eqP eq) /J; move/(congr1 (fun p => p^:F)): eq_Xpoly.
        pose C  := GRing.comp_rmorphism (tofrac_rmorphism _) (polyC_rmorphism _).
        pose E' := ec_of_ecmorph E (C K).
        have ->: Xpoly^:F = ec.Xpoly E' by rewrite map_XpolyE /= XpolyE.
        move/(congr1 (fun r => r.[p // q])); rewrite horner_Xpoly.
        move/(congr1 (fun x => x * q%:F^+3)); rewrite !mulrDl.
        rewrite expr_div_n [_*_^+3]mulrAC -[_*_/_]mulrA divff; last first.
          by rewrite expf_neq0 // tofrac_eq0 monic_neq0.
        rewrite mulr1 -[_*_^+3]mulrA -[_*_^+3]mulrA -exprN1.
        rewrite !exprnP -expfzDr ?(tofrac_eq0, monic_neq0) //.
        have ->: (-1 + 3%:Z) = 2 by []; rewrite -!exprnP.
        rewrite -!(tofracX, tofracM, tofracD) /= [_%:P * _]mulrA !mul_polyC.
        rewrite rmorph_prod /= horner_prod.
        rewrite (eq_bigr (fun i => (p - (cs`_i) *: q) // q)); last first.
          move=> j _; rewrite rmorphB /= !(map_polyX, map_polyC) !hornerE /=.
          rewrite tofracB exprN1 mulrDl mulNr -mul_polyC.
          by rewrite tofracM -mulrA divff ?(tofrac_eq0, monic_neq0) // mulr1.
        rewrite big_split /= big_const_seq /= mulr1 -!invfM -expr2 -exprS.
        rewrite tofracX [_*_^+3]mulrAC -[_*_^-1]mulrA divff; last first.
          by rewrite expf_neq0 // tofrac_eq0 monic_neq0.
        move/eqP; rewrite mulr1 -rmorph_prod /= tofrac_eq => /eqP->.
        by rewrite (big_nth 0) size_tuple.
      by move=> r /eqP Er2; exists r.
    move=> cE; set opprcs := [tuple of (map -%R cs)].
    set c := \col_(i < 4) (if i < 3 then xchoose (cE (inord i)) else qsrt)%N.
    have xchP: forall (j : 'I_3), p - (csn j)%:P * q = xchoose (cE j) ^+ 2.
      by move=> j; move: (xchooseP (cE j)) => /eqP; rewrite mul_polyC.
    have chi2: 2 \notin [char K].
      by rewrite inE /= ecu_chi2.
    move: (@L_2_39 clK chi2 (DetFree.A opprcs 1) [col p; q] c).
    rewrite ![[col p; q] _ _]mxE !(tnth_nth [tuple 0]) !inordK //=.
    rewrite !(tnth_nth 0) /= ![(size _ <= _)%N]leqNgt -negb_or sz_p /=.
    move=> H; absurd false=> //; apply H => {H} //.
    + by apply: DetFree.detfree; rewrite ?oner_eq0 // uniq_map //; exact: oppr_inj.
    apply/matrixP=> i j; rewrite ord1 => {j}.
    have ->: opprcs = [tuple -(csn 0%:I); -(csn 1%:I); -(csn 2%:I)].
      rewrite /csn /opprcs; case: {uq_cs cop_p_sub_iq csn eq_Xpoly cE opprcs c xchP} cs.
      case=> [|c1 [|c2 [|c3 [|]]]] //= er; rewrite !(tnth_nth 0) !inordK //=.
      by apply/eqP; rewrite eqE /=.
    rewrite MA_E !mxE big_ord_to_nat unlock /= addr0.
    rewrite ![[col p; q] _ _]mxE !(tnth_nth [tuple 0]) !inordK //=.
    rewrite !(tnth_nth 0) /= !mxE !(tnth_nth [tuple 0; 0]) /= !(tnth_nth 0).
    rewrite !inordK //; case: i; case=> [|[|[|[|i]]]] /=;
      try solve [by [] | by move=> _; rewrite mul1r polyC_opp mulNr xchP].
    by move=> _; rewrite mul0r add0r mul1r qE.
  Qed.

  Require Import fraction.
  Import FracInterp.

  Lemma L_2_38_fec (r s : {fraction {poly K}}):
       ~~ (isfcnt r)
    -> ~~ (isfcnt s)
    -> r ^+ 2 != s ^+ 3 + ((E #a)%:P)%:F * s + ((E #b)%:P)%:F.
  Proof.
    elim/fracredW: r => n1 d1 cop_1 d1_monic Ncct1.
    elim/fracredW: s => n2 d2 cop_2 d2_monic Ncct2.
    have [size_1 size_2] := (isfnctN_size Ncct1, isfnctN_size Ncct2).
    move: (L_2_38 size_2 size_1 cop_2 cop_1 d2_monic d1_monic) => h.
    rewrite !expr_div_n -!tofracX; apply/eqP => /(congr1 (fun x => x * (d1^+2)%:F)).
    rewrite -mulrA [_^-1*_]mulrC divff ?mulr1; last first.
      by rewrite tofrac_eq0 expf_neq0 // monic_neq0.
    rewrite [X in _ = X]mulrC => /(congr1 (fun x => x * (d2^+3)%:F)).
    rewrite -tofracM -[X in _ = X]mulrA !mulrDl -[_ * (d2^+3)%:F]mulrA.
    rewrite [_^-1*_]mulrC divff ?mulr1; last first.
      by rewrite tofrac_eq0 expf_neq0 // monic_neq0.
    rewrite -[(_ * (n2//d2)) * _]mulrA [(n2//d2)*_]mulrAC.
    rewrite {1}[(d2^+3)%:F]tofracX -exprN1 [_%:F^+3]exprnP -[_*_^(-1)]mulrA.
    rewrite -expfzDr ?(tofrac_eq0, monic_neq0) //= -exprnP.
    rewrite -!(tofracX, tofracM, tofracD) mulrA !mul_polyC.
    by move/eqP; rewrite tofrac_eq => /eqP eq; move: h; rewrite eq eqxx.
  Qed.
End ECRR_2_38.

(* -------------------------------------------------------------------- *)
Section L_2_40_base.
  Variable K : ecuDecFieldType.
  Variable E : ecuType K.

  Notation Xpoly   := (@Xpoly K E).
  Notation ecpoly  := (@ecpoly K E).
  Notation oncurve := (@oncurve K E).
  Notation "f .[ x , y ]" := (eceval f x y).
  Notation "p %:E" := (ecX E p).

  Implicit Types f : {fraction ecpoly}.
  Hypothesis closedK : GRing.ClosedField.axiom K.
  Import PreClosedField.

  Local Notation clK := (ClosedFieldType K closedK).
  Local Notation PEF := (@tofrac _ \o ((ecX E) \o polyC)).
  Local Notation "x %:PEF" := (PEF x) (at level 2).
  Local Notation "x %:F"  := (tofrac x).
  Local Notation "x // y" := (x%:F / y%:F) (at level 50, no associativity).

  Local Notation "\- x"   := (FracInterp.opp x).
  Local Notation "x \+ y" := (FracInterp.add x y).
  Local Notation "x \* y" := (FracInterp.mul x y) (at level 30).
  Local Notation "x \^-1" := (FracInterp.gginv x) (at level 20).

  Local Notation neq0 := (mulf_neq0, invr_eq0, ecX_eq0, tofrac_eq0, conjp_eq0).

  Local Hint Extern 0 (is_true (ec.Xpoly _ != 0)) => exact: XpolyN0.

  Notation "f \Fo g"  := (comp_frac_fec f g).
  Notation "f \PFo g" := (comp_poly_fec g f).

  Local Notation "'Y" := [ecp 1 *Y + 0].

  Variable h : {fraction ecpoly}.
  Variable P : point K.
  Variable Q : point K.

  Hypothesis divhE : ecdiv h = << P >> - << Q >>.

  Lemma L_2_40_base: P = Q.
  Proof.
    have [->|ne_PQ] := eqVneq P Q; first by [].
    (* Some properties about h:
     * - order h R =  1 if R = P
     *             = -1 if R = Q
     *             =  0 otherwise
     * - h is not constant (as a fraction)
     * - P/Q are on the curve *)
    have ordhE: forall R, order h R = (R == P)%:Z - (R == Q)%:Z.
      move=> R; rewrite -ecdiv_coeffE divhE coeffB !coeffU.
      by rewrite !mul1r ![_ == R]eq_sym !natz.
    have ordhP: order h P = 1.
      by move: (ordhE P); rewrite (negbTE ne_PQ) eqxx subr0.
    have ordhQ: order h Q = -1.
      by move: (ordhE Q); rewrite eq_sym (negbTE ne_PQ) eqxx sub0r.
    have ordhNPQ R: R != P -> R != Q -> order h R = 0.
      move=> ne_PR ne_QR; move: (ordhE R);
        by rewrite (negbTE ne_PR) (negbTE ne_QR) subrr.
    have Ncct_h: ~~ (constant_fraction h).
      by apply: (constant_fraction_order0 (P := P)); rewrite ordhP.
    have oncveQ: oncurve Q.
      rewrite -[_ _ _]negbK; apply/negP;
        by move/(order_outcve h); rewrite ordhQ.
    have oncveP: oncurve P.
      rewrite -[_ _ _]negbK; apply/negP;
        by move/(order_outcve h); rewrite ordhP.
    have nz_h: h != 0.
      by apply/negP=> /eqP z_h; rewrite z_h order0 in ordhP.

    (* hR is the function associating h - h.(R) to R.
     * For a fixed S, (hR S) has the following properties
     * - it is not constant (as a fraction)
     * - its divisor is <<S>> - <<Q>> if S is on the curve and not equal to Q *)
    pose hR R := h - (evalK R h)%:PEF.
    have nz_hR R: hR R != 0.
      rewrite /hR subr_eq0; move: (evalK _ _) => c.
      apply/negP => /eqP  /(congr1 ((@order _ _)^~ P)).
      by rewrite orderC ordhP.
    have ecdivhRE R: oncurve R -> R != Q -> ecdiv (hR R) = << R >> - << Q >>.
      have hRdmp: ecdiv (hR R) = fgpos (ecdiv (hR R)) - fgneg (ecdiv h).
        rewrite -(Necdiv_transE _ (- (evalK R h))) /PEF /=.
        by rewrite polyC_opp ecXN tofracN -fg_decomp.
      move=> oncveR ne_RQ; rewrite hRdmp; have NhE: fgneg (ecdiv h) = <<Q>>.
        apply/eqP/freeg_eqP => S; rewrite coeff_fgnegE.
        rewrite divhE coeffB !coeffU !mul1r; do! case: eqP => //=.
        by move=> eq_QS eq_PS; rewrite eq_QS eq_PS eqxx in ne_PQ.
      have/(congr1 (@deg _))/eqP := hRdmp.
      rewrite degB {1}NhE degU deg_ecdiv_eq0 // eq_sym subr_eq0 => /eqP degPhR.
      rewrite NhE; congr (_ - _); move: degPhR; rewrite -[fgpos _]freeg_sumE.
      have ehR: eval (hR R) R = 0%:PP.
        rewrite /hR evalDr ?(evalN, evalC) // /evalK.
        case ehR: (eval h R) => [x|] /=; first by rewrite subrr.
        by move/eqP: ehR; rewrite -eval_lt0_order ordhE (negbTE ne_RQ) subr0.
      move/eqP: ehR; rewrite -eval_gt0_order // => gt0_ordhR.
      rewrite (bigD1_seq R) ?uniq_dom //=; last by rewrite mem_posdiv.
      rewrite degD [X in _ + X]raddf_sum /= degU coeff_fgposE ecdiv_coeffE.
      move: gt0_ordhR; rewrite gtz0_ge1 ler_eqVlt; case/orP; last first.
        move=> lt1_ordhR; rewrite maxr_r //; last first.
          by apply: (@ler_trans _ 1) => //; rewrite ltrW.
        move/(congr1 (+%R (-1))); rewrite [X in _ = X]addrC subrr.
        move/eqP; rewrite addrA [-1+_]addrC paddr_eq0; first last.
        + by apply: sumr_ge0=> S _; rewrite degU coeff_fgposE ler_maxr.
        + by rewrite subr_ge0 ltrW.
        case/andP; rewrite subr_eq0 => /eqP ordhR _.
        by rewrite ordhR ltrr in lt1_ordhR.
      move/eqP=> <-; rewrite maxr_r // -{2}[1]addr0 => /addrI /eqP.
      rewrite psumr_eq0 => [|S _]; last by rewrite degU coeff_fgposE ler_maxr.
      move=> all0; set S := \sum_(_ <- _ | _) _; have ->: S = 0; first last.
        by rewrite addr0.
      apply/eqP; rewrite {}/S big_seq_cond big1 // => S /andP [S_indom ne_SR].
      move/allP/(_ S S_indom)/implyP/(_ ne_SR): all0.
      by rewrite degU => /eqP->; rewrite freegU0.

    (* Any rational function s.t. Q is not in the domain of its divisor
     * can be expressed as a rational fraction in h *)
    have H f: order f Q = 0 -> exists r, f = r \Fo h; first move=> ordfQ.
      have [->|nz_f] := eqVneq f 0; first by exists 0; rewrite comp_fracC_fec.
      pose F := \prod_(R <- dom (ecdiv f)) (('X - (evalK R h)%:P)%:F)^(order f R).
      have FohE: F \Fo h = \prod_(R <- dom (ecdiv f)) (hR R)^(order f R).
        rewrite /F /hR comp_frac_prod_fec //; apply: eq_bigr => S _.
        rewrite -comp_fracX_exp ?comp_fracF_fec //; congr (_ ^ _).
        rewrite /comp_poly_fec rmorphB /= map_polyX map_polyC /=.
        by rewrite !hornerE.
      have nz_FohE: F \Fo h != 0.
        rewrite FohE prodf_seq_neq0; apply/allP.
        by move=> S _; apply/implyP=> _; rewrite expfz_neq0.
      have: ecdiv f = ecdiv (F \Fo h).
        rewrite FohE ecdiv_prod -?FohE // big_seq.
        rewrite (eq_bigr (fun S => (<<S>> - <<Q>>) *~ (order f S))); last first.
          move=> S S_in_domf; rewrite ecdivXz ecdivhRE //.
          + have [//|outcveS] := (boolP (oncurve S)); move: S_in_domf.
            by rewrite mem_dom inE ecdiv_coeffE order_outcve.
          + apply/eqP=> eq_SQ; move: ordfQ; rewrite -eq_SQ => ordfS.
            by move: S_in_domf; rewrite mem_dom inE ecdiv_coeffE ordfS.
        rewrite (eq_bigr (fun S => (<<order f S *g S>> - (<<Q>> *~ order f S)))); last first.
          by move=> S _; rewrite mulrzBl freegU_mulz intz.
        rewrite -big_seq sumrB -mulrz_sumr -ecdiv_degE.
        by rewrite deg_ecdiv_eq0 // subr0 -ecdiv_sumE.
      case/eq_ecdiv_proportional_func=> // c nz_c; exists ((c%:P%:F) * F).
      by rewrite comp_fracM_fec // mulrC comp_fracC_fec.

    (* Any rational function can be expressed as a rational fraction in h
     * (Generalization of previous property) *)
    have {H} H f: exists r, f = r \Fo h.
      have [->|nz_f] := eqVneq f 0; first by exists 0; rewrite comp_fracC_fec.
      move: (uniok_decomp (decomp_correct nz_h oncveQ)).
      move: (uniok_decomp (decomp_correct nz_f oncveQ)).
      rewrite ordhQ; set u := (unifun _ _); set r := (_ // _); set s := (_ // _).
      have nz_dc1_h: (decomp h Q).1 != 0 by rewrite decomp_nz_num.
      have nz_dc2_h: (decomp h Q).2 != 0 by rewrite decomp_nz_den.
      have nz_dc1_f: (decomp f Q).1 != 0 by rewrite decomp_nz_num.
      have nz_dc2_f: (decomp f Q).2 != 0 by rewrite decomp_nz_den.
      have nz_u: u != 0 by rewrite unifun_neq0.
      have nz_s: s != 0 by rewrite /s mulf_neq0 // ?invr_eq0 tofrac_eq0.
      move=> fE hE; have: u = h^-1 * s.
        rewrite hE invfM exprN1 invrK -mulrA mulVf ?mulr1 //.
        move=> uE; move: {hE} fE; rewrite uE expfzMl exprz_inv -mulrA.
        set g := (s^_ * r); have: order g Q = 0.
          rewrite /g order_mul ?(neq0, expfz_neq0) // order_expz.
          rewrite (uniok_order_decomp (decomp_correct nz_h oncveQ)).
          rewrite (uniok_order_decomp (decomp_correct nz_f oncveQ)).
          by rewrite addr0 mul0rz.
        case/H => t gE fE; exists (('X%:F)^(-order f Q) * t).
        rewrite comp_fracM_fec // -gE -comp_fracX_exp // comp_fracF_fec //.
        by rewrite /comp_poly_fec map_polyX hornerX {1}fE.

    (* Using previous result, we can express 'X and 'Y as rational
     * fractions in h. These functions are non constant. Moreover, they
     * are on the lifted base curve. *)
    case: (H ('X%:E)%:F) => f1 Ef1; case: (H 'Y%:F) => f2 Ef2.
    have oncve_f: f2 ^+ 2 = f1 ^+ 3 + ((E #a)%:P)%:F * f1 + ((E #b)%:P)%:F.
      apply (injective_comp_frac_fec closedK Ncct_h).
      rewrite !(comp_fracX_fec, comp_fracM_fec, comp_fracD_fec) //.
      rewrite -!Ef1 -!Ef2 !comp_fracC_fec -!(tofracX, tofracM, tofracD).
      by rewrite ecY_sqr expr1n mul1r XpolyE -!(ecXX, ecXM, ecXD) mul_polyC.
    have Ncct_f1: ~~ isfcnt f1.
      apply/negP => /isfcntfP [c Ef1c]; move/eqP: Ef1.
      rewrite Ef1c comp_fracC_fec tofrac_eq => /eqP /ecX_inj /eqP.
      by rewrite -subr_eq0 polyXsubC_eq0.
    have Ncct_f2: ~~ isfcnt f2.
      apply/negP => /isfcntfP [c Ef2c]; move/eqP: Ef2.
      rewrite Ef2c comp_fracC_fec tofrac_eq eqE /= => /eqP [].
      by move/eqP; rewrite oner_eq0.

    (* Last result conflicts with technical lemma L_2_38. QED. *)
    move: (L_2_38_fec E closedK) => /(_ f2 f1 Ncct_f2 Ncct_f1).
    by rewrite oncve_f eqxx.
  Qed.
End L_2_40_base.

(* -------------------------------------------------------------------- *)
Section L_2_40.
  Variable K : ecuDecFieldType.
  Variable E : ecuType K.

  Notation Xpoly   := (@Xpoly K E).
  Notation ecpoly  := (@ecpoly K E).
  Notation oncurve := (@oncurve K E).

  Implicit Types f : {fraction ecpoly}.

  Hypothesis closedK : GRing.ClosedField.axiom K.

  Import PreClosedField.

  Hint Resolve closedK.

  Local Notation "D1 :~: D2" := (@ecdeqv _ E D1 D2).

  Lemma L_2_40 p q: << p >> :~: << q >> -> p = q.
  Proof. by case=> h /L_2_40_base ->. Qed.
End L_2_40.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial ssralg finset fingroup finalg matrix.
Require Import Reals Fourier Rpower.
Require Import Reals_ext ssr_ext ssralg_ext Rssr log2 Rbigop ln_facts.
Require Import num_occ proba entropy channel divergence types jtypes.

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

Local Open Scope reals_ext_scope.
Local Open Scope proba_scope.
Local Open Scope entropy_scope.
Local Open Scope channel_scope.
Local Open Scope divergence_scope.
Local Open Scope num_occ_scope.
Local Open Scope types_scope.

Section condition_equivalence.

Variables A B : finType.
Variables V W : `Ch_1(A, B).
Variable P : dist A.

Definition cdom_by := forall a, P a != 0 -> (V a) << (W a).

Lemma condition_equivalence : (`J(P , V) << `J(P , W)) <-> cdom_by.
Proof.
rewrite /dom_by; split=> H.
- move=> a p_not_0 b; move: (H (a, b)).
  rewrite /JointDistd /= /JointDist.f /= => H0 H1.
  rewrite H1 mul0R in H0.
  move/(_ (refl_equal _)) in H0.
  case/Rmult_integral : H0 => // H0.
  by rewrite H0 eqxx in p_not_0.
- case=> a p_not_0 b; move: {H}(H a) => H.
  rewrite /JointDistd /= /JointDist.f /=.
  case/boolP : (P a == 0) => [/eqP -> | H1].
    by rewrite mulR0.
  move: {H}(H H1) => ->.
  by rewrite mul0R.
  case/Rmult_integral : b => // b.
  by rewrite b eqxx in H1.
Qed.

End condition_equivalence.

Notation "V '<<' W '|' P" := (cdom_by V W P) (at level 5, P at next level) : channel_scope.

Notation "V '<<b' W '|' P" := ([forall a, (P a != 0) ==> (V a) <<b (W a)])
  (at level 5) : channel_scope.

Section joint_dom_sect.

Variable A B : finType.
Variables V W : `Ch_1(A, B).
Variable P : dist A.

Lemma joint_dom : V << W | P -> dom_by (`J(P, V)) (`J(P, W)) (*NB: notation issue*).
Proof.
move => V_dom_by_W => ab /= Hab.
case: (Rle_lt_or_eq_dec _ _ (Rle0f P ab.1)) => Hab1.
- rewrite /JointDist.f V_dom_by_W.
  + by rewrite mul0R.
  + case/Rmult_integral : Hab => Hab.
    * apply/eqP; by apply nesym, Rlt_not_eq.
    * move: Hab1; rewrite Hab; by move/Rlt_irrefl.
  + case/Rmult_integral : Hab => // Hab.
    move/Rlt_not_eq : Hab1; by rewrite Hab.
- by rewrite /JointDist.f -Hab1 mulR0.
Qed.

End joint_dom_sect.

Section conditional_divergence_def.

Variables A B : finType.
Variables V W : `Ch_1(A, B).
Variable P : dist A.

Definition cdiv := \rsum_(a : A) P a * D(V a || W a).

End conditional_divergence_def.

Notation "'D(' V '||' W '|' P ')'" := (cdiv V W P)
  (at level 50, V, W, P at next level) : divergence_scope.

Section conditional_divergence_prop.

Variables A B : finType.
Variables V W : `Ch_1(A, B).
Variable P : dist A.

Hypothesis V_dom_by_W : V << W | P.

Lemma cdiv_is_div_joint_dist : D(V || W | P) =  D(`J(P , V) || `J(P , W)).
Proof.
rewrite (_ : D(V || W | P) =
  \rsum_(a : A) (\rsum_(b | b \in B) V a b * (log (V a b) - log (W a b)) * P a)); last first.
  apply eq_bigr => a _.
  by rewrite -(big_morph _ (morph_mulRDl _) (mul0R _)) mulRC.
rewrite pair_bigA big_mkcond /=.
apply eq_bigr; case => [] a b /= _.
rewrite /JointDist.f.
case/boolP : (P a == 0) => [/eqP -> | Pneq0]; first by rewrite !mulR0 mul0R.
case/boolP : (V a b == 0) => [/eqP -> | Vneq0]; first by rewrite !mul0R.
case/boolP : (W a b == 0) => [/eqP Weq0| Wneq0].
  contradict Vneq0.
  apply/negP. rewrite negbK. apply/eqP. by apply V_dom_by_W.
rewrite /= !log_mult; first field; apply Rlt_le_neq; by [apply Rle0f | apply/eqP; rewrite eq_sym].
Qed.

Lemma leq0cdiv : 0 <= D(V || W | P).
Proof.
rewrite cdiv_is_div_joint_dist //; apply leq0div.
case=> a b; rewrite /JointDistd /= /JointDist.f /=.
case/boolP : (P a == 0); first by move/eqP => ->; rewrite 2!mulR0.
move=> H1 H2.
apply Rmult_eq_0_compat_r.
apply V_dom_by_W => //.
case (Rmult_integral _ _ H2) => // ?; contradict H1.
by apply/negP/negPn/eqP.
Qed.

Lemma eq0cdiv : D(V || W | P) = 0 <-> `J(P, V) = `J(P, W).
Proof.
rewrite cdiv_is_div_joint_dist.
apply eq0div; case=> a b.
rewrite /JointDistd /= /JointDist.f /= => HW.
apply Rmult_integral in HW; case: HW => Hcase; last by rewrite Hcase mulR0.
case/boolP : (P a == 0) => [/eqP ->|Hcase2]; first by rewrite mulR0.
by apply Rmult_eq_0_compat_r, V_dom_by_W.
Qed.

End conditional_divergence_prop.

Section dmc_cdiv_cond_entropy_sect.

Variable A B : finType.
Variables W : `Ch_1(A, B).
Variable n : nat.
Variable P : P_ n ( A ).
Variable V : P_ n ( A , B ).
Variable ta : 'rV[A]_n.
Variable tb : 'rV[B]_n.

Local Open Scope vec_ext_scope.

Lemma dmc_cdiv_cond_entropy_aux : W ``^ n (tb | ta) =
  \rmul_(a : A) \rmul_(b : B) W a b ^ N(a, b | tuple_of_row ta, tuple_of_row tb).
Proof.
transitivity (\rmul_(a : A) \rmul_(b : B) \rmul_(i < n)
  if (a == ta ``_ i) && (b == tb ``_ i) then W ta ``_ i tb ``_ i else 1).
  rewrite pair_big exchange_big /= /DMC.c; unlock.
  apply eq_bigr => i _.
  rewrite (bigD1 (ta ``_ i, tb ``_ i)) //= 2!eqxx andbT.
  rewrite big1; first by rewrite mulR1.
  case=> a b /=.
  rewrite xpair_eqE negb_and.
  case/orP.
  - by move/negbTE => ->.
  - move/negbTE => ->; by rewrite andbF.
apply eq_bigr => a _; apply eq_bigr => b _.
rewrite num_co_occ_alt -sum1_card.
rewrite (@big_morph _ _ (fun x => W a b ^ x) 1 Rmult O addn) //; last first.
  move=> * /=; by rewrite -pow_add.
rewrite [in RHS]big_mkcond.
apply eq_bigr => i _.
case: ifP.
  case/andP => /eqP Ha /eqP Hb.
  by rewrite inE 2!tnth_mktuple -Ha -Hb 2!eqxx /= mulR1.
move/negbT.
rewrite negb_and inE 2!tnth_mktuple.
case/orP => /negbTE.
  by rewrite eq_sym => ->.
by rewrite andbC eq_sym => ->.
Qed.

Local Close Scope tuple_ext_scope.

Hypothesis W0_V0 : V << W | P.
Hypothesis Hta : tuple_of_row ta \in T_{P}.
Hypothesis HV : V \in \nu^{B}(P).
Hypothesis Htb : tuple_of_row tb \in V.-shell (tuple_of_row ta).
Hypothesis Hn : n != O.

(** Expression of the probability transition matrix of a DMC using
   the conditional divergence and the condition entropy *)

Lemma dmc_cdiv_cond_entropy :
  W ``^ n (tb | ta) = exp2 (- INR n * (D(V || W | P) + `H(V | P))).
Proof.
rewrite dmc_cdiv_cond_entropy_aux cond_entropy_single_sum.
rewrite /cdiv /entropy -big_split /=.
rewrite (big_morph _ (morph_mulRDr _) (mulR0 _)) (big_morph _ morph_exp2_plus exp2_0).
apply eq_bigr => a _.
rewrite (big_morph _ morph_Ropp Ropp_0).
rewrite /div /= -mulRDr mulRA -big_split /=.
rewrite (big_morph _ (morph_mulRDr _) (mulR0 _)) (big_morph _ morph_exp2_plus exp2_0).
apply eq_bigr => b _.
case/boolP : (W a b == 0) => Wab0.
- move/eqP in Wab0; rewrite Wab0.
  case/boolP : (P a == 0) => Pa0.
  - move/eqP in Pa0; rewrite Pa0.
    rewrite mulR0 mul0R exp2_0 -(pow_O 0).
    f_equal.
    move: Htb; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP => ->.
    move: (HV).
    rewrite in_set.
    move/cond_type_equiv/(_ _ Hta a).
    move: Hta; rewrite in_set => /forallP/(_ a)/eqP => Htmp Htmp'.
    rewrite -Htmp' Pa0 in Htmp.
    symmetry in Htmp; case/Rmult_integral : Htmp; last first.
      move=> abs.
      suff : False by done.
      move: abs.
      apply Rinv_neq_0_compat.
      apply not_0_INR; by apply/eqP.
    rewrite (_ : 0 = INR 0) //.
    move/INR_eq.
    move/eqP; rewrite sum_nat_eq0 => /forall_inP/(_ b) => H; apply/eqP; by move: H => ->.
  - move: (W0_V0 Pa0 Wab0) => nullV.
    rewrite nullV.
    suff : N(a, b| tuple_of_row ta, tuple_of_row tb) = 0%nat.
      move=> ->; by rewrite 2!mul0R Ropp_0 addR0 mulR0 exp2_0.
    move: Htb; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP => ->.
    by rewrite jtype_0_jtypef.
- rewrite -{1}(@exp2_log (W a b)); last first.
    apply Rlt_le_neq; first by apply Rle0f.
    move/eqP; apply/negP; by rewrite eqtype.eq_sym.
  rewrite -exp2_pow.
  f_equal.
  rewrite -Ropp_mult_distr_r_reverse -mulRDr mulRA /Rminus addRC addRA Rplus_opp_l add0R Ropp_mult_distr_r_reverse -3!Ropp_mult_distr_l_reverse Ropp_involutive.
  f_equal.
  move: Htb; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP => ->.
  move: (HV).
  rewrite in_set.
  move/cond_type_equiv => /(_ _ Hta a).
  move=> Htmp'.
  move: Hta; rewrite in_set => /forallP/(_ a)/eqP => Htmp.
  rewrite (jtype.c_f V) /=.
  case: ifP.
  - move/eqP => HP.
    rewrite Htmp -Htmp' HP /Rdiv !(mul0R, mulR0).
    move/eqP : HP.
    rewrite sum_nat_eq0.
    move/forallP.
    by move/(_ b)/implyP/(_ Logic.eq_refl)/eqP => ->.
  - move/negP/negP => HP.
    rewrite Htmp Htmp' !mulRA Rinv_r_simpl_m; last by apply not_0_INR; apply/eqP.
    rewrite Rinv_r_simpl_m // -Htmp'.
    apply/eqP.
    move: HP; apply contra.
    move/eqP.
    rewrite (_ : 0 = INR 0) //.
    by move/INR_eq => ->.
Qed.

End dmc_cdiv_cond_entropy_sect.

Section cdiv_spec.

Variables A B : finType.
Variable n : nat.
Variable P : P_ n ( A ).
Variable V : P_ n ( A , B ).
Variable W : `Ch_1*(A, B).
(*Variable ta : n.-tuple A.
Variable tb : n.-tuple B.*)

Definition exp_cdiv :=
  if V <<b W | P
  then exp2 (- INR n * D(V || W | P))
  else 0.

Lemma exp_cdiv_left (H : V << W | P) : exp_cdiv = exp2 (-INR n * D(V || W | P)).
Proof.
rewrite /exp_cdiv.
suff : V <<b W | P by move=> ->.
apply/forallP => a.
apply/implyP => Pa0.
apply/forall_inP => b /eqP Wab.
apply/eqP.
by apply H.
Qed.

End cdiv_spec.

Section dmc_cdiv_cond_entropy_spec_sect.

Variables A B : finType.
Variable W : `Ch_1*(A, B).
Variable n' : nat.
Let n := n'.+1.
Variable P : P_ n ( A ).
Variable V : P_ n ( A , B ).
Variable ta : 'rV[A]_n.
Variable tb : 'rV[B]_n.

Hypothesis Hta : tuple_of_row ta \in T_{P}.
Hypothesis Vctyp : V \in \nu^{B}(P).
Hypothesis Htb : tuple_of_row tb \in V.-shell (tuple_of_row ta).

Lemma dmc_exp_cdiv_cond_entropy :
  W ``^ n (tb | ta) = exp_cdiv P V W * exp2 (- INR n * `H(V | P)).
Proof.
rewrite /exp_cdiv.
case : ifP => Hcase.
- rewrite -exp2_plus -mulRDr.
  apply dmc_cdiv_cond_entropy => // a Pa b /eqP Wab.
  by move: Hcase => /forallP/(_ a)/implyP/(_ Pa)/forallP/(_ b)/implyP/(_ Wab)/eqP.
- rewrite mul0R.
  move: Hcase => /negbT; rewrite negb_forall; case/existsP => a.
  rewrite negb_imply.
  case/andP => Pa.
  rewrite negb_forall_in ; move/existsP ; case => b.
  case/andP=> Wab H.
  rewrite dmc_cdiv_cond_entropy_aux.
  rewrite pair_big /= (bigD1 (a, b)) //=.
  apply Rmult_eq_0_compat_r.
  move/eqP in Wab; rewrite Wab.
  apply pow_i.
  apply/ltP.
  rewrite lt0n.
  move: Htb ; rewrite in_set => /forallP/(_ a)/forallP/(_ b)/eqP ->.
  move: H => /=.
  rewrite (jtype.c_f V) /=.
  move: (Vctyp).
  rewrite in_set.
  move/cond_type_equiv => /(_ _ Hta a) ->.
  move: Hta; rewrite in_set => /forallP/(_ a)/eqP => Htmp.
  case: ifP => Hcase.
    suff : False by done.
    move/eqP : Pa; apply.
    rewrite Htmp.
    move/eqP : Hcase => ->.
    by rewrite /Rdiv mul0R.
  apply contra.
  move/eqP => ->.
  by rewrite /Rdiv mul0R.
Qed.

End dmc_cdiv_cond_entropy_spec_sect.