From Undecidability Require Import Definitions.
From Undecidability Require Import mu_nat partial equiv_on.

From Undecidability Require Import simple principles EnumerabilityFacts.

Require Import Nat Arith Lia.

From Undecidability Require Import FinitenessFacts.
From stdpp Require Import base.
Require Import List.

From Undecidability Require Import Pigeonhole.

From Undecidability Require Import Dec.

Set Default Goal Selector "!".

Lemma NoDup_app {X} (l1 l2 : list X) :
  NoDup l1 -> NoDup l2 -> (forall x, In x l1 -> ~ (In x l2)) -> NoDup (l1 ++ l2).
Proof.
  induction 1 in l2 |- *.
  - eauto.
  - intros Hl2 Hel. cbn. econstructor. 2:eapply IHNoDup; eauto.
    + intros [ | ] % in_app_iff; firstorder.
Qed.

Lemma NoDup_map {X Y} (f : X -> Y) l :
  Inj (=) (=) f -> NoDup l -> NoDup (map f l).
Proof.
  induction 2; cbn; econstructor.
  1:intros (? & ? % H & ?) % in_map_iff; subst.
  all: firstorder congruence.
Qed.

Lemma bitlist_for_k k :
  exists l : list (list bool), (forall x, In x l <-> length x = k) /\ NoDup l /\ length l = 2 ^ k.
Proof.
  induction k.
  - exists (nil :: nil). split; [ | split ].
    + cbn. intros []; cbn in *; firstorder congruence. all: congruence.
    + repeat econstructor; eauto.
    + reflexivity.
  - destruct IHk as (L & IH1 & IH2 & IH3).
    exists (map (cons true) L ++ map (cons false) L).
    split; [ | split].
    + intros l.
      rewrite in_app_iff, !in_map_iff.
      setoid_rewrite IH1.
      destruct l as [ | ].
      * cbn. split. 2:lia.
        intros [(? & [=] & ?) | (? & [=] & ?)].
      * cbn. split.
        -- intros [(? & [=] & ?) | (? & [=] & ?)]; subst; lia.
        -- destruct b; intros [=]; eauto.
    + eapply NoDup_app; try eapply NoDup_map; eauto.
      intros ? (? & <- & ?) % in_map_iff (? & ? & ?) % in_map_iff.
      congruence.
    + rewrite app_length, !map_length, IH3. cbn. lia.
Qed.

Theorem least_exists (p : nat -> Prop) :
  (exists n, p n) -> ~~ exists n, p n /\ forall i, p i -> n <= i.
Proof.
  intros H. destruct H as [n H].
  induction n using lt_wf_ind.
  ccase (exists m, m < n /\ p m) as [[m [Hm1 Hm2]] | Hm].
  - eauto.
  - cprove exists n; firstorder.
    assert (i < n \/ n <= i) by lia; firstorder.
Qed.

Definition the_least_pred (P : nat -> Prop) : nat -> Prop :=
  fun y => P y /\ forall y', P y' -> y <= y'.

Lemma the_least_pred_unique {P : nat -> Prop} {x y} :
  the_least_pred P x -> the_least_pred P y -> x = y.
Proof.
  firstorder lia.
Qed.

Lemma the_least_pred_impl' {P Q : nat -> Prop} {x} :
  the_least_pred P x -> (forall x, P x <-> Q x) -> the_least_pred Q x.
Proof.
  intros [H2 H3] H1. eapply H1 in H2. split. 1:exact H2. intros y'. rewrite <- H1. apply H3.
Qed.

Lemma the_least_pred_equiv {P Q : nat -> Prop} {x} :
  (forall x, P x <-> Q x) -> the_least_pred P x <-> the_least_pred Q x.
Proof.
  intros. split; intros; eapply the_least_pred_impl'; eauto; firstorder.
Qed.

Lemma the_least_pred_impl {P Q : nat -> Prop} {x} :
  the_least_pred P x -> (forall x, P x -> exists y, Q y) -> ~~ exists x, the_least_pred Q x.
Proof.
  intros [H2 H3] H1. eapply H1 in H2.
  clear H1 H3 P.
  assert (exists x, Q x) as H by eauto. clear x H2. eapply least_exists in H.
  intros G. apply H. intros (x & H2 & H3).  apply G.
  exists x. split. 1:auto. intros. eapply H3. auto.
Qed.

Lemma the_least_ex (P : nat -> Prop) :
  (exists n, P n) -> ~~ exists n, the_least_pred P n.
Proof.
  intros H % least_exists.
  intros G. apply H. intros (n & H2 & H3).
  apply G. exists n. split; auto with arith.
Qed.

Record FunRel X Y := {
  the_rel :> X -> Y -> Prop ;
  is_fun : (forall x y1 y2, the_rel x y1 -> the_rel x y2 -> y1 = y2) (* ; *)
  (* is_wtotal : (forall x, ~~ exists y, the_rel x y) *) }.

Definition on_value {X Y} (R : FunRel X Y) (P : Y -> Prop) x :=
  forall y, R x y -> P y.

Definition on_value' {X Y} (R : FunRel X Y) (P : Y -> Prop) x :=
  exists y, R x y /\ P y.

Lemma on_value_iff1 {X Y} (R : FunRel X Y) (P : Y -> Prop) x :
  on_value' R P x -> on_value R P x.
Proof.
  intros (y & H1 & H2) y' H.
  now rewrite <- (is_fun _ _ R _ _ _ H1 H).
Qed.

Definition total {X Y} (R : X -> Y -> Prop) :=
  forall x, exists y, R x y.

Lemma on_value_iff2 {X Y} (R : FunRel X Y) (P : Y -> Prop) x :
  total R ->
  on_value R P x -> on_value' R P x.
Proof.
  intros Htot H.
  destruct (Htot x) as [y Hy].
  exists y. split; [ assumption | ].
  eapply (H _ Hy).
Qed.

Definition weakly_total {X Y} (R : X -> Y -> Prop) :=
  forall x, ~~ exists y, R x y.

Lemma on_value_iff2' {X Y} (R : FunRel X Y) (P : Y -> Prop) x :
  weakly_total R ->
  on_value R P x -> ~~ on_value' R P x.
Proof.
  intros Htot H G.
  apply (Htot x); intros [y Hy].
  apply G.
  exists y. split; [ assumption | ].
  eapply (H _ Hy).
Qed.

Lemma on_value_imp {X Y} {P Q : Y -> Prop} R (x : X) :
  on_value R P x -> (forall y, P y -> Q y) -> on_value R Q x.
Proof.
  intros H1 H y Hy. apply H, H1, Hy.
Qed.

Lemma on_value_neg {X Y} {P : Y -> Prop} R (x : X) :
  ~ on_value R P x -> on_value R (fun y => ~ P y) x.
Proof.
  intros H y Hy G; cbn in *. apply H. intros y' Hy'. cbn in *.
  enough (y = y') as -> by assumption. eapply R; eauto.
Qed.

Program Definition the_least {X} (R : X -> nat -> Prop) : FunRel X nat :=
  {|
  the_rel x := the_least_pred (R x) ;
  is_fun := fun x y1 y2 H1 H2 => the_least_pred_unique H1 H2
  |}.

Axiom tonat : list bool -> nat.
Axiom ofnat : nat -> list bool.

Axiom ofnat_tonat : forall l, ofnat (tonat l) = l.
Axiom tonat_ofnat : forall n, tonat (ofnat n) = n.
Axiom length_log : forall n, length (ofnat n) <= Nat.log2 n.

Hint Rewrite ofnat_tonat tonat_ofnat : length.
Hint Rewrite List.app_length : length.

Notation "| n |" := (length (ofnat n)) (at level 10).

Notation "⟨ x , y ⟩" := (tonat (ofnat x ++ ofnat y)) (at level 0).

Lemma length_pair x y : | ⟨x,y⟩ | = |x| + |y|.
Proof.
  now autorewrite with length.
Qed.

Lemma length_sublinear d : ~ forall n, n <= |n| + d.
Proof.
  intros H.
  pose (n := 1 + 2 * S d).
  assert (2 ^ n > n + S d).
  { subst n. rewrite Nat.pow_add_r, Nat.pow_mul_r.
    generalize (S d). cbn. induction n; cbn; lia.
  }
  specialize (H (2 ^ n)).
  pose proof (length_log (2 ^ n)).
  rewrite Nat.log2_pow2 in *; lia.
Qed.

Axiom Part : partiality.
Existing Instance Part.

Notation "x ▷ y" := (@hasvalue Part nat x y) (at level 50).

Instance equiv_part {A} : equiv_on (part A) := {| equiv_rel := @partial.equiv _ A |}.

Lemma MP_choice (R : nat -> nat -> Prop) : MP -> enumerable (fun '(x,y) => R x y) ->
  (forall x, ~~ exists y, R x y) -> exists f, forall x, R x (f x).
Proof.
  intros.
  eapply enumerable_AC; eauto.
  intros x. eapply MP_to_MP_semidecidable in H.
  red in H. eapply H with (p := fun x => exists n, R x n).
  - eapply SemiDecidabilityFacts.semi_decidable_ex.
    eapply SemiDecidabilityFacts.enumerable_semi_decidable; eauto.
    eapply ReducibilityFacts.enumerable_red.
    4: exact H0. all:eauto.
    exists (fun '(x,y) => (y, x)). intros []. firstorder.
  - eauto.
Qed.

Lemma get_partial_choice (R : nat -> nat -> Prop) :
  enumerable (fun '(x,y) => R x y) ->
  exists f : nat ↛ nat, forall x v_x,
    (f x ▷ v_x -> R x v_x) /\ (R x v_x -> exists v', f x ▷ v').
Proof.
  intros [f Hf].
  exists (fun x => bind (mu_tot (fun n => if f n is Some (x', y) then x =? x' else false))
                (fun n => if f n is Some (x', y) then ret y else undef)).
  intros x v_x. rewrite bind_hasvalue.
  split.
  - intros (n & (H1 & H3) % mu_tot_hasvalue & H2).
    destruct (f n) as [ [x' y] | ]eqn:E; try congruence.
    destruct (Nat.eqb_spec x x'); try congruence. subst.
    eapply ret_hasvalue_iff in H2. subst.
    eapply (Hf (x', v_x)). eauto.
  - intros [n Hn] % (Hf (x, v_x)).
    edestruct (mu_tot_ter) as [a Ha].
    2:{ destruct (f a) as [[x' y'] | ] eqn:E.
        - eexists. eapply bind_hasvalue. exists a. split. 1: eapply Ha.
          rewrite E. eapply ret_hasvalue.
        - eapply mu_tot_hasvalue in Ha as [Ha _].
          rewrite E in Ha. congruence.
    }
    cbn. rewrite Hn. eapply Nat.eqb_refl.
Qed.

Lemma enum_size_lt :
  forall q : nat -> Prop, enumerable q -> enumerable (fun p => fst p < | snd p | /\ q (snd p)).
Proof.
  intros q Hq.
  eapply enumerable_conj; [ eauto | .. ].
  - eapply decidable_enumerable; eauto.
    eapply DecidabilityFacts.decidable_iff; econstructor; eauto.
  - eapply ReducibilityFacts.enumerable_red.
    4: eapply Hq. all: eauto.
    exists snd. firstorder.
Qed.

Hint Rewrite List.app_nil_l @list.nil_length : length.

Section Kolmogorov.

Variable Θ : nat ↛ nat.

Definition C := the_least (fun x s => exists c, s = |c| /\ Θ c ▷ x).

Variable Θ_total : forall x, exists y, Θ y ▷ x.

Lemma C_weakly_total :
  forall x,~~ exists y, C x y.
Proof.
  intros x. destruct (Θ_total x) as [y Hy].
  eapply the_least_ex. eauto.
Qed.

Definition N (x : nat) :=
  exists y, Θ y ▷ x /\ |y| < |x|.

Definition N1 (x : nat) := exists y, C x y /\ y < |x|.
Definition N3 (x : nat) := forall y, C x y -> y < |x|.

Fact N_equiv x :
  (N1 x -> N x) /\ (N x -> N3 x) /\ (N3 x -> ~~ N1 x).
Proof.
  repeat split.
  - intros (y & ((c & -> & H2) & H3) & H4).
    firstorder.
  - intros (y & H1 & H2) y' ((c & -> & ?) & ?).
    eapply le_lt_trans with (m := |y|); eauto.
  - firstorder using C_weakly_total.
Qed.

Definition R (x : nat) :=
  forall y, Θ y ▷ x -> |y| >= |x|.

Definition R1 (x : nat) := exists y, C x y /\ y >= |x|.
Definition R3 (x : nat) := forall y, C x y -> y >= |x|.

Fact R_equiv x :
  (R1 x -> R x) /\ (R x -> R3 x) /\ (R3 x -> ~~ R1 x).
Proof.
  repeat split.
  - intros (y & ((c & -> & H2) & H3) & H4) y' H.
    red. transitivity (|c|); eauto.
  - intros H1 y ((c & -> & H2) & H3). firstorder.
  - firstorder using C_weakly_total.
Qed.

Lemma R_neg_N x :
  R x <-> ~ N x.
Proof.
  split.
  - intros H (y & H1 % H & H2). lia.
  - intros H y H1.
    assert (|y| >= |x| \/ |y| < |x|) as [ Ha | Ha ] by lia; [ auto | ].
    destruct H. exists y. eauto.
Qed.

Lemma par_enum_ϕ :
  enumerable (fun '(x, y) => Θ y ▷ x).
Proof.
  eapply ReducibilityFacts.enumerable_red.
  4: eapply enumerable_graph_part; eauto.
  all: eauto.
  exists (fun '(x,y) => (y, x)). intros [].  cbn. reflexivity.
Qed.

Lemma enumerable_N :
  enumerable N.
Proof.
  destruct (par_enum_ϕ) as [f Hf].
  exists (fun n => if f n is Some (x,y) then if Nat.ltb (|y|) (|x|) then Some x else None else None).
  red. intros x. split.
  - intros (y & H1 & H2).
    eapply (Hf (x, y)) in H1 as [n Hn].
    exists n. rewrite Hn.
    destruct (Nat.ltb_spec (|y|) (|x|)).
    + reflexivity.
    + lia.
  - intros [n Hn]. destruct (f n) as [[x' y] | ] eqn:E; inversion Hn.
    destruct (Nat.ltb_spec (|y|) (|x'|)).
    + inversion Hn. subst. exists y. split; eauto.
      eapply (Hf (x, y)). eauto.
    + congruence.
Qed.

Lemma list_for_k k :
  exists l, (forall x, In x l <-> | x | = k) /\ NoDup l /\ length l = 2 ^ k.
Proof.
  destruct (bitlist_for_k k) as (l & H1 & H2 & H3).
  exists (map tonat l). split; [ | split].
  - intros x. cbn. rewrite in_map_iff.
    setoid_rewrite H1. split.
    + intros (y & <- & <-). now autorewrite with length.
    + intros <-. exists (ofnat x). now autorewrite with length.
  - eapply NoDup_map; auto. intros ? ? E % (f_equal ofnat).
    now rewrite !ofnat_tonat in E.
  - now rewrite map_length.
Qed.

Lemma list_for_le_k k :
  exists l, (forall x, In x l <-> | x | <= k) /\ NoDup l /\ length l = 2 ^ (S k) - 1.
Proof.
  induction k.
  - cbn. exists [ tonat nil ].
    split; [ | split ].
    + cbn. split.
      * intros [ <- | []]. now autorewrite with length.
      * intros H. left. destruct (ofnat x) eqn:E; inversion H.
        rewrite <- E. now autorewrite with length.
    + repeat econstructor. firstorder.
    + reflexivity.
  - cbn. destruct IHk as (l1 & IH1 & IH2 & IH3).
    destruct (list_for_k (S k)) as (l2 & H1 & H2 & H3).
    exists (l1 ++ l2). split; [ | split].
    + intros. rewrite in_app_iff, IH1, H1.
      lia.
    + eapply NoDup_app; firstorder lia.
    + rewrite app_length, IH3, H3. cbn; lia.
Qed.

Lemma at_most k : k > 0 ->
  forall l, (forall x, In x l -> | x | < k) -> NoDup l -> length l <= 2^ k - 1.
Proof.
  intros Hk l H1 H2. unfold lt in H1.
  destruct k.
  - lia.
  - setoid_rewrite <- Nat.succ_le_mono in H1.
    destruct (list_for_le_k k) as (l2 & H3 & H4 & H5).
    assert (length l <= length l2). {
      eapply NoDup_incl_length; firstorder.
    }
    enough (length l2 <= 2 ^ (S k) - 1) by lia.
    rewrite H5. lia.
Qed.

Definition injective {X Y} (R : X -> Y -> Prop) :=
  forall x1 x2 y, R x1 y -> R x2 y -> x1 = x2.

Lemma Forall2_ex_r {X Y} (R : X -> Y -> Prop) l1 l2 y :
  Forall2 R l1 l2 ->
  In y l2 -> exists x, In x l1 /\ R x y.
Proof.
  induction 1; repeat firstorder subst.
Qed.

Lemma functional_NoDup (R : nat -> nat -> Prop) l :
  injective R ->
  (forall x, In x l -> exists y, R x y) ->
  NoDup l ->
  exists l', NoDup l' /\ Forall2 R l l'.
Proof.
  intros HR Htot Hl. induction Hl.
  - exists []. split; econstructor.
  - destruct IHHl as (l' & H1 & H2).
    + firstorder.
    + destruct (Htot x) as [y Hy].
      1: firstorder.
      exists (y :: l'). split.
      * econstructor; [ | eauto].
        intros Hin.
        edestruct @Forall2_ex_r as (x' & H3 & H4); eauto.
        eapply H. eapply HR in H4 as <-; eauto.
      * econstructor; eauto.
Qed.

Lemma nonrandom_k k :
  ~ forall x, |x| = k -> N x.
Proof.
  intros H.
  destruct (list_for_k k) as (l & H1 & H2 & H3).
  eapply (functional_NoDup (fun x y => Θ y ▷ x ∧ | y | < | x |)) in H2 as (l' & H4 & H5).
  - assert (Forall (fun y => |y| < k) l'). {
      eapply list.Forall2_Forall_r; eauto.
      cbn. eapply Forall_forall.
      intros ? ? % H1. lia.
    }
    assert (length l' = 2 ^ k). { erewrite <- list.Forall2_length; eauto. }
    destruct k.
    + cbn in *. destruct H0.  1:inversion H2. cbn in *. lia.
    + unshelve epose proof (@at_most (S k) _ l' _ _).
      * lia.
      * eapply Forall_forall. eauto.
      * eauto.
      * rewrite H2 in H6.
        enough (2 ^ S k > S k) by lia.
        eapply Nat.pow_gt_lin_r. lia.
  - intros x1 x2 y [Hx1 Hx11] [Hx2 Hx22]. eapply hasvalue_det; eauto.
  - intros x (y & ? & ?) % H1 % H. eauto.
Qed.

Lemma unboundedR :
  forall k, ~~ exists x, | x | = k /\ R x.
Proof.
  setoid_rewrite R_neg_N. intros k G.
  assert (forall x, |x| = k -> ~~ N x) by firstorder. clear G.
  pose proof (nonrandom_k k).
  pose proof (list_for_k k) as (l & H1 & H2 & H3).
  setoid_rewrite <- H1 in H.
  setoid_rewrite <- H1 in H0. clear - H H0.
  induction l.
  - eapply H0. firstorder.
  - eapply H.
    + now left.
    + intros Ha. eapply IHl.
      * intros HH. eapply H0. intros. inversion H1 as [-> | ]; eauto.
      * firstorder.
Qed.

Lemma non_finite_length (p : nat -> Prop) :
  ~ exhaustible p -> forall x, ~~ exists y, x < | y | /\ p y.
Proof.
  intros H.
  unshelve epose proof (non_finite_unbounded_fun _ (fun x => |x|) _ H).
  - cbn. intros n.
    destruct (@list_for_le_k n) as [L HL].
    exists L. intros. eapply HL. eauto.
  - intros x. specialize (H0 (S x)). cunwrap.
    destruct H0 as (y & H1 & H2). cprove exists y.
    split. 1:lia. assumption.
Qed.

Lemma classical_finite {X} (p q : X -> Prop):
  listable p -> (forall x, p x -> ~~ q x) -> ~~ forall x, p x -> q x.
Proof.
  intros [l Hl]. red in Hl.
  setoid_rewrite Hl. clear p Hl.
  induction l.
  - firstorder.
  - cbn. intros H.
    specialize (IHl ltac:(firstorder)).
    cunwrap. ccase (q a) as [Ha | Ha].
    + cprove intros ? [-> | ]; eauto.
    + specialize (H a); firstorder.
Qed.

Lemma non_finite_R :
  ~ exhaustible R.
Proof.
  eapply unbounded_non_finite_fun with (f := fun x => |x|).
  intros k G.
  setoid_rewrite R_neg_N in G.
  assert (forall x, |x| = k -> ~~ N x).
  { intros x Hx GG. apply G. exists x. split. 1:lia. assumption. }
  clear G.

  eapply classical_finite in H.
  1:cstart; cunwrap; intros _; now eapply (nonrandom_k k).
  destruct (list_for_k k) as (L & H1 & _ & _).
  firstorder.
Qed.

Variable dist : forall f,
  exists d, forall x, exists y_x, Θ y_x ▷ f x /\ | y_x| < |x| + d.

Lemma subset :
  MP -> forall q : nat -> Prop, (forall x, q x -> R x) -> enumerable q -> ~ exhaustible q -> False.
Proof.
  intros mp q H1 H2 H3.
  unshelve epose proof (MP_choice _ mp _ (non_finite_length _ H3)) as [f Hf].
  1:{ eapply Proper_enumerable. 2: eapply enum_size_lt, H2. intros []; reflexivity. }
  assert (forall k y, Θ y ▷ f k -> |f k| <= |y|). {
    intros. destruct (Hf k) as [Hk1 Hk2].
    eapply H1; eauto.
  }
  destruct (dist f) as [d Hd].
  eapply (length_sublinear d). intros k.
  transitivity (|f k|). 1:eapply Nat.lt_le_incl, Hf.
  destruct (Hd k) as (y_k & Hk1 & Hk2).
  transitivity (|y_k|). 1: eauto.
  lia.
Qed.

Variable dist_part :
  forall f : nat ↛ nat,  exists d, forall x, exists y_x, forall v_x, f x ▷ v_x -> Θ y_x ▷ v_x /\ |y_x| < |x| + d.

Lemma dist_lem : forall f,
  exists d, forall x, exists y_x, Θ y_x ▷ f x /\ | y_x| < |x| + d.
Proof.
  intros f.
  destruct (dist_part (fun x => ret (f x))) as [d Hd].
  exists d. intros x. destruct (Hd x) as [y_x].
  exists y_x. destruct (H (f x)) as [H1 H2]; eauto using ret_hasvalue.
Qed.

Lemma dist_rel : forall R,
  weakly_total R -> enumerable (fun '(x,y) => R x y) ->
  exists d, forall x, exists y_x, ~~ exists v_x, R x v_x /\ Θ y_x ▷ v_x /\ | y_x| < |x| + d.
Proof.
  intros R Htot [f Hf] % get_partial_choice.
  destruct (dist_part f) as [d Hd].
  - exists d. intros x. destruct (Hd x) as [y_x H].
    exists y_x. specialize (Htot x). cunwrap. destruct Htot as [v_x Hvx].
    eapply Hf in Hvx as [v_x' Hvx]. cprove exists v_x'.
    firstorder.
Qed.

Lemma subset_strong :
  forall q : nat -> Prop, (forall x, q x -> R x) -> enumerable q -> ~ exhaustible q -> False.
Proof.
  intros q H1 H2 H3.
  destruct (dist_rel (fun k x => k < |x| /\ q x)) as [d Hd].
  - exact (non_finite_length _ H3).
  - eapply Proper_enumerable. 2: eapply enum_size_lt, H2. intros []; reflexivity.
  - eapply (length_sublinear d). intros k.
    destruct (Hd k) as [y_k H].
    unshelve cstart. 1:eapply le_dec.
    cunwrap. destruct H as (x_k & [H4 H5] & H6 & H7).
    cprove idtac.
    transitivity (|x_k|). 1:eapply Nat.lt_le_incl, H4.
    transitivity (|y_k|). 1: eapply H1; eauto. lia.
Qed.

Lemma exhaustible_ext {X} (p q : X -> Prop) :
  exhaustible p -> (forall x, p x <-> q x) -> exhaustible q.
Proof.
  firstorder.
Qed.

Lemma simple_N : MP -> simple N.
Proof.
  split. 2: split.
  - eapply enumerable_N.
  - intros ?. eapply non_finite_R, exhaustible_ext. 1: eauto.
    intros. now rewrite R_neg_N.
  - intros (q & H1 & H2 & H3). eapply subset; try eassumption.
    intros. eapply R_neg_N; eauto. firstorder.
Qed.

Lemma simple_N_strong : simple N.
Proof.
  split. 2: split.
  - eapply enumerable_N.
  - intros ?. eapply non_finite_R, exhaustible_ext. 1: eauto.
    intros. now rewrite R_neg_N.
  - intros (q & H1 & H2 & H3). eapply subset_strong; try eassumption.
    intros. eapply R_neg_N; eauto. firstorder.
Qed.

Lemma dist_again :
  forall f : nat -> nat, exists d, forall x y, C (f x) y -> y <= |x| + d.
Proof.
  intros f.
  destruct (dist f) as [d Hd]. exists d.
  intros x y H. destruct (Hd x) as (y_x & H1 & H2).
  etransitivity.
  - eapply H; eauto.
  - lia.
Qed.

Lemma R_undecidable :
  MP -> ~ decidable R.
Proof.
  intros mp Hdec.
  unshelve epose proof (MP_choice _ mp _ unboundedR) as [g Hg].
  - cbn. eapply decidable_enumerable. 2:eauto.
    eapply DecidabilityFacts.decidable_iff.
    eapply DecidabilityFacts.decidable_iff in Hdec. destruct Hdec.
    econstructor. intros (x, y).
    exact _.
  - destruct (dist_again g) as [d].
    eapply length_sublinear with (d := d).
    intros k.
    unshelve cstart.  1:eapply le_dec.
    pose proof (C_weakly_total (g k)) as Hk. cunwrap.
    destruct Hk as [C_u_k Hcuk].
    cprove idtac.
    transitivity (| g k|).
    1:{ eapply Nat.eq_le_incl. symmetry. eapply Hg. }
    destruct Hcuk as ([? [-> H1]] & H2).
    etransitivity.
    1:{ eapply Hg. eapply H1. }
    eapply H. cbn. firstorder.
Qed.

Lemma dist_again_strong R :
  weakly_total R -> enumerable (fun '(x,y) => R x y) ->
  exists d, forall x, ~~ exists v_x, R x v_x /\ forall y, C (v_x) y -> y <= |x| + d.
Proof.
  intros H1 H2.
  destruct (dist_rel R H1 H2) as [d Hd].
  exists d. intros x.
  destruct (Hd x) as [y_x Hyx].
  cunwrap. destruct Hyx as (v_x & H3 & H4 & H5).
  cprove exists v_x. split; eauto.
  intros.
  etransitivity. 1:eapply H; eauto.
  lia.
Qed.

Lemma R_undecidable_strong :
  ~ decidable R.
Proof.
  intros Hdec.
  destruct (dist_again_strong (fun k x => |x| = k /\ R x)) as [d Hd].
  - exact unboundedR.
  - cbn. eapply decidable_enumerable. 2:eauto.
    eapply DecidabilityFacts.decidable_iff.
    eapply DecidabilityFacts.decidable_iff in Hdec. destruct Hdec.
    econstructor. intros (x, y).
    exact _.
  - eapply length_sublinear with (d := d).
    intros k.
    specialize (Hd k).
    unshelve cstart.  1:eapply le_dec. cunwrap.
    destruct Hd as (x_k & [H1 H2] & H3).
    rewrite <- H1 at 1.
    pose proof (C_weakly_total x_k) as Hk. cunwrap.
    destruct Hk as [C_u_k Hcuk].
    destruct Hcuk as ([? [-> H4]] & H5).
    cprove idtac.
    etransitivity. 1:{ eapply H2. eauto. }
    eapply H3. cbn. firstorder.
Qed.

End Kolmogorov.

Axiom ϕ : nat -> nat ↛ nat.
Axiom EPF : forall f : nat -> nat ↛ nat,
    exists γ, forall i, ϕ (γ i) ≡{_} f i.

Theorem Invariance Θ :
  (forall f, exists d, forall x, forall v_x, f x ▷ v_x -> exists y_x, Θ y_x ▷ v_x /\ | y_x| < |x| + d) ->
  forall Θ', exists d, forall x y, C Θ x y -> forall y', C Θ' x y' -> y < y' + d.
Proof.
  intros Hopt Θ'.
  destruct (Hopt Θ') as [d Hd].
  exists d.
  intros x ? ((y & -> & H) & Hleast) _ ((y' & -> & H2) & Hleast2).
  eapply Hd in H2 as [v_x [H1 H2]].
  eapply Nat.le_lt_trans with (2 := H2), Hleast. eauto.
Qed.

Theorem bla Θ :
  (forall f, exists d, forall x, forall v_x, f x ▷ v_x -> exists y_x, Θ y_x ▷ v_x /\ | y_x| < |x| + d) ->
  forall x, exists y, Θ y ▷ x.
Proof.
  intros Hopt x.
  destruct (Hopt (@ret _ nat)) as [d Hd].
  specialize (Hd x x (ret_hasvalue x)) as [y [H1 _]].
  eauto.
Qed.

Module universal.

  Definition C_ u := the_least (fun x s => exists y, s = |y| /\ ϕ u y ▷ x).

  Definition universal u := forall c, exists x, forall y, ϕ c y ≡{_} (ϕ u ⟨x,y⟩).

  Theorem Invariance_strong u :
    universal u -> forall Θ, exists d,
    forall x y, C_ u x y -> forall y', C Θ x y' -> y <= y' + d.
  Proof.
    intros Hu Θ.
    destruct (EPF (fun _ => Θ)) as [γ Hγ].
    specialize (Hγ 0). remember (γ 0) as u'.
    destruct (Hu u') as [d Hd]. exists (|d|).
    intros x ? ((y & -> & H) & Hleast) _ ((y' & -> & H2) & Hleast2).
    eapply Hγ, Hd in H2.
    rewrite Hleast. 2: eauto.
    rewrite length_pair. lia.
  Qed.

  Theorem Invariance u :
    universal u -> forall u', exists d,
    forall x y, C_ u x y -> forall y', C_ u' x y' -> y <= y' + d.
  Proof.
    intros Hu u'.
    eapply Invariance_strong, Hu.
  Qed.

  Lemma EPF_univ_tot {u} : universal u ->
                           forall f : nat -> nat, exists c, forall x, ϕ u ⟨c,x⟩ ▷ f x.
  Proof.
    intros Hu f.
    specialize (EPF (fun _ x => ret (f x))) as [γ H].
    destruct (Hu (γ 0)) as [c Hc].
    exists c. intros. cbn in * |-. red in H, Hc.
    rewrite <- Hc, H. eapply ret_hasvalue.
  Qed.

  Lemma Θ_total u :
    universal u -> forall x, exists y, ϕ u y ▷ x.
  Proof.
    intros Hu x.
    destruct (EPF_univ_tot Hu (fun _ => x)) as [c Hc % fun H => H 0].
    eauto.
  Qed.

  Section fix_u.

  Variable u : nat.
  Variable univ_u : universal u.

  Definition N (x : nat) :=
    exists y, ϕ u y ▷ x /\ |y| < |x|.

  Lemma simple_N :
    simple N.
  Proof.
    eapply simple_N_strong.
    intros f.
    specialize (EPF (fun _ => f)) as [γ H].
    destruct (univ_u (γ 0)) as [c Hc].
    exists (|c| + 1). intros x.
    exists (⟨ c, x ⟩). intros v_x Hvx.
    split.
    + eapply Hc, H, Hvx.
    + autorewrite with length. lia.
  Qed.

  End fix_u.

  Definition strongly_universal u := forall c i, ϕ c i ≡{_} ϕ u ⟨c,i⟩.

  Lemma strongly_universal_universal u :
    strongly_universal u -> universal u.
  Proof.
    intros H c'. red in H. setoid_rewrite <- H. exists c'. reflexivity.
  Qed.

  Variable invert : nat -> nat * nat.
  Variable invert_spec :     (forall x y, invert ⟨x, y⟩ = (x,y)).

  Lemma strongly_universal_ex :
    exists u, strongly_universal u.
  Proof.
    destruct (EPF (fun _ => fun ci => let '(c,i) := invert ci in ϕ c i)) as [γ Hγ].
    exists (γ 0). intros c i.
    specialize (Hγ 0 ⟨c,i⟩). cbn in *.
    rewrite invert_spec in Hγ. symmetry. exact Hγ.
  Qed.

  Module universal_ex.

    Definition info x := tonat (repeat true (|x|) ++ [false]).

    Definition invert x :=
      let l := ofnat x in
      if list.list_find (fun x => x = false) l is Some (n, _)
      then
        let l := skipn (n + 1) l in
        (tonat (firstn n l), tonat (skipn n l))
      else
        (0, 0).

    Hint Rewrite repeat_length : list.

    Lemma info_spec : forall x y, invert ⟨⟨info x, x⟩, y⟩ = (x, y).
    Proof.
      intros x y.
      unfold invert, info.
      autorewrite with length.
      erewrite list.list_find_app_l.
      2:{ eapply list.list_find_app_l.
          etransitivity.
          1:{ eapply list.list_find_app_r.
              eapply list.list_find_None.
              eapply Forall_forall.
              intros ? ? % repeat_spec. congruence.
          }
          cbn. destruct decide; try congruence.
          unfold prod_map. cbn.
          now rewrite repeat_length.
      }
      replace (|x| + 1) with (length (repeat true (|x|) ++ [false])) by now autorewrite with list.
      rewrite list.drop_app_le. 2: autorewrite with list; lia.
      rewrite list.drop_app, list.take_app, list.drop_app.
      now autorewrite with length.
    Qed.

    Lemma universal_ex :
      exists u, universal u.
    Proof.
      destruct (EPF (fun _ => fun ci => let '(c,i) := invert ci in ϕ c i)) as [γ Hγ].
      exists (γ 0). intros c. exists ⟨info c,c⟩. intros i.
      specialize (Hγ 0 ⟨⟨info c,c⟩,  i⟩). cbn in *.
      rewrite info_spec in Hγ. symmetry. eapply Hγ.
    Qed.

  End universal_ex.

  Definition C := the_least (fun x s => exists c e, s = |c| + |e| /\ ϕ c e ▷ x).

  Lemma strongly_universal_equivalence u :
    strongly_universal u -> forall x y, C x y <-> C_ u x y.
  Proof.
    intros Huniv x y. rename u into c.  eapply the_least_pred_equiv.
    intros e. split.
    - intros (e' & i & -> & HH).
      eexists. eexists. 1:now rewrite <- length_pair.
      edestruct Huniv as [H _]. now eapply H.
    - intros (i & -> & Hn). exists (tonat nil), i.
      split. 1:now autorewrite with length.
      eapply Huniv. now autorewrite with length.
  Qed.

  Definition N_again x :=
    exists c e, ϕ c e ▷ x /\ |c| + |e| < |x|.

  Lemma strongly_universal_equivalence_N u :
    strongly_universal u -> forall x, N u x <-> N_again x.
  Proof.
    intros Huniv x. split.
    - intros (c & H1 & H2). exists (tonat nil), c. split; autorewrite with length.
      + eapply Huniv. now autorewrite with length.
      + eauto.
    - intros (c & e & H1 & H2).
      exists ⟨c,e⟩. split.
      + edestruct Huniv as [H _]. now eapply H.
      + now autorewrite with length.
  Qed.

End universal.

Module fixed_input.

  Variable input : nat.

  Definition C := the_least (fun x s => exists c, s = |c| /\ ϕ c input ▷ x).

  Lemma Θ_total x :
    exists c, ϕ c input ▷ x.
  Proof.
    destruct (EPF (fun _ _ => ret x)) as [γ H].
    exists (γ 0). eapply H, ret_hasvalue.
  Qed.

  Definition N (x : nat) :=
    exists c, ϕ c input ▷ x /\ |c| < |x|.

  Variable dist_part :
    forall f : nat ↛ nat, exists γ d, forall x, ϕ (γ x) input ≡{_} f x /\ (ter (f x) ->  |γ x| < |x| + d).

  Lemma simple_N : simple N.
  Proof.
    eapply simple_N_strong.
    intros f.
    destruct (dist_part f) as (γ & d & H). exists d.
    intros x. exists (γ x). firstorder.
  Qed.

End fixed_input.


(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.
From mathcomp Require Import bigop ssralg poly polydiv matrix.

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

Import GRing.Theory.
Local Open Scope ring_scope.

(** * Euclidean algorithm for decoding *)

(** OUTLINE:
- Module Euclid.
- Section euclid_stop.
- Section euclid_lemma.
*)

Lemma pair_ind (P : nat -> Type) :
  P O -> P 1%nat ->
  (forall m, P m * P m.+1 -> P m.+2) ->
  forall m, P m.
Proof.
move=> P0 P1 H m.
suff : (P m * P m.+1)%type by case.
elim: m => // m [H1 H2]; split; by [assumption | apply H].
Qed.

Module Euclid.

Section euclid_algo.

Variable (F : fieldType).
Variable r0 r1 : {poly F}.
(* r0 to be init with 'X^t.*2, r1 with the syndrome *)

Fixpoint r i :=
  if i is i1.+1 then
    if i1 is i0.+1 then r i0 %% r i1
    else r1
  else r0.

Definition q k :=
  if k is k1.+1 then
    if k1 is k0.+1 then r k0 %/ r k1
    else 0
  else 0.

Lemma qE k : q k.+2 = r k %/ r k.+1.
Proof. by []. Qed.

Lemma rE k : r k = q k.+2 * r k.+1 + r k.+2.
Proof. by rewrite /= -divp_eq. Qed.

Section uv_sect.

Variable P0 P1 : {poly F}.

Fixpoint uv k :=
  if k is k1.+1 then
    if k1 is k0.+1 then - q k * uv k1 + uv k0
    else P1
  else P0.

Lemma uvE k : uv k.+2 = - q k.+2 * uv k.+1 + uv k.
Proof. done. Qed.

End uv_sect.

Definition v0 : {poly F} := 0.
Definition v1 : {poly F} := 1.
Definition v k := uv v0 v1 k.

Definition u0 : {poly F} := 1.
Definition u1 : {poly F} := 0.
Definition u k := uv u0 u1 k.

Local Notation "'`r'" := (r).
Local Notation "'`q'" := (q).
Local Notation "'`u'" := (u).
Local Notation "'`v'" := (v).

(* McEliece, p.245, table 9.2, slight difference *)
Lemma relationA k : v k.+1 * r k - v k * r k.+1 = (- 1)^+k *: r0.
Proof.
elim: k => [|k IH].
  by rewrite /= /v0 mul0r subr0 expr0 scale1r /v1 mul1r.
rewrite {1}[k.+1]lock [in X in X * _ - _ = _]/= -lock.
rewrite {5}[k.+1]lock [in X in _ - _ * X= _]/= -lock.
move/eqP: (divp_eq (r k) (r k.+1)).
rewrite addrC -subr_eq => /eqP <-.
rewrite mulrDl mulrDr opprD addrA.
rewrite mulrN mulNr opprK addrC !addrA mulNr mulrC mulrAC subrr add0r.
by rewrite exprS -scalerA scaleN1r -IH opprB.
Qed.

(* McEliece, p.245, table 9.2, slight difference *)
Lemma relationB k : u k.+1 * r k - u k * r k.+1 = (- 1)^+k.+1 *: r1.
Proof.
elim: k => [|k IH].
  by rewrite /= /u1 /u0 mul0r add0r mul1r expr1 scaleN1r.
rewrite {1}[k.+1]lock [in X in X * _ - _ = _]/= -lock.
rewrite {5}[k.+1]lock [in X in _ - _ * X= _]/= -lock.
move/eqP: (divp_eq (r k) (r k.+1)).
rewrite addrC -subr_eq => /eqP <-.
rewrite mulrDl mulrDr opprD addrA.
rewrite mulrN mulNr opprK addrC !addrA mulNr mulrC mulrAC subrr add0r.
by rewrite exprS -scalerA scaleN1r -IH opprB.
Qed.

(* McEliece, p.245, table 9.2, relation C *)
Lemma vu i : `v i.+1 * `u i - `v i * `u i.+1 = (- 1)^+i.
Proof.
elim: i => [|k IH].
  by rewrite /= expr0 /v1 mul1r /u0 /v0 mul0r subr0.
rewrite /v /u 2!uvE.
transitivity ((- q k.+2 * v k.+1) * u k.+1 + v k * u k.+1 +
  v k.+1 * (q k.+2 * u k.+1) - v k.+1 * u k).
  rewrite mulrDl -3!addrA; congr (_ + (_ + _)).
  rewrite mulrDr opprD; congr (_ - _).
  by rewrite mulNr mulrN opprK.
rewrite exprS -IH mulNr mul1r opprD opprK [in RHS]addrC; congr (_ - _).
rewrite addrC addrA -[RHS]add0r; congr (_ + _).
by rewrite mulrC -mulrA (mulrC (v k.+1)) mulrA 2!mulNr subrr.
Qed.

(* McEliece, p.245, table 9.2, relation D *)
Lemma ruv i : `r i = `u i * `r 0 + `v i * `r 1.
Proof.
elim/pair_ind: i => [||k [Hk1 Hk]].
  by rewrite mul1r /= /v0 mul0r addr0.
  by rewrite /= /v1 mul1r mul0r add0r.
rewrite /v uvE.
transitivity (- q k.+2 * (u k.+1 * r 0 + v k.+1 * r 1) + (u k * r 0 + v k * r 1)).
  by rewrite -Hk -Hk1 (rE k) addrA addrC [in X in _ + X]addrC mulNr subrr addr0.
rewrite mulrDl mulrDr mulrA -2!addrA; congr (_ + _).
rewrite mulrDl [in RHS]addrC mulrA -addrA; congr (_ + _); by rewrite addrC.
Qed.

Lemma ltn_size_r i : 1 <= i -> `r i != 0 -> size (`r i.+1) < size (`r i).
Proof.
elim: i => // -[_ _ r10|k IH _ rn2]; first by rewrite /= ltn_modp.
by rewrite {1}[k.+2]lock [in X in X < _]/= -lock ltn_modp.
Qed.

Hypothesis r1_r0 : size r1 <= size r0.

Lemma leq_size_r n : (forall k, k < n -> r k != 0) ->
  size (r n) <= size (r 0) - n.-1.
Proof.
elim/pair_ind: n => [_|_|n [H1 H2 H]].
  by rewrite /= subn0.
  by rewrite /= subn0.
rewrite [n.+1]lock /= -lock.
move: (H _ (ltnSn n.+1)) => rn10.
move: (ltn_modpN0 (r n) rn10) => K1.
have Htmp : (forall k : nat, k < n.+1 -> r k != 0).
  move=> k kn.
  apply H.
  by rewrite ltnW.
move: (leq_trans K1 (H2 Htmp)).
rewrite [in X in _ < _ - X -> _]/= => Ktmp.
rewrite subnS -ltnS prednK //.
rewrite [in X in _ < X - _]/= in Ktmp.
apply: (leq_ltn_trans _ Ktmp).
done.
Qed.

End euclid_algo.

End Euclid.

Section euclid_stop.

Variables (F : fieldType) (n : nat) (y : 'rV[F]_n) (t : nat).
Variable r0 r1 : {poly F}.

Local Notation "'`r'" := (Euclid.r r0 r1).
Local Notation "'`q'" := (Euclid.q r0 r1).

Definition euclid_cont := [pred k | [forall i : 'I_k.+1, t < size (`r i)]].

Lemma euclid_next i j : ~~ euclid_cont i && (i <= j) ==> ~~ euclid_cont j.
Proof.
apply/implyP => /andP [H1 H2].
apply: contra H1 => /forallP /= H1.
apply/forallP => /= x.
have @b : 'I_j.+1 by exists x; rewrite ltnS (leq_trans _ H2) // -ltnS.
by rewrite (_ : `r x = `r b).
Qed.

Lemma euclid_back i j : euclid_cont j && (i <= j) ==> euclid_cont i.
Proof.
apply/implyP => /andP [/forallP H1 H2].
apply/forallP => /= x.
have @b : 'I_j.+1 by exists x; rewrite ltnS (leq_trans _ H2) // -ltnS.
by rewrite (_ : `r x = `r b).
Qed.

Lemma ex_euclid_cont (tr0 : t < size r0) : exists k, euclid_cont k.
Proof.
exists O; apply/forallP => /= j.
by move: (ltn_ord j); rewrite ltnS leqn0 => /eqP ->.
Qed.

Lemma euclid_cont_size_r (r1_eq_r0 : size r1 <= size r0) :
  forall k, euclid_cont k -> k <= size (`r 0).
Proof.
case/boolP : [exists k : 'I_(size r0).+1, (size (`r k)) <= t] =>
  [/existsP[k Hk i Hi]|].
  have Pk : ~~ euclid_cont k.
    rewrite /= negb_forall; apply/existsP; exists ord_max => /=.
    by rewrite -ltnNge.
  have : forall j, euclid_cont j -> j < k.
    move=> j Pj.
    rewrite ltnNge; apply: contra Pk => kj.
    move: (euclid_back k j) => /implyP; rewrite Pj kj; by apply.
  move/(_ i Hi) => ik.
  rewrite /=.
  move: (ltn_ord k).
  rewrite ltnS.
  apply: (leq_trans).
  by rewrite -ltnS ltnW.
rewrite negb_exists => /forallP abs i /forallP Pi.
move: (Euclid.leq_size_r (r1_eq_r0)) => size_r.
have {abs} : forall k : nat, k < (size r0).+1 -> `r k != 0.
  move=> k Hk.
  rewrite -size_poly_eq0.
  rewrite /= in abs.
  move: (abs (Ordinal Hk)) => Ht.
  rewrite -ltnNge /= in Ht.
  rewrite -lt0n.
  by rewrite (leq_trans _ Ht).
move/size_r => {size_r}.
rewrite subnn leqn0 leqNgt => /eqP size_r0.
apply/negP => abs.
have {abs}abs : (size (`r 0)).+1 < i.+1 by [].
move: (Pi (Ordinal abs)).
by rewrite /= size_r0 leqn0 -(negbK (_ == _)) -lt0n.
Qed.

Definition stop' (tr0 : t < size r0) (r1_leq_r0 : size r1 <= size r0) :=
  ex_maxn (ex_euclid_cont tr0) (euclid_cont_size_r r1_leq_r0).
Definition stop := if Bool.bool_dec (t < size r0) true is left H1 then
                     if Bool.bool_dec (size r1 <= size r0) true is left H2 then
                       (stop' H1 H2).+1
                     else O else O.

Lemma stop'_is_before (tr0 : t < size r0) (r1_leq_r0 : size r1 <= size r0) :
  t < size (`r (stop' tr0 r1_leq_r0)).
Proof.
rewrite /stop'; case: ex_maxnP => i Hi _.
move: Hi; by rewrite /euclid_cont => /forallP /(_ (Ordinal (ltnSn i))).
Qed.

Lemma stop_is_after (tr0 : t < size r0) (r1_leq_r0 : size r1 <= size r0) :
  size (`r stop) <= t.
Proof.
rewrite /stop.
case: Bool.bool_dec => H1; last by rewrite tr0 in H1.
case: Bool.bool_dec => H2; last by rewrite r1_leq_r0 in H2.
rewrite /stop'; case: ex_maxnP => i Hi ij.
rewrite leqNgt; apply/negP => abs.
suff /ij : euclid_cont i.+1 by rewrite ltnn.
apply/forallP => /= x.
case/boolP : (x == ord_max) => [/eqP->//|Hx].
have {Hx}Hx : x < i.+1 by rewrite ltn_neqAle Hx /= -ltnS.
by move/forallP : Hi => /(_ (Ordinal Hx)).
Qed.

Lemma ltn_size_r_stop l (tr0 : t < size r0) (r1_leq_r0 : size r1 <= size r0) :
  1 <= l < stop -> size (`r l.+1) < size (`r l).
Proof.
move=> lEu.
apply Euclid.ltn_size_r => //.
  by case/andP : lEu.
case/andP : lEu => l0.
rewrite /stop.
case: Bool.bool_dec => H1; last by rewrite tr0 in H1.
case: Bool.bool_dec => H2; last by rewrite r1_leq_r0 in H2.
rewrite /stop'; case: ex_maxnP => i Hi H li.
move/forallP in Hi; move: (Hi (Ordinal li)).
rewrite /= ltnNge; apply: contra => /eqP ->.
by rewrite size_poly0.
Qed.

Lemma r10_stop'0 (tr0 : t < size r0) (r1_leq_r0 : size r1 <= size r0) :
  r1 = 0 -> stop' tr0 r1_leq_r0 = O.
Proof.
move=> r10; rewrite /stop'; case: ex_maxnP => i Pi Hi.
have P1 : ~~ euclid_cont 1%nat.
  rewrite /= negb_forall.
  apply/existsP; exists (lift ord0 ord0).
  by rewrite /= r10 size_poly0 leqn0 -lt0n.
case: i Pi Hi => // i Pi Hi.
move: (euclid_next 1 i.+1).
by rewrite P1 Pi.
Qed.

Lemma q0 : `q 0 = 0. Proof. by []. Qed.

Lemma q1 : `q 1 = 0. Proof. by []. Qed.

Lemma q2 : `q 2 = r0 %/ r1. Proof. by []. Qed.

(* NB: used in cyclic_decoding.v *)
Lemma size_rstop (tr0 : t < size r0) (r1_leq_r0 : size r1 <= size r0) :
  size (`r stop) <= t.
Proof.
rewrite /stop.
case: Bool.bool_dec => H1; last by rewrite tr0 in H1.
case: Bool.bool_dec => H2; last by rewrite r1_leq_r0 in H2.
rewrite /stop'.
case: ex_maxnP => i Pi Hi.
rewrite leqNgt.
apply/negP => abs.
have Pi1 : euclid_cont i.+1.
  rewrite /=.
  apply/forallP => x.
  move: (ltn_ord x).
  rewrite ltnS leq_eqVlt.
  case/orP => [/eqP ->{x} // | xi].
  rewrite /euclid_cont /= in Pi.
  move/forallP in Pi.
  by move: (Pi (Ordinal xi)).
move: (Hi _ Pi1).
by rewrite ltnn.
Qed.

Local Notation "'`v'" := (Euclid.v r0 r1).

Lemma ltn_size_r_stop_r0 l (tr0 : t < size r0) (r1_leq_r0 : size r1 <= size r0) :
  1 <= l < stop -> size (`r l.+1) < size (`r 0).
Proof.
elim: l => // -[_ /=|l IH H].
  rewrite /stop.
  case: Bool.bool_dec => H1; last by rewrite tr0 in H1.
  case: Bool.bool_dec => H2; last by rewrite r1_leq_r0 in H2.
  rewrite /stop'; case: ex_maxnP => i Hi ij i1.
  move: Hi => /forallP /(_ (Ordinal i1)) H.
  by rewrite (leq_trans _ r1_leq_r0) // ltn_modpN0 // -size_poly_eq0 -lt0n (leq_trans _ H).
rewrite (leq_trans (ltn_size_r_stop _ _ H)) // ltnW //.
apply IH => /=.
simpl in H.
by rewrite ltnW.
Qed.

Lemma leq_size_v_incr i (tr0 : t < size r0) (r1_leq_r0 : size r1 <= size r0) :
  i < stop -> size (`v i) <= size (`v i.+1).
Proof.
elim: i => [? /= | i ih istop].
  by rewrite /Euclid.v0 /Euclid.v1 size_poly0 size_poly1.
rewrite {2}/Euclid.v Euclid.uvE.
do 2 rewrite -/(Euclid.v _ _ _).
case/boolP : (`v i.+1 == 0) => vi1_eq0.
  by rewrite (eqP vi1_eq0) size_poly0.
destruct i.
  rewrite /= /Euclid.v0 /Euclid.v1 size_poly1 addr0 mulr1 size_opp.
  have r10 : r1 != 0.
    move: istop.
    rewrite /stop.
    case: Bool.bool_dec => H1; last by rewrite tr0 in H1.
    case: Bool.bool_dec => H2; last by rewrite r1_leq_r0 in H2.
    rewrite /stop'; case: ex_maxnP => l Hl Hi il.
    move: Hl => /forallP /(_ (Ordinal il)) H.
    by rewrite -size_poly_eq0 -lt0n (leq_trans _ H).
  rewrite size_divp //.
  rewrite -subn1 subnBA; last by rewrite lt0n size_poly_eq0.
  by rewrite addnC addSn add0n subSn.
have ri20 :`r i.+2 != 0.
    move: istop.
    rewrite /stop.
    case: Bool.bool_dec => H1; last by rewrite tr0 in H1.
    case: Bool.bool_dec => H2; last by rewrite r1_leq_r0 in H2.
    rewrite /stop'; case: ex_maxnP => l Hl Hi il.
    move: Hl => /forallP /(_ (Ordinal il)) H.
    by rewrite -size_poly_eq0 -lt0n (leq_trans _ H).
have qi3 : 1 < size (`q i.+3).
  rewrite {1}Euclid.qE size_divp //.
  rewrite -subn1 subnBA ?lt0n ?size_poly_eq0 // addn1 subSn; last first.
    by rewrite ltnW // ltn_size_r_stop //= ltnW.
  by rewrite ltnS subn_gt0 ltn_size_r_stop //= ltnW.
rewrite [in X in _ <= X]size_addl.
  rewrite mulNr size_opp size_mul //; last first.
    by rewrite -size_poly_eq0 -lt0n (leq_trans _ qi3).
  rewrite -subn1 -addnBA; last by rewrite lt0n size_poly_eq0.
  rewrite (@leq_trans (1 + (size (`v i.+2) - 1))) //.
    by rewrite add1n subn1 prednK // lt0n size_poly_eq0.
  by rewrite leq_add2r (leq_trans _ qi3).
rewrite mulNr size_opp.
rewrite size_mul // -?size_poly_eq0 -?lt0n ?(leq_trans _ qi3) //.
rewrite -subn1 -addnBA; last by rewrite lt0n size_poly_eq0.
rewrite (@leq_ltn_trans (1 + (size (`v i.+2) - 1))) //; last first.
  by rewrite ltn_add2r.
rewrite add1n subn1 prednK // ?lt0n ?size_poly_eq0 // ih //.
by rewrite ltnW.
Qed.

Lemma relationF k (tr0 : t < size r0) (r1_leq_r0 : size r1 <= size r0) :
  k < stop -> ((size (`v k.+1)).-1 + (size (`r k)).-1 = (size (`r 0)).-1)%N.
Proof.
elim: k => [?|k IH H].
  by rewrite /= /Euclid.v1 /Euclid.v0 size_poly1 add0n.
rewrite {1}/Euclid.v Euclid.uvE -2!/(Euclid.v _ _ _) Euclid.qE.
have rk1_neq0 : `r k.+1 != 0.
  move: H; rewrite /stop.
  case: Bool.bool_dec => H1; last by rewrite tr0 in H1.
  case: Bool.bool_dec => H2; last by rewrite r1_leq_r0 in H2.
  rewrite /stop'; case: ex_maxnP => i Hi ij ki.
  move: Hi => /forallP/(_ (Ordinal ki)) H.
  by rewrite -size_poly_eq0 -lt0n (leq_trans _ H).
have rk_neq0 : `r k != 0.
  move: H; rewrite /stop.
  case: Bool.bool_dec => H1; last by rewrite tr0 in H1.
  case: Bool.bool_dec => H2; last by rewrite r1_leq_r0 in H2.
  rewrite /stop'; case: ex_maxnP => i Hi ij ki.
  move: Hi => /forallP/(_ (Ordinal (ltnW ki))) H.
  by rewrite -size_poly_eq0 -lt0n (leq_trans _ H).
have vk1_neq0 : `v k.+1 != 0.
  destruct k; first by rewrite /= oner_neq0.
  rewrite -size_poly_eq0.
  apply/eqP => abs.
  move: {IH}(IH (ltnW H)); rewrite abs add0n => /(congr1 (fun x => x.+1)).
  rewrite prednK; last by rewrite lt0n size_poly_eq0.
  rewrite prednK; last by rewrite (leq_trans _ tr0).
  apply/eqP.
  rewrite ltn_eqF //.
  destruct k => //.
    move: abs.
    rewrite /= addr0 mulr1 size_opp => /eqP.
    rewrite size_poly_eq0 divp_eq0 ltnNge r1_leq_r0 orbF (negbTE rk_neq0) orbF.
    rewrite -size_poly_eq0 => abs.
    exfalso.
    move/eqP : abs.
    apply/eqP.
    rewrite -lt0n.
    by rewrite (leq_trans _ tr0).
  apply (ltn_size_r_stop_r0) => //=.
  by rewrite ltnW // ltnW.
rewrite size_addl; last first.
  rewrite mulNr size_opp.
  destruct k.
    rewrite /= /Euclid.v0 /Euclid.v1 size_poly0 mulr1 lt0n size_poly_eq0 divp_eq0.
    by rewrite ltnNge r1_leq_r0 orbF (negbTE rk1_neq0) orbF.
  have Htmp : 1 < size (`q k.+3).
    rewrite Euclid.qE size_divp // -subn1 subnBA; last by rewrite lt0n size_poly_eq0.
    rewrite addn1 subSn; last first.
      by rewrite ltnW // ltn_size_r_stop //= ltnW.
    by rewrite ltnS subn_gt0 ltn_size_r_stop //= ltnW.
  rewrite -Euclid.qE size_mul //; last first.
    by rewrite -size_poly_eq0 -lt0n (leq_trans _ Htmp).
  rewrite -subn1 -addnBA; last first.
     by rewrite lt0n size_poly_eq0.
  rewrite (@leq_ltn_trans (1 + (size (`v k.+2)).-1))%N //.
    rewrite add1n prednK.
      rewrite leq_size_v_incr //.
      by rewrite ltnW.
    by rewrite lt0n size_poly_eq0.
  rewrite add1n subn1 prednK; last first.
    by rewrite lt0n size_poly_eq0.
  rewrite -subn1 addnBA ?lt0n ?size_poly_eq0 // (@leq_ltn_trans (1 + size (`v k.+2) -1)) //.
    by rewrite add1n subn1.
  rewrite -addnBA ?lt0n ?size_poly_eq0 // -addnBA ?lt0n ?size_poly_eq0 //.
  by rewrite ltn_add2r //.
have H1 : size (`r k.+1) <= size (`r k).
  destruct k => //.
  rewrite ltnW //; apply ltn_size_r_stop => //.
  by rewrite /= ltnW.
rewrite size_mul //; last by rewrite oppr_eq0 divpN0.
rewrite size_opp.
rewrite size_divp //.
rewrite -subn2.
set a := size (`r k.+1).
rewrite addnC.
rewrite addnBA; last first.
  rewrite {}/a.
  rewrite -subn1 subnBA; last by rewrite lt0n size_poly_eq0.
  by rewrite addn1 subSn // addSn ltnS addn_gt0 (lt0n (size (`v k.+1))) size_poly_eq0 vk1_neq0 orbT.
rewrite addnA.
rewrite subnKC; last by rewrite {}/a (leq_trans _ H1) // leq_pred.
rewrite -IH; last by rewrite ltnW.
rewrite -[in X in (_ = _ + X)%N]subn1.
rewrite addnBA; last by rewrite lt0n size_poly_eq0.
rewrite [in RHS]addnC subn1.
rewrite subn2.
congr (_ .-1).
rewrite -subn1.
rewrite -addnBA; last by rewrite lt0n size_poly_eq0.
by rewrite subn1.
Qed.

Lemma ltn_size_q' i (tr0 : t < size r0) (r1_ltn_r0 : size r1 < size r0) :
  i < stop -> `r i.+1 != 0 -> 1 < size (`q i.+2).
Proof.
move=> istop Hr; rewrite Euclid.qE.
case: i => [|i] in Hr istop *.
  rewrite size_divp //= ltn_subRL addn1 prednK //.
  by rewrite lt0n size_poly_eq0.
rewrite size_divp // ltn_subRL addn1 prednK; last by rewrite lt0n size_poly_eq0.
by rewrite ltn_size_r_stop // ltnW.
Qed.

Lemma ltn_size_q i (tr0 : t < size r0) (r1_ltn_r0 : size r1 < size r0) :
  i.+1 < stop -> 1 < size (`q i.+2).
Proof.
move=> istop.
apply: (ltn_size_q' tr0 r1_ltn_r0 (ltn_trans (ltnSn _) istop)).
move: istop.
rewrite /stop.
case: Bool.bool_dec => H1; last by rewrite tr0 in H1.
case: Bool.bool_dec => H2; last by rewrite (ltnW r1_ltn_r0) in H2.
rewrite ltnS /stop'.
case: ex_maxnP => l Hl Hi il.
have : euclid_cont i.+1 by move: (euclid_back i.+1 l); rewrite Hl il.
rewrite /euclid_cont /= => /forallP/(_ (Ordinal (ltnSn i.+1))).
rewrite -size_poly_eq0; by case: (size _).
Qed.

Lemma size_v01 : size (`v 0) < size (`v 1).
Proof.
by rewrite /= /Euclid.v0 /Euclid.v1 size_poly0 size_poly1.
Qed.

Lemma size_v12 (r1_leq_r0 : size r1 <= size r0) : r1 != 0 -> size (`v 1) <= size (`v 2).
Proof.
move=> r10.
rewrite /= /Euclid.v1 /Euclid.v0 addr0 mulr1 size_opp.
rewrite size_divp // -subn1 subnBA ?lt0n ?size_poly_eq0 // size_poly1.
by rewrite addnC -addnBA.
Qed.

Lemma size_v_incr_new i (tr0 : t < size r0) (r1_leq_r0 : size r1 <= size r0) :
  1 < i < stop -> size (`v i) < size (`v i.+1).
Proof.
case/andP => i1 istop.
move: (relationF tr0 r1_leq_r0 istop) => H1.
destruct i => //.
move: (relationF tr0 r1_leq_r0(ltnW istop)) => H2.
move: (ltn_size_r_stop).
have : 0 < i < stop.
  destruct i => //=.
  by rewrite ltnW.
move=> H3.
move/(_ _ tr0 r1_leq_r0 H3) => H4.
move: H1.
move/(congr1 (fun x => x.+1))/eqP.
Abort.

Lemma size_v_incr (tr0 : t < size r0) (r1_ltn_r0 : size r1 < size r0) i :
  i < stop -> size (`v i) < size (`v i.+1).
Proof.
elim: i => [_ /= | i ih istop].
  by rewrite /Euclid.v0 /Euclid.v1 size_poly0 size_poly1.
have Hq : 1 < size (`q i.+2) by apply ltn_size_q.
move=> [:H1 H2].
rewrite /Euclid.v Euclid.uvE mulNr size_addl size_opp.
  rewrite size_mul; last 2 first.
    abstract: H1; by rewrite -size_poly_eq0 -leqn0 -ltnNge (ltn_trans _ Hq).
    abstract: H2. rewrite -size_poly_eq0  -leqn0 -ltnNge (leq_ltn_trans _ (ih _)) //.
    by rewrite (ltn_trans _ istop).
  by rewrite -subn1 ltn_subRL ltn_add2r.
rewrite size_mul // -subn1 ltn_subRL (@ltn_trans (1 + size (`v i.+1))) //.
  by rewrite ltn_add2l ih // (ltn_trans _ istop).
by rewrite ltn_add2r.
Qed.

Lemma ltn_size_v (tr0 : t < size r0) (r1_ltn_r0 : size r1 < size r0) i :
  i.+1 < stop -> size (`v i) < size (- `q i.+2 * `v i.+1).
Proof.
move=> istop.
have Hq : 1 < size (`q i.+2) by apply ltn_size_q.
rewrite mulNr size_opp.
rewrite size_mul; last 2 first.
  by rewrite -size_poly_eq0 -leqn0 -ltnNge (ltn_trans _ Hq).
  rewrite -size_poly_eq0 -lt0n.
  by rewrite (leq_ltn_trans _ (@size_v_incr tr0 r1_ltn_r0 _ (ltn_trans (ltnSn _) istop))).
rewrite -subn1 ltn_subRL (@ltn_trans (1 + size (`v i.+1))) // ?ltn_add2r //.
by rewrite ltn_add2l size_v_incr // (ltn_trans _ istop).
Qed.

Lemma size_v_sum (tr0 : t < size r0) (r1_ltn_r0 : size r1 < size r0) k :
  k < stop -> (size (`v k.+1)).-1 = (\sum_(i < k.+1) (size (`q i.+1)).-1)%N.
Proof.
elim: k => [_ | k IH kstop].
  by rewrite big_ord_recr /= big_ord0 /Euclid.v1 size_poly1 size_poly0.
transitivity ((size (`q k.+2)).-1 + (size (`v k.+1)).-1)%N; last first.
  rewrite {}IH ?(ltn_trans _ kstop) //.
  by rewrite [in RHS]big_ord_recr addnC.
rewrite {1}/Euclid.v Euclid.uvE size_addl; last by rewrite ltn_size_v.
rewrite mulNr size_opp.
have H1 : 0 < size (`q k.+2) by rewrite (ltn_trans _ (ltn_size_q tr0 r1_ltn_r0 kstop)).
have H2 : 0 < size (`v k.+1).
  by rewrite (leq_ltn_trans _ (@size_v_incr tr0 r1_ltn_r0 _ (ltn_trans (ltnSn _) kstop))).
rewrite size_mul -?size_poly_eq0 -?lt0n //.
suff : (forall a b, 0 < a -> 0 < b -> (a + b).-2 = a.-1 + b.-1)%N by apply.
case=> // a; case => // b _ _; by rewrite addSn addnS.
Qed.

Lemma size_r0_sum (tr0 : t < size r0) (r1_ltn_r0 : size r1 < size r0) l :
  l < stop ->
  (size (`r 0)).-1 = (\sum_(k < l.+1) (size (`q k.+1)).-1 + (size (`r l)).-1)%nat.
Proof.
elim: l => [_ | l IH].
  by rewrite big_ord_recr big_ord0 /= size_poly0.
move=> lEu.
rewrite IH; last by rewrite (ltn_trans (ltnSn _) lEu).
transitivity ((\sum_(k < l.+1) (size (`q k.+1)).-1 + (size (`q l.+2)).-1 + (size (`r l.+1)).-1)%N); last first.
  by rewrite [in RHS]big_ord_recr -addnA.
rewrite -addnA.
congr addn.
have H1 : 0 < size (`q l.+2) by rewrite (ltn_trans _ (ltn_size_q tr0 r1_ltn_r0 lEu)).
  have {lEu}lEu : is_true (0 < l.+1 < stop) by rewrite lEu.
rewrite Euclid.rE size_addl; last first.
  rewrite size_mul; last 2 first.
    by rewrite -size_poly_eq0 -lt0n.
    by rewrite -size_poly_eq0 -lt0n (leq_ltn_trans _ (ltn_size_r_stop tr0 (ltnW r1_ltn_r0) lEu)).
  suff : (forall a b c, 0 < b -> a < c -> (a < (b + c).-1))%nat.
    apply => //; by apply: (ltn_size_r_stop tr0 (ltnW r1_ltn_r0) lEu).
  clear.
  move=> a.
  case=> // b; case=> // c _ ac.
  by rewrite addSn /= ltn_addl.
rewrite size_mul; last 2 first.
  by rewrite -size_poly_eq0 -lt0n.
  by rewrite -size_poly_eq0 -lt0n (leq_ltn_trans _ (ltn_size_r_stop tr0 (ltnW r1_ltn_r0) lEu)).
suff : (forall a b, 0 < a -> 0 < b -> (a + b).-2 = a.-1 + b.-1)%nat.
  apply => //; by rewrite (leq_ltn_trans _ (ltn_size_r_stop tr0 (ltnW r1_ltn_r0) lEu)).
clear.
case=> // a; case => // b _ _.
by rewrite addSn addnS.
Qed.

(* NB: used in reed_solomon.v *)
Lemma leq_size_v (tr0 : t < size r0) (r1_ltn_r0 : size r1 < size r0) k :
  (size r0).-1 <= t.*2 -> k.-1 < stop -> (size (`v k)).-1 <= t.
Proof.
move=> r0t.
case: k => [_|k].
  by rewrite /= /Euclid.v0 size_poly0.
move=> lEu.
rewrite /= in lEu.
rewrite size_v_sum //.
rewrite -(leq_add2l t) addnn.
move: (size_r0_sum tr0 r1_ltn_r0 lEu).
rewrite [in X in X = _ -> _]/= => H.
apply: (leq_trans _ r0t).
rewrite [in X in _ <= X]H.
rewrite addnC leq_add2l.
move: lEu.
rewrite /stop.
case: Bool.bool_dec => H1; last by rewrite tr0 in H1.
case: Bool.bool_dec => H2; last by rewrite (ltnW r1_ltn_r0) in H2.
rewrite /stop'; case: ex_maxnP => i Pi Hi l'i.
have : euclid_cont k.
  move: (euclid_back k i).
  by rewrite -ltnS Pi l'i.
move/forallP/(_ (Ordinal (ltnSn k))) => H'.
by rewrite -(leq_add2r 1) 2!addn1 prednK // (leq_ltn_trans _ H').
Qed.

End euclid_stop.

Section euclid_lemma.

(** see [McEliece 2002], 9.4 *)
Variables (F : fieldType).
Variable r0 r1 : {poly F}.
Hypothesis r1_leq_r0 : size r1 <= size r0.

Local Notation "'`r'" := (Euclid.r r0 r1).
Local Notation "'`v'" := (Euclid.v r0 r1).

(* McEliece, Lemma 2, p.245 *)
Lemma euclid_lemma p t : (p + t = size (`r 0))%N ->
  let stop := stop t (`r 0) (`r 1) in
  size (`v stop) <= p /\ size (`r stop) <= t.
Proof.
move=> H.
case/boolP : (0 < size r0) => [Hr0|]; last first.
  rewrite -leqNgt leqn0 size_poly_eq0 => /eqP ?; subst r0.
  suff : p = O /\ t = O.
    case=> -> -> /=.
    rewrite /stop.
    case: Bool.bool_dec => [H1|_].
      exfalso.
      by rewrite size_poly0 ltnn in H1.
    by rewrite /= /Euclid.v0 size_poly0.
  move: H; rewrite size_poly0.
  by case: p.
move=> j.
case/boolP : (t < size r0) => Hnu; last first.
  have {Hnu} ?: p = O.
    move: Hnu.
    rewrite -H -leqNgt.
    by rewrite -{2}(add0n t) leq_add2r leqn0 => /eqP.
  subst p.
  rewrite {}/j.
  rewrite /stop.
  case: Bool.bool_dec => H1.
    exfalso.
    move: H1.
    by rewrite -H add0n ltnn.
  by rewrite /= /Euclid.v0 size_poly0 leqnn -H add0n.
split; last by apply: stop_is_after.
rewrite -(leq_add2r t) H.
move: (@relationF _ _ _ _ (stop' Hnu r1_leq_r0) Hnu r1_leq_r0).
rewrite /stop.
case: Bool.bool_dec => H1; last by rewrite Hnu in H1.
case: Bool.bool_dec => H2; last by rewrite r1_leq_r0 in H2.
rewrite (_ : H1 = Hnu); last by apply eq_irrelevance.
rewrite (_ : H2 = r1_leq_r0); last by apply eq_irrelevance.
rewrite ltnSn => /(_ isT).
rewrite -/(stop _ _) => /(congr1 (fun x => x.+1)).
rewrite prednK ?lt0n ?size_poly_eq0 //; last by rewrite -size_poly_eq0 -lt0n.
move => <-.
rewrite -ltnS.
move: (stop'_is_before Hnu r1_leq_r0) => Hsave; move: (Hsave).
rewrite -(ltn_add2l (size (`v j))).
move/leq_trans; apply.
rewrite -addSn.
case/boolP : (size (`v j) == O) => vs0.
  rewrite (eqP vs0) add0n.
  rewrite addSn addnC -2!addSn (leq_trans _ (leq_addr _ _)) // prednK //.
  by rewrite (leq_trans _ Hsave).
rewrite /j /stop.
case: Bool.bool_dec => H1'; last by rewrite Hnu in H1.
case: Bool.bool_dec => H2'; last by rewrite r1_leq_r0 in H2.
rewrite -(_ : Hnu = H1'); last by apply eq_irrelevance.
rewrite -(_ : r1_leq_r0 = H2'); last by apply eq_irrelevance.
rewrite -addnS leq_add // prednK // ?(leq_trans _ Hsave) // ?lt0n.
apply: contra vs0.
rewrite /j /stop.
case: Bool.bool_dec => H1''; last by rewrite Hnu in H1.
case: Bool.bool_dec => H2''; last by rewrite r1_leq_r0 in H2.
rewrite -(_ : Hnu = H1''); last by apply eq_irrelevance.
rewrite -(_ : r1_leq_r0 = H2'') //; by apply eq_irrelevance.
Qed.

Local Notation "'`u'" := (Euclid.u r0 r1).

Variables V R U : {poly F}.
Hypotheses (v_neq0 : V != 0) (r1_neq0 : r1 != 0).

(** see [McEliece 2002], Theorem 9.5, p.246 *)
Lemma solve_key_equation m t :
  V * (`r 1) = R + U * (`r 0) ->
  size V <= m -> size R <= t ->
  (m + t = size r0)%N ->
  let j := stop t r0 r1 in
  exists k, k <> 0 /\ V = k * `v j /\ R = k * `r j.
Proof.
have r0_neq0 : r0 != 0.
  by rewrite -size_poly_eq0 -lt0n (leq_trans _ r1_leq_r0) // lt0n size_poly_eq0.
move=> key_eqn Hmu Hnu Hsize j'.
move: (euclid_lemma Hsize) => [H2 Hj].
set j := stop _ _ _ in H2, Hj.
move: (Euclid.ruv r0 r1 j) => E1.
have {key_eqn}key_eqn : R = (- U) * r0 + V * r1 by rewrite key_eqn addrC mulNr addrK.
move/(congr1 (fun x => V * x)) : (E1); rewrite mulrDr !mulrA => E1'.
move/(congr1 (fun x => `v j * x)) : (key_eqn); rewrite mulrDr !mulrA => key_eqn'.
have step1 : `r j * V = R * `v j.
  have [k Hk] : exists k, `r j * V = R * `v j + k * r0.
    exists (V * `u j - `v j * (- U)).
    rewrite mulrC {}E1'.
    move: key_eqn' => /eqP.
    rewrite addrC -subr_eq -(mulrA _ V) mulrCA mulrA => /eqP <-.
    by rewrite addrCA mulrN mulNr 2!opprK -mulrDl mulrC.
  have HrV : size (`r j * V) < size r0.
    case/boolP : (`r j == 0) => [/eqP->|rj0].
      by rewrite mul0r size_poly0 lt0n size_poly_eq0.
    case/boolP : (V == 0) => [/eqP ->|V_neq0].
      by rewrite mulr0 size_poly0 lt0n size_poly_eq0.
    rewrite size_mul; last 2 first.
      exact: rj0.
      exact V_neq0.
    rewrite -Hsize.
    rewrite prednK; last first.
      by rewrite ltn_addr // lt0n size_poly_eq0.
    by rewrite addnC leq_add.
  have HRv : size (R * `v j) < size r0.
    case/boolP : (`v j == 0) => [/eqP->|vj0].
      by rewrite mulr0 size_poly0 lt0n size_poly_eq0.
    case/boolP : (R == 0) => [/eqP->|R_neq0].
      by rewrite mul0r size_poly0 lt0n size_poly_eq0.
    rewrite size_mul; last 2 first.
      exact R_neq0.
      exact vj0.
    rewrite prednK; last first.
      by rewrite addnC ltn_addr // lt0n size_poly_eq0.
    by rewrite -Hsize addnC leq_add.
  case/boolP : (k == 0) => [/eqP k0|k0].
    move: Hk; by rewrite k0 mul0r addr0.
  exfalso.
  move/eqP : Hk.
  rewrite addrC -subr_eq.
  move/eqP/(congr1 (fun x : {poly F} => size x)).
  apply/eqP.
  rewrite ltn_eqF //.
  rewrite (leq_ltn_trans (size_add _ _)) // size_opp.
  rewrite (@leq_trans (size r0)) //.
    by rewrite gtn_max HrV.
  by rewrite size_mul // addnC -subn1 -addnBA ?lt0n ?size_poly_eq0 // leq_addr.
have step2 : `u j * V = (-U) * `v j.
  move: step1.
  rewrite [in X in _ = X -> _]mulrC {}key_eqn' mulrC {}E1'.
  rewrite -(mulrA _ (`v j)) mulrCA mulrA.
  move/eqP; rewrite -subr_eq addrK -subr_eq0 -mulrBl => /eqP.
  move/poly_idomainAxiom; rewrite (negbTE r0_neq0) orbF subr_eq0 => /eqP.
  rewrite mulrC => ->; by rewrite mulrC.
have [l [Hl1 Hl2]] : exists l, (-U) = l * `u j /\ V = l * `v j.
  have Hcoprime : coprimep (`u j) (`v j).
    apply/Bezout_coprimepP.
    exists (`v j.+1, - `u j.+1).
    rewrite mulNr (mulrC _ (`v j)) (Euclid.vu r0 r1 j).
    by rewrite /eqp dvd1p andbT dvdp1 -(mulr1 ((_)^+_)) size_Msign size_poly1.
  have /dvdpP[k Hk] : `u j %| (-U).
    by rewrite -(Gauss_dvdpl _ Hcoprime) -step2 dvdp_mulr.
  have /dvdpP[k' Hk'] : `v j %| V.
    rewrite -(@Gauss_dvdpl _ _ (`u j)); last by rewrite coprimep_sym.
    by rewrite mulrC step2 dvdp_mull.
  case/boolP : (`u j == 0) => [/eqP uj0|uj0].
    move: Hcoprime.
    rewrite uj0 coprime0p => vj1.
    exists k'.
    by rewrite Hk uj0 2!mulr0.
  exists k; split => //.
  suff : k = k' by move => ->.
  move: step2.
  rewrite Hk Hk' mulrCA -mulrA => /eqP.
  rewrite -subr_eq0 -mulrBl => /eqP.
  move/poly_idomainAxiom => /orP[|/eqP]; first by rewrite subr_eq0 => /eqP.
  move/poly_idomainAxiom => /orP[] /eqP abs; last first.
    move: Hk'; rewrite abs mulr0 => /eqP; by rewrite (negbTE v_neq0).
  by rewrite abs eqxx in uj0.
exists l; split.
  move=> ?; subst l.
  rewrite mul0r in Hl2.
  move: v_neq0.
  by rewrite Hl2 eqxx.
move: key_eqn; by rewrite Hl1 Hl2 -!mulrA -mulrDr -E1.
Qed.

Lemma solve_key_equation_coprimep p t :
  V * (`r 1) = R + U * (`r 0) ->
  size V <= p -> size R <= t ->
  (p + t = size r0)%N ->
  coprimep V R ->
  let stop := stop t (`r 0) (`r 1) in
  exists k, k <> 0 /\ `v stop = k *: V /\ `r stop = k *: R.
Proof.
move=> H1 Hmu Hnu H2 Hco j.
case: (solve_key_equation H1 Hmu Hnu H2) => l [l_neq0 [vvi rrj]].
move: Hco.
rewrite {1}vvi {1}rrj coprimep_mulr coprimep_mull coprimepp => /andP[/andP[]].
case/size_poly1P => k k_neq0 lk _ _.
exists k^-1; split; first by apply/eqP; rewrite invr_eq0.
split.
- by rewrite vvi lk mul_polyC scalerA mulVr ?scale1r // unitfE.
- by rewrite rrj lk mul_polyC scalerA mulVr ?scale1r // unitfE.
Qed.

End euclid_lemma.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition rvic_test_flag_spec (intid: Z64) (bitmap: Pointer) (adt: RData) : option Z :=
    match intid with
    | VZ64 intid =>
      rely is_int64 intid;
      let idx := (intid / 64) in
      let bit := (intid mod 64) in
      let slot := offset bitmap in
      rely prop_dec (0 <= slot < 16);
      rely prop_dec (0 <= idx < 512);
      when gidx == ((buffer (priv adt)) @ slot);
      let gn := (gs (share adt)) @ gidx in
      rely ((g_tag (ginfo gn)) =? GRANULE_STATE_REC);
      rely prop_dec (glock gn = Some CPU_ID);
      if peq (base bitmap) rvic_pending_loc then
        let bits := (r_pending_bits (g_rvic (gnorm gn))) @ idx in
        if Z.land bits (Z.shiftl 1 bit) =? 0
        then Some 0 else Some 1
      else
        if peq (base bitmap) rvic_mask_loc then
          let bits := (r_mask_bits (g_rvic (gnorm gn))) @ idx in
          if Z.land bits (Z.shiftl 1 bit) =? 0
          then Some 0 else Some 1
        else None
    end.

End Spec.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e158m15_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e448m2e224m1_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


(** * Restriction of an adjuction to an equivalence *)

(** ** Contents
  - Restriction of an adjunction to an equivalence
 *)

Require Import UniMath.Foundations.Preamble.
Require Import UniMath.Foundations.Propositions.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.whiskering.

Local Open Scope cat.

(** ** Restriction of an adjunction to an equivalence *)

(** Restriction of an adjunction to the subcategories where the unit
    and counit are isos forms an equivalence *)

(** The full subcategory of [C] for which [eta] is an isomorphism *)
Definition full_subcat_nat_trans_is_z_iso {C D : category}
           {F : functor C D} {G : functor C D} (eta : nat_trans F G) :
  sub_precategories C.
Proof.
  apply full_sub_precategory.
  intro c; use make_hProp.
  - exact (is_z_isomorphism (eta c)).
  - apply isaprop_is_z_isomorphism.
Defined.

Section Restriction.
  Context {C D : category} {F : functor C D} {G : functor D C} (are : are_adjoints F G).

  Let η := adjunit are.
  Let ε := adjcounit are.

  Definition restricted_adjunction_left_adjoint :
    functor (full_subcat_nat_trans_is_z_iso η) (full_subcat_nat_trans_is_z_iso ε).
  Proof.
    use make_functor; [use make_functor_data|split].
    - (* Left adjoint data on objects *)
      * intros c'; pose (c := precategory_object_from_sub_precategory_object _ _ c').
        use tpair.
        -- exact (F c).
        -- cbn.
           (* need: ε (F c) is an iso *)
           use make_is_z_isomorphism.
           ++ exact (post_whisker η F _).
           ++ assert (HH : (post_whisker η F) c · ε (F c) = identity (F c)).
             { apply (triangle_id_left_ad are). }
             (* We know [# F (η x)] is invertible because [η x] is *)
             assert (inv : ∑ h, is_inverse_in_precat ((post_whisker η F) c) h).
             {
               use tpair.
               - exact (# F (inv_from_z_iso (make_z_iso' _ (pr2 c')))).
               - cbn. apply (functor_is_inverse_in_precat_inv_from_z_iso F (make_z_iso' _ (pr2 c'))).
             }
             split.
             ** (* Since [# F (η x)] is invertible and [ε (F c)] is its right inverse,
                   [ε (F c)] must be its left inverse. *)
                 pose (eq := right_inverse_of_iso_is_inverse ((post_whisker η F) c) ).
                 specialize (eq (pr1 inv) (pr2 inv) (ε (F c)) HH).
                 refine (maponpaths (fun z => z · _) eq @ _).
                 apply is_inverse_in_precat1.
                 apply is_inverse_in_precat_inv.
                 exact (pr2 inv).
             ** exact HH.
    - (* Left adjoint data on morphisms *)
      intros ? ? f; cbn.
      use tpair.
      + exact (# F (precategory_morphism_from_sub_precategory_morphism _ _ _ _ f)).
      + exact tt.
    - (* Left adjoint identity axiom *)
      intro; cbn.
      apply subtypePath; [intro; apply propproperty|].
      apply functor_id.
    - (* Left adjoint composition axiom *)
      intros ? ? ? ? ?; cbn.
      apply subtypePath; [intro; apply propproperty|].
      apply functor_comp.
  Defined.

  Definition restricted_adjunction_right_adjoint :
    functor (full_subcat_nat_trans_is_z_iso ε) (full_subcat_nat_trans_is_z_iso η).
  Proof.
    use make_functor; [use make_functor_data|split].
    - (* The definition of the right adjoint just mirrors that of the left *)
      (* Right adjoint data on objects *)
      intros d'; pose (d := precategory_object_from_sub_precategory_object _ _ d').
      use tpair.
      + exact (G d).
      + cbn.
        use make_is_z_isomorphism.
        * exact (post_whisker ε G _).
        * assert (HH : η (G d) · (post_whisker ε G) d = identity (G d)).
          { apply (triangle_id_right_ad are). }
          assert (inv : ∑ h, is_inverse_in_precat (post_whisker ε G d) h).
          {
            use tpair.
            - exact (# G (inv_from_z_iso (make_z_iso' _ (pr2 d')))).
            - apply (functor_is_inverse_in_precat_inv_from_z_iso G (make_z_iso' _ (pr2 d'))).
          }
          split.
          -- exact HH.
          -- pose (eq := left_inverse_of_iso_is_inverse ((post_whisker ε G) d)).
             specialize (eq (pr1 inv) (pr2 inv) (η (G d)) HH).
             refine (maponpaths (fun z => _ · z) eq @ _).
             apply is_inverse_in_precat1.
             exact (pr2 inv).
    - (* Right adjoint data on morphisms *)
        * intros ? ? f; cbn.
          use tpair.
          -- exact (# G (precategory_morphism_from_sub_precategory_morphism _ _ _ _ f)).
          -- exact tt.
    - (* Right adjoint identity axiom *)
      intro; cbn.
      apply subtypePath; [intro; apply propproperty|].
      apply functor_id.
    - (* Right adjoint composition axiom *)
      intros ? ? ? ? ?; cbn.
      apply subtypePath; [intro; apply propproperty|].
      apply functor_comp.
  Defined.

  Definition restricted_adjunction_unit :
    nat_trans (functor_identity (full_subcat_nat_trans_is_z_iso η))
              (restricted_adjunction_left_adjoint ∙ restricted_adjunction_right_adjoint).
  Proof.
    use make_nat_trans.
    - intro; cbn.
      use tpair.
      + apply η.
      + exact tt.
    - (* Unit is natural *)
      intros ? ? ?.
      apply subtypePath; [intro; apply propproperty|].
      apply (pr2 η).
  Defined.

  Definition restricted_adjunction_counit :
    nat_trans (restricted_adjunction_right_adjoint ∙ restricted_adjunction_left_adjoint)
              (functor_identity (full_subcat_nat_trans_is_z_iso ε)).
  Proof.
    use make_nat_trans.
    - intro; cbn.
      use tpair.
      + apply ε.
      + exact tt.
    - (* Counit is natural *)
      intros ? ? ?.
      apply subtypePath; [intro; apply propproperty|].
      apply (pr2 ε).
  Defined.

  Lemma are_adjoints_restricted_adjunction :
    are_adjoints restricted_adjunction_left_adjoint
                 restricted_adjunction_right_adjoint.
  Proof.
    use make_are_adjoints.
    - exact restricted_adjunction_unit.
    - exact restricted_adjunction_counit.
    - use make_form_adjunction.
      + (* 1st triangle identity *)
        intro; apply subtypePath; [intro; apply propproperty|].
        apply triangle_id_left_ad.
      + (* 2nd triangle identity *)
        intro; apply subtypePath; [intro; apply propproperty|].
        apply triangle_id_right_ad.
  Defined.

  Lemma restricted_adjunction_equivalence :
    equivalence_of_cats (full_subcat_nat_trans_is_z_iso η)
                           (full_subcat_nat_trans_is_z_iso ε).
  Proof.
    exists (adjunction_data_from_is_left_adjoint
         are_adjoints_restricted_adjunction).
    split.
    - intro a.
      pose (isomor := make_z_iso' _ (pr2 a) :
                        z_iso (pr1 a) (pr1 (right_adjoint are_adjoints_restricted_adjunction
                                           (left_adjoint are_adjoints_restricted_adjunction a)))).
      apply (iso_in_precat_is_iso_in_subcat C _ _ _ isomor).
    - intro b.
      cbn.
      pose (isomor := make_z_iso' _ (pr2 b) :
                        z_iso (pr1 (left_adjoint are_adjoints_restricted_adjunction
                                   (right_adjoint are_adjoints_restricted_adjunction b))) (pr1 b)).
      apply (iso_in_precat_is_iso_in_subcat _ _ _ _ isomor).
  Defined.

End Restriction.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e382m105_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


(** Coq coding by choukh, Oct 2021 **)

Require Import BBST.Axiom.Meta.
Require Import BBST.Axiom.Extensionality.
Require Import BBST.Definition.Emptyset.
Require Import BBST.Definition.Singleton.
Require Import BBST.Definition.Function.
Require Import BBST.Lemma.MetaFunction.

Definition 恒等函数 := λ A, 函数 A A (λ x, x).

Fact 恒等函数是恒等关系 : ∀ A, 恒等函数 A = 恒等关系 A.
Proof. intros. 外延; 关系|-H; 关系-|; auto. Qed.

Fact 恒等函数应用 : ∀ A, ∀x ∈ A, (恒等函数 A)[x] = x.
Proof. intros. apply 函数应用. apply 函数为之. 关系-|; auto. Qed.

Lemma 恒等函数为一对一 : ∀ A, 一对一 (恒等函数 A).
Proof.
  split. apply 函数为之. intros x y z H1 H2.
  关系|-H1. 关系|-H2. congruence.
Qed.

Theorem 恒等函数是双射 : ∀ A, 恒等函数 A : A ⟺ A.
Proof. intros. apply 元双射; firstorder. Qed.

Lemma 空集为函数 : 为函数 ∅.
Proof. split. intros x H. 空集归谬. intros x y z H. 空集归谬. Qed.

Lemma 空函数的定义域为空集 : dom ∅ = ∅.
Proof. 外延. 定|-H as [y H]. 空集归谬. 空集归谬. Qed.

Lemma 空函数的值域为空集 : ran ∅ = ∅.
Proof. 外延. 值|-H as [w H]. 空集归谬. 空集归谬. Qed.

Lemma 定义域为空集的函数是空函数 : ∀ f, 为函数 f → dom f = ∅ → f = ∅.
Proof.
  intros. 外延 p Hp. 2: 空集归谬.
  函数|-Hp. 定 Hp. rewrite H0 in Hp. 空集归谬.
Qed.

Lemma 值域为空集的函数是空函数 : ∀ f, 为函数 f → ran f = ∅ → f = ∅.
Proof.
  intros. 外延 p Hp. 2: 空集归谬.
  函数|-Hp. 值 Hp. rewrite H0 in Hp. 空集归谬.
Qed.

Theorem 空函数是空集到任意集合的单射 : ∀ A, ∅: ∅ ⇔ A.
Proof.
  intros. repeat split.
  - intros x Hx. 空集归谬.
  - intros x y z Hxy. 空集归谬.
  - intros x y z Hxz. 空集归谬.
  - apply 空函数的定义域为空集.
  - intros y Hy. 值|-Hy as [x Hp]. 空集归谬.
Qed.

Theorem 空函数是空集到空集的双射 : ∅: ∅ ⟺ ∅.
Proof.
  apply 双射即射满的单射. split.
  apply 空函数是空集到任意集合的单射. intros x Hx. 空集归谬.
Qed.

Definition 常函数 := λ A a, 函数 A {a,} (λ _, a).

Lemma 常函数是映射 : ∀ A a, 常函数 A a: A ⇒ {a,}.
Proof. intros. apply 元映射. auto. Qed.

Lemma 常函数应用 : ∀ A a, ∀x ∈ A, (常函数 A a)[x] = a.
Proof. intros. unfold 常函数. rewrite 元应用; auto. Qed.

Lemma 定义域非空的常函数是满射 : ∀ A a, 非空 A → 常函数 A a : A ⟹ {a,}.
Proof.
  intros A a [x Hx]. apply 元满射. auto.
  intros y Hy. apply 单集除去 in Hy; subst. firstorder.
Qed.

Lemma 单点集为函数 : ∀ a b, 为函数 {<a, b>,}.
Proof.
  intros. split.
  - intros x Hx. apply 单集除去 in Hx. subst x; auto.
  - intros x y z Hxy Hxz. apply 单集除去 in Hxy, Hxz.
    apply 序偶相等 in Hxy as [], Hxz as []; subst; auto.
Qed.

Theorem 单点函数应用: ∀ a b, ∀x ∈ {a,}, {<a, b>,}[x] = b.
Proof.
  intros. apply 单集除去 in H; subst.
  symmetry. apply 函数除去1. apply 单点集为函数. auto.
Qed.

Lemma 单点集一对一 : ∀ a b, 一对一 {<a, b>,}.
Proof.
  intros. split. apply 单点集为函数.
  intros x y z Hxz Hyz. apply 单集除去 in Hxz, Hyz.
  apply 序偶相等 in Hxz as [], Hyz as []; subst; auto.
Qed.

Lemma 单点集的定义域 : ∀ a b, dom {<a, b>,} = {a,}.
Proof.
  intros. 外延 Hx.
  - 定|-Hx as [y Hp]. apply 单集除去 in Hp.
    apply 序偶相等 in Hp as []; subst; auto.
  - apply 单集除去 in Hx; subst. 定-|b; auto.
Qed.

Lemma 单点集的值域 : ∀ a b, ran {<a, b>,} = {b,}.
Proof.
  intros. 外延 y Hy.
  - 值|-Hy as [x Hp]. apply 单集除去 in Hp.
    apply 序偶相等 in Hp as []; subst; auto.
  - apply 单集除去 in Hy; subst. 值-|a; auto.
Qed.

Theorem 单点集是双射 : ∀ a b, {<a, b>,} : {a,} ⟺ {b,}.
Proof.
  intros. split. apply 单点集一对一. split.
  apply 单点集的定义域. apply 单点集的值域.
Qed.