Require Import Utils.

Require Import Lia.
Require Coq.Lists.List.
Import List.ListNotations.
Import Coq.NArith.BinNat.
Import EqNotations.

Record vector {A n} := {
  vector_list : list A;
  vector_wf : length_bin vector_list = n;
}.

Arguments vector : clear implicits.

Notation bitvec := (vector bool).

Declare Scope vector_scope.
Delimit Scope vector_scope with vector.
Bind Scope vector_scope with vector.
Notation "[| |]" := {| vector_list := []; vector_wf := eq_refl |} (format "[| |]").
Notation "[| x |]" := {| vector_list := [x]; vector_wf := eq_refl |}.
Notation "[| x ; y ; .. ; z |]" := {| vector_list := cons x (cons y .. [z] ..); vector_wf := eq_refl |}.

Register vector as vcpu.vector.type.
Register Build_vector as vcpu.vector.constructor.
Register vector_list as vcpu.vector.list.
Register vector_wf as vcpu.vector.wf.

Definition mk_vector {A n} v_list v_wf : vector A n := {|
  vector_list := v_list;
  vector_wf := normalize_eq_binnat _ _ v_wf;
|}.

Lemma mk_vector_ext :
  forall {A n} (v_list : list A) (v_wf_1 v_wf_2 : length_bin v_list = n),
  mk_vector v_list v_wf_1 = mk_vector v_list v_wf_2.
Proof.
  intros A n v_list v_wf_1 v_wf_2. unfold mk_vector. f_equal. apply normalize_eq_binnat_ext.
Qed.

Lemma mk_vector_ext_all :
  forall {A n} (v_list_1 v_list_2 : list A)
  (v_wf_1 : length_bin v_list_1 = n) (v_wf_2 : length_bin v_list_2 = n),
  v_list_1 = v_list_2 ->
  mk_vector v_list_1 v_wf_1 = mk_vector v_list_2 v_wf_2.
Proof.
  intros A n v_list_1 v_list_2 v_wf_1 v_wf_2 H. subst v_list_2. apply mk_vector_ext.
Qed.

Lemma mk_vector_eq_refl :
  forall {A} (l : list A),
  mk_vector l eq_refl = {| vector_list := l; vector_wf := eq_refl |}.
Proof.
  intros A l. unfold mk_vector. f_equal. apply normalize_eq_binnat_eq_refl.
Qed.

Definition vector_normalize {A n} (v : vector A n) : vector A n := mk_vector (vector_list v) (vector_wf v).

Definition vector_similar {A n1 n2} (v1 : vector A n1) (v2 : vector A n2) := vector_list v1 = vector_list v2.

Infix "~=" := vector_similar (at level 70) : type_scope.

Register vector_similar as vcpu.vector.similar.

Lemma vector_similar_ext :
  forall {A n} (v1 : vector A n) (v2 : vector A n),
  v1 = v2 ->
  v1 ~= v2.
Proof.
  intros A n v1 v2 H. rewrite H. reflexivity.
Qed.

Register vector_similar_ext as vcpu.vector.similar_ext.

#[program] Definition vector_head {A n} (v : vector A (N.succ n)) : A :=
  match vector_list v with
  | x :: _ => x
  | [] => _
  end.
Next Obligation.
  intros A n v. specialize (vector_wf v) as H. destruct (vector_list v).
  - simpl in H. apply N.neq_0_succ in H. destruct H.
  - simpl. auto.
Qed.

#[program] Definition vector_tail {A n} (v : vector A (N.succ n)) : vector A n := {|
  vector_list := List.tl (vector_list v);
|}.
Next Obligation.
  intros A n v. specialize (vector_wf v) as H. destruct (vector_list v).
  - simpl in H. apply N.neq_0_succ in H. destruct H.
  - simpl. rewrite length_bin_cons in H. apply N.succ_inj in H. auto.
Qed.

Definition vector_dest {A n} (v : vector A (N.succ n)) : A * vector A n :=
  (vector_head v, vector_tail v).

Register vector_dest as vcpu.vector.dest.

Definition vector_of_list {A} (l : list A) : vector A (length_bin l) := mk_vector l eq_refl.

#[program] Definition vector_app {A n1 n2} (v1 : vector A n1) (v2 : vector A n2) : vector A (n1 + n2) :=
  mk_vector (vector_list v1 ++ vector_list v2) _.
Next Obligation.
  intros A n1 n2 v1 v2. rewrite length_bin_app. rewrite ? vector_wf. auto.
Qed.

Infix "++" := vector_app : vector_scope.

Register vector_app as vcpu.vector.app.

Lemma vector_app_mk_vector :
  forall A n1 n2 (v_list_1 v_list_2 : list A)
    (v_wf_1 : length_bin v_list_1 = n1) (v_wf_2 : length_bin v_list_2 = n2),
  ((mk_vector v_list_1 v_wf_1) ++ (mk_vector v_list_2 v_wf_2))%vector =
    mk_vector (v_list_1 ++ v_list_2)
      (vector_app_obligation_1 _ _ _(mk_vector v_list_1 v_wf_1) (mk_vector v_list_2 v_wf_2)).
Proof.
  intros A n1 n2 v_list_1 v_list_2 v_wf_1 v_wf_2. unfold vector_app. apply mk_vector_ext.
Qed.

Definition vector_seq_bin s n : vector binnat n :=
  mk_vector (list_seq_bin s n) (length_bin_list_seq_bin s n).

Definition vector_select_bin {A n m} (values : vector A n) (indices : vector binnat m) default : vector A m :=
  mk_vector
    (list_select_bin (vector_list values) (vector_list indices) default)
    (rew vector_wf indices in length_bin_list_select_bin _ _ _).

Register vector_select_bin as vcpu.vector.select_bin.

#[program] Definition vector_map {A B n} f (v : vector A n) : vector B n :=
  mk_vector (List.map f (vector_list v)) _.
Next Obligation.
  intros A B n f v. rewrite length_bin_list_map. apply (vector_wf v).
Qed.

Unset Program Cases.

#[program] Definition vector_map2 f {n} (bv1 bv2 : bitvec n) : bitvec n := {|
  vector_list := List.map (fun '(b1, b2) => f b1 b2) (List.combine (vector_list bv1) (vector_list bv2));
|}.
Next Obligation.
  intros f n bv1 bv2. rewrite length_bin_list_map. rewrite length_bin_list_combine.
  rewrite ? vector_wf. apply N.min_id.
Qed.

Set Program Cases.

Definition vector_and {n} (bv1 bv2 : bitvec n) : bitvec n := vector_map2 andb bv1 bv2.


From iris.program_logic Require Export weakestpre total_weakestpre.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Export tactics.
From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type".

Section ListAllEven.
  Context `{heapG Σ}.

  Inductive mylist : Set :=
  | mynil : mylist
  | mycons : Z → mylist → mylist.

  Fixpoint is_mylist (v : val) (xs : mylist) : iProp Σ :=
    match xs with
    | mynil => ⌜v = InjLV #()⌝
    | mycons n xs' => ∃(tail : loc) (vtail : val), ⌜v = InjRV (#n,#tail)⌝ ∗ tail ↦ vtail ∗ is_mylist vtail xs'
  end%I.

  Fixpoint all_even (xs : mylist) : bool :=
    match xs with
    | mynil => true
    | mycons n xs' => andb (bool_decide (Z.rem n 2 = 0)) (all_even xs')
    end.

  Definition all_even_loop : val :=
    rec: "all_even_loop" "xs" "state" :=
      match: "xs" with
        InjL "unit" => Skip
      | InjR "cons" =>
        let: "current" := (Fst "cons") `rem` #2 = #0 in
        "state" <- !"state" && "current";;
        "all_even_loop" !(Snd "cons") "state"
      end.

  Definition all_even_prog : val := λ: "xs",
    let: "state" := ref #true in
    all_even_loop "xs" "state";;
    !"state".

  (* Lemma val_eq_helper a b: *)
  (*   a = b ↔ #a = #b. *)
  (* Proof. *)
  (*   split; intros H0. *)
  (*   - by rewrite H0. *)
  (*   - by inversion H0. *)
  (* Qed. *)

  Lemma all_even_loop_wp v xs l (b : bool):
    [[{ l ↦ #b ∗ is_mylist v xs }]]
      all_even_loop v #l
      [[{ RET #(); l ↦ #(all_even xs && b) ∗ is_mylist v xs }]].
  Proof.
    iIntros (Φ) "[Hl Hxs] HΦ".
    iInduction xs as [|n xs'] "IH" forall (v b Φ); simpl; wp_rec; wp_let.
    - iDestruct "Hxs" as "%"; subst. wp_match.
      wp_lam.
      (* iApply ("HΦ" with "[Hl]"). iFrame. done. *)
      (* by iApply ("HΦ" with "[$Hl]"). *)
      iApply ("HΦ" with "[$Hl //]").
    - iDestruct "Hxs" as (tail vtail ->) "(Hltail & Hxtail)".
      wp_load.
      destruct b; (wp_if_true || wp_if_false); wp_store; wp_proj; wp_load;
      wp_apply ("IH" with "Hl Hxtail"); iIntros "[Hl Hxtail]";
      iApply "HΦ"; iSplitL "Hl"; try (iExists tail, vtail; by iFrame).
      + (* b = true *)
        replace (bool_decide (n `rem` 2 = 0) && all_even xs' && true)
          with (all_even xs' && bool_decide (#(n `rem` 2) = #0)). done.
        replace (bool_decide (#(n `rem` 2) = #0))
          with (bool_decide (n `rem` 2 = 0)). ring.
          (* apply bool_decide_iff. apply val_eq_helper. *)
        apply bool_decide_iff. split; intros H0. by rewrite H0. by inversion H0.
      + (* b = false *)
        by replace (all_even xs' && false)
          with (bool_decide (n `rem` 2 = 0) && all_even xs' && false) by ring.
  Qed.

  Lemma all_even_prog_wp v xs:
    [[{ is_mylist v xs }]]
      all_even_prog v
    [[{ RET #(all_even xs); is_mylist v xs }]].
  Proof.
    iIntros (Φ) "Hxs HΦ".
    wp_lam. wp_alloc s as "Hs". wp_let.
    wp_apply (all_even_loop_wp with "[$Hs $Hxs]").
    iIntros "[Hs Hxs]".
    wp_seq.
    replace (all_even xs && true) with (all_even xs) by ring.
    wp_load. by iApply "HΦ".
  Qed.

  Check all_even_prog_wp.
End ListAllEven.


(* Misc.v *)

Require Import Utf8.
Require Import QArith.
Require Import NPeano.
Require Import Sorted.
Require Import Psatz.

Notation "[ ]" := nil.
Notation "[ x ; .. ; y … l ]" := (cons x .. (cons y l) ..).
Notation "[ x ]" := (cons x nil).
Notation "x ++ y" := (List.app x y) (right associativity, at level 60).
Notation "x < y <= z" := (x < y ∧ y <= z) (at level 70, y at next level).
Notation "x < y < z" := (x < y ∧ y < z) (at level 70, y at next level).
Notation "x < y ≤ z" := (x < y ∧ y <= z)%nat (at level 70, y at next level).
Notation "x ≤ y ≤ z" := (x <= y ∧ y <= z)%nat (at level 70, y at next level).
Notation "x ≤ y < z" := (x <= y ∧ y < z)%nat (at level 70, y at next level).
Notation "x ∈ l" := (List.In x l) (at level 70).
Notation "x ∉ l" := (not (List.In x l)) (at level 70).

Ltac negation H := exfalso; apply H; reflexivity.
Tactic Notation "fast_omega" hyp_list(Hs) := revert Hs; clear; intros; lia.

Set Implicit Arguments.

Definition Qnat i := Z.of_nat i # 1.

(* experimentations with Definition instead of Theorem *)

Definition Nat_sub_succ_diag : ∀ n, (S n - n = 1)%nat :=
  λ n,
  eq_trans (Nat.sub_succ_l n n (le_n n)) (f_equal S (Nat.sub_diag n)).

Definition Nat_le_neq_lt : ∀ x y : nat, x ≤ y → x ≠ y → (x < y)%nat :=
  λ x y Hxy Hnxy,
  match le_lt_eq_dec x y Hxy with
  | left Hle => Hle
  | right Heq => match Hnxy Heq with end
  end.

Definition Qle_neq_lt : ∀ x y, x <= y → ¬ x == y → x < y :=
  λ x y Hxy Hnxy,
  Qnot_le_lt y x (λ H, Hnxy (Qle_antisym x y Hxy H)).

Definition Qdiv_lt_compat_r : ∀ x y z, 0 < z → x < y → x / z < y / z :=
  λ x y z Hz Hxy,
  Qmult_lt_compat_r x y (/ z) (Qinv_lt_0_compat z Hz) Hxy.

Theorem Qdiv_minus_distr_r : ∀ x y z, (x - y) / z == x / z - y / z.
Proof.
intros x y z.
destruct (Qeq_dec z 0) as [Heq| Hne].
 rewrite Heq.
 unfold Qdiv, Qinv; simpl.
 do 3 rewrite Qmult_0_r.
 reflexivity.

 field; assumption.
Qed.

Theorem Qdiv_plus_distr_r : ∀ x y z, (x + y) / z == x / z + y / z.
Proof.
intros x y z.
destruct (Qeq_dec z 0) as [Heq| Hne].
 rewrite Heq.
 unfold Qdiv, Qinv; simpl.
 do 3 rewrite Qmult_0_r.
 reflexivity.

 field; assumption.
Qed.

Definition Qeq_opp_r : ∀ x y, x == y → - x == - y :=
  λ x y Hxy,
  let H₁ := eq_sym (f_equal Z.opp Hxy) in
  let H₂ := eq_trans (Z.mul_opp_l (Qnum y) (Zpos (Qden x))) H₁ in
  let H₃ := Z.mul_opp_l (Qnum x) (Zpos (Qden y)) in
  eq_trans H₃ (eq_sym H₂).

Theorem Qgt_0_not_0 : ∀ x, 0 < x → ¬x == 0.
Proof.
intros x Ha.
intros H.
rewrite H in Ha.
apply Qlt_irrefl in Ha; assumption.
Qed.

Theorem Qlt_minus : ∀ x y, x < y → 0 < y - x.
Proof.
intros x y H.
unfold Qlt in H |-*; simpl.
rewrite Z.mul_1_r, <- Zopp_mult_distr_l.
apply Zlt_left_lt.
assumption.
Qed.

Theorem Qminus_eq : ∀ x y, x - y == 0 → x == y.
Proof.
intros x y H.
apply Qplus_inj_r with (z := - y).
rewrite Qplus_opp_r.
assumption.
Qed.

Theorem Qmult_div_assoc : ∀ x y z, x * (y / z) == (x * y) / z.
Proof. intros x y z; unfold Qdiv; apply Qmult_assoc. Qed.

Theorem Qmult_opp_l : ∀ x y, (- x) * y == - (x * y).
Proof.
intros x y.
unfold Qeq, Qmult, Qopp; simpl.
rewrite Z.mul_opp_l.
reflexivity.
Qed.

Theorem Qmult_opp_r : ∀ x y, x * - y == - (x * y).
Proof.
intros x y.
unfold Qeq, Qmult, Qopp; simpl.
rewrite Z.mul_opp_r.
reflexivity.
Qed.

Theorem Qmult_minus_distr_l : ∀ x y z, (x - y) * z == x * z - y * z.
Proof.
intros x y z.
unfold Qminus.
rewrite Qmult_plus_distr_l.
rewrite Qmult_opp_l; reflexivity.
Qed.

Theorem Qmult_minus_distr_r : ∀ x y z, x * (y - z) == x * y - x * z.
Proof.
intros x y z.
unfold Qminus.
rewrite Qmult_plus_distr_r.
rewrite Qmult_opp_r; reflexivity.
Qed.

Theorem QZ_plus : ∀ x y z, x + y # z == (x # z) + (y # z).
Proof.
intros x y z.
unfold Qplus; simpl.
unfold Qeq; simpl.
rewrite Pos2Z.inj_mul; ring.
Qed.

Theorem Qnat_lt : ∀ i j, (i < j)%nat ↔ Qnat i < Qnat j.
Proof.
intros i j; split; intros H.
 unfold Qnat, Qlt; simpl.
 do 2 rewrite Zmult_1_r.
 apply inj_lt; assumption.

 unfold Qlt in H; simpl in H.
 do 2 rewrite Z.mul_1_r in H.
 apply Nat2Z.inj_lt in H; assumption.
Qed.

Theorem Qnat_succ : ∀ n x, x * Qnat (S n) == x * Qnat n + x.
Proof.
intros n x.
unfold Qnat.
setoid_replace x with (x * 1) at 3.
 rewrite <- Qmult_plus_distr_r.
 destruct (Qeq_dec x 0) as [Hz| ]; [ rewrite Hz; reflexivity | idtac ].
 apply Qmult_inj_l; auto.
 unfold Qeq; simpl.
 do 2 rewrite Z.mul_1_r.
 rewrite Pos.mul_1_r, Z.add_1_r.
 apply Zpos_P_of_succ_nat.

 rewrite Qmult_comm, Qmult_1_l; reflexivity.
Qed.

Theorem Qlt_not_0 : ∀ x y, x < y → ¬ y - x == 0.
Proof.
intros i j H HH.
apply Qminus_eq in HH.
rewrite HH in H; apply Qlt_irrefl in H; contradiction.
Qed.

Theorem Qopp_minus : ∀ x y, - (x - y) == y - x.
Proof. intros; field. Qed.

Theorem Qplus_div : ∀ x y z, ¬(z == 0) → x + y / z == (x * z + y) / z.
Proof.
intros x y z Hc.
rewrite Qdiv_plus_distr_r.
rewrite Qdiv_mult_l; [ reflexivity | assumption ].
Qed.

Theorem Qminus_minus_assoc : ∀ x y z, x - (y - z) == (x - y) + z.
Proof. intros x y z; ring. Qed.

Theorem Qplus_minus_assoc : ∀ x y z, x + (y - z) == (x + y) - z.
Proof. intros x y z; ring. Qed.

Theorem Zposnat2Znat : ∀ i, (0 < i)%nat → Zpos (Pos.of_nat i) = Z.of_nat i.
Proof.
intros i Hi.
destruct i; [ apply lt_irrefl in Hi; contradiction | clear Hi ].
simpl; f_equal.
induction i; [ reflexivity | simpl ].
rewrite IHi; reflexivity.
Qed.

(* *)

Theorem Qplus_plus_swap : ∀ x y z, x + y + z == x + z + y.
Proof. intros; ring. Qed.

Theorem Qplus_minus_swap : ∀ x y z, x + y - z == x - z + y.
Proof. intros; ring. Qed.

Theorem Qplus_lt_compat_r : ∀ x y z, x < y → x + z < y + z.
Proof.
intros (x₁, x₂) (y₁, y₂) (z₁, z₂) H.
unfold Qlt in H; simpl in H.
unfold Qlt, Qplus; simpl.
do 2 rewrite Pos2Z.inj_mul.
do 2 rewrite Z.mul_add_distr_r.
do 4 rewrite Z.mul_assoc.
remember (z₁ * Zpos y₂ * Zpos x₂ * Zpos z₂)%Z as t.
remember (z₁ * Zpos y₂ * Zpos x₂)%Z as u.
rewrite Z.mul_shuffle0 in Hequ.
subst u.
rewrite <- Heqt.
apply Zplus_lt_compat_r.
clear t Heqt.
rewrite <- Zmult_assoc.
rewrite Z.mul_shuffle1.
remember (y₁ * Zpos z₂ * Zpos x₂ * Zpos z₂)%Z as t.
rewrite <- Zmult_assoc in Heqt.
rewrite Z.mul_shuffle1 in Heqt; subst t.
apply Zmult_lt_compat_r; [ idtac | assumption ].
rewrite <- Pos2Z.inj_mul.
apply Pos2Z.is_pos.
Qed.

Theorem Qminus_lt_lt_plus_r : ∀ x y z, x - y < z → x < z + y.
Proof.
intros x y z H.
apply Qplus_lt_compat_r with (z := y) in H.
rewrite <- Qplus_minus_swap, <- Qplus_minus_assoc in H.
unfold Qminus in H.
rewrite Qplus_opp_r, Qplus_0_r in H.
assumption.
Qed.

Theorem Qlt_minus_plus_lt_r : ∀ x y z, x < y - z → x + z < y.
Proof.
intros x y z H.
apply Qplus_lt_compat_r with (z := z) in H.
rewrite <- Qplus_minus_swap in H.
rewrite <- Qplus_minus_assoc in H.
unfold Qminus in H.
rewrite Qplus_opp_r, Qplus_0_r in H.
assumption.
Qed.

Theorem Qmult_div_swap : ∀ x y z, x / y * z == x * z / y.
Proof.
intros.
rewrite Qmult_comm, Qmult_div_assoc, Qmult_comm.
reflexivity.
Qed.

Theorem Qeq_shift_mult_l : ∀ x y z, ¬z == 0 → x / z == y → x == y * z.
Proof.
intros x y z Hc H.
rewrite <- H.
rewrite Qmult_div_swap.
rewrite Qdiv_mult_l; [ reflexivity | assumption ].
Qed.

Theorem Qeq_shift_div_l : ∀ x y z, ¬z == 0 → x == y * z → x / z == y.
Proof.
intros x y z Hz H.
rewrite H.
rewrite Qdiv_mult_l; [ reflexivity | assumption ].
Qed.

Theorem Qminus_diag : ∀ x, x - x == 0.
Proof. intros; apply Qplus_opp_r. Qed.

Theorem Qminus_eq_eq_plus_r : ∀ x y z, x - y == z → x == z + y.
Proof.
intros.
rewrite <- H.
rewrite <- Qplus_minus_swap, <- Qplus_minus_assoc.
rewrite Qminus_diag, Qplus_0_r.
reflexivity.
Qed.

(* TODO: transform the above with ?= like below. *)

Theorem Zplus_cmp_compat_r : ∀ n m p,
  (n ?= m)%Z = (n + p ?= m + p)%Z.
Proof.
intros.
rewrite Zplus_comm.
replace (m + p)%Z with (p + m)%Z by apply Zplus_comm.
symmetry; apply Zcompare_plus_compat.
Qed.

Theorem Zmult_cmp_compat_r : ∀ n m p,
  (0 < p)%Z
  → (n ?= m)%Z = (n * p ?= m * p)%Z.
Proof.
intros.
apply Zmult_compare_compat_r.
apply Z.lt_gt; assumption.
Qed.

Theorem Qplus_cmp_compat_r : ∀ x y z,
  (x ?= y) = (x + z ?= y + z).
Proof.
intros (x₁, x₂) (y₁, y₂) (z₁, z₂).
unfold Qcompare; simpl.
do 2 rewrite Pos2Z.inj_mul.
do 2 rewrite Z.mul_add_distr_r.
do 4 rewrite Z.mul_assoc.
remember (z₁ * Zpos y₂ * Zpos x₂ * Zpos z₂)%Z as t.
remember (z₁ * Zpos y₂ * Zpos x₂)%Z as u.
rewrite Z.mul_shuffle0 in Hequ.
subst u.
rewrite <- Heqt.
rewrite <- Zplus_cmp_compat_r.
clear t Heqt.
rewrite <- Zmult_assoc.
rewrite Z.mul_shuffle1.
remember (y₁ * Zpos z₂ * Zpos x₂ * Zpos z₂)%Z as t.
rewrite <- Zmult_assoc in Heqt.
rewrite Z.mul_shuffle1 in Heqt; subst t.
apply Zmult_cmp_compat_r.
rewrite <- Pos2Z.inj_mul.
apply Pos2Z.is_pos.
Qed.

Theorem Qcmp_plus_minus_cmp_r : ∀ x y z,
  (x ?= y + z) = (x - z ?= y).
Proof.
intros x y z.
rewrite Qplus_cmp_compat_r with (z := - z).
rewrite <- Qplus_assoc.
rewrite Qplus_opp_r, Qplus_0_r.
reflexivity.
Qed.
Theorem Qeq_plus_minus_eq_r : ∀ x y z, x == y + z → x - z == y.
Proof.
intros.
apply Qeq_alt in H; apply Qeq_alt.
rewrite <- H; symmetry; apply Qcmp_plus_minus_cmp_r.
Qed.
Theorem Qlt_plus_minus_lt_r : ∀ x y z, x < y + z → x - z < y.
Proof.
intros.
apply Qlt_alt in H; apply Qlt_alt.
rewrite <- H; symmetry; apply Qcmp_plus_minus_cmp_r.
Qed.

Theorem Qmult_cmp_compat_r : ∀ x y z,
  0 < z
  → (x ?= y) = (x * z ?= y * z).
Proof.
intros (a₁, a₂) (b₁, b₂) (c₁, c₂) H.
unfold Qcompare; simpl.
do 2 rewrite Pos2Z.inj_mul.
rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b₁).
rewrite <- Zmult_cmp_compat_r; [ reflexivity | idtac ].
apply Z.mul_pos_pos; [ idtac | reflexivity ].
unfold Qlt in H; simpl in H.
rewrite Zmult_1_r in H; assumption.
Qed.

Theorem Qcmp_shift_mult_l : ∀ x y z,
  0 < z
  → (x / z ?= y) = (x ?= y * z).
Proof.
intros x y z Hz.
erewrite Qmult_cmp_compat_r; [ idtac | eassumption ].
rewrite Qmult_div_swap.
unfold Qdiv.
rewrite <- Qmult_assoc.
rewrite Qmult_inv_r; [ idtac | apply Qgt_0_not_0; assumption ].
rewrite Qmult_1_r; reflexivity.
Qed.

Theorem Qlt_shift_mult_l : ∀ x y z, 0 < z → x / z < y → x < y * z.
Proof.
intros x y z Hc H.
rewrite Qlt_alt in H |- *.
rewrite <- H; symmetry; apply Qcmp_shift_mult_l; assumption.
Qed.

Theorem Qcmp_shift_mult_r : ∀ x y z,
  0 < z
  → (x ?= y / z) = (x * z ?= y).
Proof.
intros x y z Hz.
erewrite Qmult_cmp_compat_r; [ idtac | eassumption ].
rewrite Qmult_div_swap.
unfold Qdiv.
rewrite <- Qmult_assoc.
rewrite Qmult_inv_r; [ idtac | apply Qgt_0_not_0; assumption ].
rewrite Qmult_1_r; reflexivity.
Qed.

Theorem Qlt_shift_mult_r : ∀ x y z, 0 < z → x < y / z → x * z < y.
Proof.
intros x y z Hc H.
rewrite Qlt_alt in H |- *.
rewrite <- H; symmetry; apply Qcmp_shift_mult_r; assumption.
Qed.

Theorem Qplus_cmp_cmp_minus_r : ∀ x y z,
  (x + y ?= z) = (x ?= z - y).
Proof.
intros x y z.
rewrite Qplus_cmp_compat_r with (z := - y).
rewrite <- Qplus_assoc.
rewrite Qplus_opp_r, Qplus_0_r.
reflexivity.
Qed.
Theorem Qplus_lt_lt_minus_r : ∀ x y z, x + y < z → x < z - y.
Proof.
intros x y z H.
rewrite Qlt_alt in H |- *.
rewrite <- H; symmetry; apply Qplus_cmp_cmp_minus_r.
Qed.

Theorem Qplus_cmp_compat_l : ∀ x y z,
  (x ?= y) = (z + x ?= z + y).
Proof.
intros x y z.
do 2 rewrite (Qplus_comm z).
apply Qplus_cmp_compat_r.
Qed.

Theorem list_Forall_inv : ∀ A (P : A → Prop) a l,
  List.Forall P [a … l] → P a ∧ List.Forall P l.
Proof.
intros A P a l H.
inversion H; split; assumption.
Qed.

Theorem Pos2Z_ne_0 : ∀ p, (Zpos p ≠ 0)%Z.
Proof.
intros p H.
pose proof (Zgt_pos_0 p) as HH.
rewrite H in HH.
apply Zgt_irrefl in HH; assumption.
Qed.

Theorem Qnum_inv : ∀ a, (0 < Qnum a)%Z → Qnum (/ a) = Zpos (Qden a).
Proof.
intros (a, b) Ha; simpl in Ha |- *.
unfold Qinv; simpl.
destruct a as [| a| a]; simpl.
 apply Z.lt_irrefl in Ha; contradiction.

 reflexivity.

 apply Zlt_not_le in Ha.
 exfalso; apply Ha, Z.lt_le_incl, Zlt_neg_0.
Qed.

Theorem Qden_inv : ∀ a, (0 < Qnum a)%Z → Zpos (Qden (/ a)) = Qnum a.
Proof.
intros (a, b) Ha; simpl in Ha |- *.
unfold Qinv; simpl.
destruct a as [| a| a]; simpl.
 apply Z.lt_irrefl in Ha; contradiction.

 reflexivity.

 apply Zlt_not_le in Ha.
 exfalso; apply Ha, Z.lt_le_incl, Zlt_neg_0.
Qed.

Theorem Qnum_minus_distr_r : ∀ a b c, a - b # c == ((a # c) - (b # c)).
Proof.
intros a b c.
unfold Qeq; simpl.
rewrite Zmult_minus_distr_r.
rewrite Zmult_plus_distr_l.
rewrite Pos2Z.inj_mul.
do 2 rewrite Zmult_assoc.
do 2 rewrite Z.mul_opp_l.
reflexivity.
Qed.

Definition pair_rec A B C (f : A → B → C) := λ xy, f (fst xy) (snd xy).

Theorem divmod_div : ∀ a b, fst (divmod a b 0 b) = (a / S b)%nat.
Proof. intros a b; reflexivity. Qed.

Theorem Pos2Nat_ne_0 : ∀ a, (Pos.to_nat a ≠ 0)%nat.
Proof.
intros a H.
pose proof Pos2Nat.is_pos a as HH.
rewrite H in HH.
revert HH; apply lt_irrefl.
Qed.
Global Hint Resolve Pos2Nat_ne_0 : Arith.

Open Scope positive_scope.

Theorem Pos_mul_shuffle0 : ∀ n m p, n * m * p = n * p * m.
Proof.
intros n m p.
rewrite <- Pos.mul_assoc.
remember (m * p) as mp.
rewrite Pos.mul_comm in Heqmp; subst mp.
apply Pos.mul_assoc.
Qed.

Close Scope positive_scope.

Theorem Z2Nat_sub_min :  ∀ x y, Z.to_nat (x - Z.min x y) = Z.to_nat (x - y).
Proof.
intros x y.
destruct (Z.min_dec x y) as [H₁| H₁].
 rewrite H₁.
 rewrite Z.sub_diag.
 apply Z.min_l_iff in H₁.
 apply Z.le_sub_0 in H₁.
 destruct (x - y)%Z as [| p| p]; [ reflexivity | idtac | reflexivity ].
 apply Z.nlt_ge in H₁.
 exfalso; apply H₁, Pos2Z.is_pos.

 rewrite H₁; reflexivity.
Qed.

Theorem Z2Nat_sub_min1 : ∀ x y z,
  (Z.to_nat (Z.min x y - z) + Z.to_nat (y - x))%nat =
  Z.to_nat (y - Z.min z x).
Proof.
intros x y z.
rewrite <- Z.sub_min_distr_r.
rewrite <- Z.sub_max_distr_l.
destruct (Z_le_dec (x - z) (y - z)) as [Hle₁| Hgt₁].
 rewrite Z.min_l; [ idtac | assumption ].
 apply Z.sub_le_mono_r in Hle₁.
 destruct (Z_le_dec (y - z) (y - x)) as [Hle₂| Hgt₂].
  rewrite Z.max_r; [ idtac | assumption ].
  apply Z.sub_le_mono_l in Hle₂.
  rewrite Z.sub_le_mono_r with (p := z) in Hle₂.
  rewrite Z.sub_diag in Hle₂.
  destruct (x - z)%Z as [| p| p]; [ reflexivity | idtac | reflexivity ].
  apply Z.le_ngt in Hle₂.
  exfalso; apply Hle₂, Pos2Z.is_pos.

  apply Z.nle_gt, Z.lt_le_incl in Hgt₂.
  rewrite Z.max_l; [ idtac | assumption ].
  apply Z.sub_le_mono_l in Hgt₂.
  rewrite Z.sub_le_mono_r with (p := x) in Hle₁.
  rewrite Z.sub_diag in Hle₁.
  rewrite Z.sub_le_mono_r with (p := z) in Hgt₂.
  rewrite Z.sub_diag in Hgt₂.
  rewrite <- Z2Nat.inj_add; [ idtac | assumption | assumption ].
  rewrite Z.add_comm, Z.add_sub_assoc, Z.sub_add.
  reflexivity.

 apply Z.nle_gt, Z.lt_le_incl in Hgt₁.
 rewrite Z.min_r; [ idtac | assumption ].
 apply Z.sub_le_mono_r in Hgt₁.
 destruct (Z_le_dec (y - z) (y - x)) as [Hle₂| Hgt₂].
  rewrite Z.max_r; [ idtac | assumption ].
  apply Z.sub_le_mono_l in Hle₂.
  eapply Z.le_trans in Hle₂; [ idtac | eassumption ].
  rewrite Z.sub_le_mono_r with (p := z) in Hle₂.
  rewrite Z.sub_diag in Hle₂.
  destruct (y - z)%Z as [| p| p]; [ reflexivity | idtac | reflexivity ].
  apply Z.le_ngt in Hle₂.
  exfalso; apply Hle₂, Pos2Z.is_pos.

  apply Z.nle_gt, Z.lt_le_incl in Hgt₂.
  rewrite Z.max_l; [ idtac | assumption ].
  apply Z.sub_le_mono_l in Hgt₂.
  rewrite Z.sub_le_mono_r with (p := x) in Hgt₁.
  rewrite Z.sub_diag in Hgt₁.
  rewrite Nat.add_comm.
  destruct (y - x)%Z as [| p| p]; [ reflexivity | idtac | reflexivity ].
  apply Z.le_ngt in Hgt₁.
  exfalso; apply Hgt₁, Pos2Z.is_pos.
Qed.

Theorem Z2Nat_sub_min2 : ∀ x y z,
  (Z.to_nat (Z.min x y - z) + Z.to_nat (x - y))%nat =
  Z.to_nat (x - Z.min y z).
Proof.
intros x y z.
rewrite <- Z.sub_min_distr_r.
rewrite <- Z.sub_max_distr_l.
destruct (Z_le_dec (x - z) (y - z)) as [Hle₁| Hgt₁].
 rewrite Z.min_l; [ idtac | assumption ].
 apply Z.sub_le_mono_r in Hle₁.
 destruct (Z_le_dec (x - y) (x - z)) as [Hle₂| Hgt₂].
  rewrite Z.max_r; [ idtac | assumption ].
  rewrite Z.sub_le_mono_r with (p := y) in Hle₁.
  rewrite Z.sub_diag in Hle₁.
  rewrite Nat.add_comm.
  destruct (x - y)%Z as [| p| p]; [ reflexivity | idtac | reflexivity ].
  apply Z.le_ngt in Hle₁.
  exfalso; apply Hle₁, Pos2Z.is_pos.

  apply Z.nle_gt, Z.lt_le_incl in Hgt₂.
  rewrite Z.max_l; [ idtac | assumption ].
  apply Z.sub_le_mono_l in Hgt₂.
  eapply Z.le_trans in Hgt₂; [ idtac | eassumption ].
  rewrite Z.sub_le_mono_r with (p := z) in Hgt₂.
  rewrite Z.sub_diag in Hgt₂.
  destruct (x - z)%Z as [| p| p]; [ reflexivity | idtac | reflexivity ].
  apply Z.le_ngt in Hgt₂.
  exfalso; apply Hgt₂, Pos2Z.is_pos.

 apply Z.nle_gt, Z.lt_le_incl in Hgt₁.
 rewrite Z.min_r; [ idtac | assumption ].
 apply Z.sub_le_mono_r in Hgt₁.
 destruct (Z_le_dec (x - y) (x - z)) as [Hle₂| Hgt₂].
  rewrite Z.max_r; [ idtac | assumption ].
  apply Z.sub_le_mono_l in Hle₂.
  rewrite Z.sub_le_mono_r with (p := y) in Hgt₁.
  rewrite Z.sub_diag in Hgt₁.
  rewrite Z.sub_le_mono_r with (p := z) in Hle₂.
  rewrite Z.sub_diag in Hle₂.
  rewrite <- Z2Nat.inj_add; [ idtac | assumption | assumption ].
  rewrite Z.add_comm, Z.add_sub_assoc, Z.sub_add.
  reflexivity.

  apply Z.nle_gt, Z.lt_le_incl in Hgt₂.
  rewrite Z.max_l; [ idtac | assumption ].
  apply Z.sub_le_mono_l in Hgt₂.
  rewrite Z.sub_le_mono_r with (p := z) in Hgt₂.
  rewrite Z.sub_diag in Hgt₂.
  destruct (y - z)%Z as [| p| p]; [ reflexivity | idtac | reflexivity ].
  apply Z.le_ngt in Hgt₂.
  exfalso; apply Hgt₂, Pos2Z.is_pos.
Qed.

Theorem Z2Nat_inj_mul_pos_r : ∀ n m,
  Z.to_nat (n * Zpos m) = (Z.to_nat n * Pos.to_nat m)%nat.
Proof.
intros n m.
destruct n as [| n| ]; [ reflexivity | simpl | reflexivity ].
rewrite Pos2Nat.inj_mul; reflexivity.
Qed.

Theorem Nat_sub_sub_distr : ∀ n m p, (p ≤ m → n - (m - p) = n + p - m)%nat.
Proof.
intros n m p Hpm.
rewrite Nat.add_comm.
revert n m Hpm.
induction p; intros.
 rewrite Nat.sub_0_r, Nat.add_0_l; reflexivity.

 destruct m as [| m].
  exfalso; revert Hpm; apply Nat.nle_succ_0.

  rewrite Nat.sub_succ; simpl.
  apply Nat.succ_le_mono in Hpm.
  apply IHp; assumption.
Qed.

Theorem Nat_sub_sub_comm : ∀ m n p, (m - n - p)%nat = (m - p - n)%nat.
Proof.
intros.
do 2 rewrite <- Nat.sub_add_distr.
rewrite Nat.add_comm.
apply eq_refl.
Qed.

Theorem Z2Nat_id_max : ∀ x, Z.of_nat (Z.to_nat x) = Z.max 0 x.
Proof.
intros x.
destruct x as [| x| x]; [ reflexivity | idtac | reflexivity ].
rewrite Z2Nat.id; [ reflexivity | apply Pos2Z.is_nonneg ].
Qed.

Theorem Nat_sub_succ_1 : ∀ n, (S n - 1 = n)%nat.
Proof. intros n; simpl; rewrite Nat.sub_0_r; reflexivity. Qed.

Theorem Z_div_pos_is_nonneg : ∀ x y, (0 <= Zpos x / Zpos y)%Z.
Proof.
intros x y.
apply Z.div_pos.
 apply Pos2Z.is_nonneg.

 apply Pos2Z.is_pos.
Qed.

Theorem Pos2Nat_to_pos : ∀ x,
  (0 < x)%Z
  → Pos.to_nat (Z.to_pos x) = Z.to_nat x.
Proof.
intros x Hx.
destruct x as [| x| x].
 exfalso; revert Hx; apply Z.lt_irrefl.

 reflexivity.

 exfalso; apply Z.nle_gt in Hx.
 apply Hx, Pos2Z.neg_is_nonpos.
Qed.

Theorem Nat_divides_l : ∀ a b, (∃ c, a = (b * c)%nat) ↔ (b | a)%nat.
Proof.
intros a b.
split; intros H.
 destruct H as (c, Hc); subst a.
 exists c; apply Nat.mul_comm.

 destruct H as (c, Hc); subst a.
 exists c; apply Nat.mul_comm.
Qed.

Theorem Nat_lcm_divides : ∀ a b c,
  (a ≠ 0
   → b ≠ 0
     → (a | c)
       → (b | c)
         → (Nat.lcm a b | c))%nat.
Proof.
intros k l c Hkp Hlp Hkm Hlm.
apply Nat_divides_l in Hkm.
apply Nat_divides_l in Hlm.
apply Nat_divides_l.
destruct Hkm as (k₁, Hk₁).
destruct Hlm as (l₁, Hl₁).
pose proof (Nat.gcd_divide_l k l) as Hk'.
pose proof (Nat.gcd_divide_r k l) as Hl'.
destruct Hk' as (k', Hk').
destruct Hl' as (l', Hl').
remember (Nat.gcd k l) as g eqn:Hg .
subst k l.
apply Nat.gcd_div_gcd in Hg.
 rewrite Nat.div_mul in Hg.
  rewrite Nat.div_mul in Hg.
   unfold Nat.lcm.
   rewrite Nat.gcd_mul_mono_r.
   rewrite Hg, Nat.mul_1_l.
   rewrite Nat.div_mul.
    rewrite Hk₁ in Hl₁.
    rewrite Nat.mul_shuffle0 in Hl₁; symmetry in Hl₁.
    rewrite Nat.mul_shuffle0 in Hl₁; symmetry in Hl₁.
    apply Nat.mul_cancel_r in Hl₁.
     exists (k₁ / l')%nat.
     rewrite <- Nat.mul_assoc.
     rewrite <- Nat.divide_div_mul_exact.
      replace (l' * k₁)%nat with (k₁ * l')%nat by apply Nat.mul_comm.
      rewrite Nat.div_mul.
       assumption.

       intros H; apply Hlp; subst l'; reflexivity.

      intros H; apply Hlp; subst l'; reflexivity.

      apply Nat.gauss with (m := k').
       rewrite Hl₁; exists l₁; apply Nat.mul_comm.

       rewrite Nat.gcd_comm; assumption.

     intros H1; apply Hlp; subst g; auto.

    intros H; apply Hlp; subst g; auto.

   intros H; apply Hlp; subst g; auto.

  intros H; apply Hlp; subst g; auto.

 intros H; apply Hlp; subst g; auto.
Qed.

Theorem Nat_gcd_le_l : ∀ a b, (a ≠ 0 → Nat.gcd a b ≤ a)%nat.
Proof.
intros a b Ha.
pose proof (Nat.gcd_divide_l a b) as Hg.
destruct Hg as (c, Hg).
rewrite Hg in |- * at 2.
unfold Nat.gcd.
destruct c; [ contradiction | simpl ].
apply le_plus_l.
Qed.

Theorem Nat_gcd_le_r : ∀ a b, (b ≠ 0 → Nat.gcd a b ≤ b)%nat.
Proof.
intros a b Hb.
rewrite Nat.gcd_comm.
apply Nat_gcd_le_l; assumption.
Qed.

Theorem Nat_le_lcm_l : ∀ a b, (b ≠ 0 → a ≤ Nat.lcm a b)%nat.
Proof.
intros a b Hb.
remember Hb as Hab; clear HeqHab.
apply Nat_gcd_le_l with (b := a) in Hab.
rewrite Nat.gcd_comm in Hab.
unfold Nat.lcm.
eapply Nat.div_le_mono in Hab.
 rewrite Nat.div_same in Hab.
  apply Nat.mul_le_mono_l with (p := a) in Hab.
  rewrite Nat.mul_1_r in Hab; assumption.

  destruct a; [ assumption | idtac ].
  intros H; apply Nat.gcd_eq_0_r in H; contradiction.

 intros H; apply Nat.gcd_eq_0_r in H; contradiction.
Qed.

Theorem Nat_divides_lcm_l : ∀ a b, (a | Nat.lcm a b)%nat.
Proof.
intros a b.
unfold Nat.lcm.
exists (b / Nat.gcd a b)%nat.
apply Nat.mul_comm.
Qed.

Theorem Nat_compare_add : ∀ a b c,
  Nat.compare a b = Nat.compare (a + c) (b + c).
Proof.
intros a b c.
remember (Nat.compare a b) as c₁ eqn:Hc₁ .
remember (Nat.compare (a + c) (b + c)) as c₂ eqn:Hc₂ .
symmetry in Hc₁, Hc₂.
destruct c₁.
 apply nat_compare_eq in Hc₁; subst a.
 destruct c₂; auto.
  apply nat_compare_lt in Hc₂.
  exfalso; revert Hc₂; apply Nat.lt_irrefl.

  apply nat_compare_gt in Hc₂.
  exfalso; revert Hc₂; apply Nat.lt_irrefl.

 apply nat_compare_lt in Hc₁.
 destruct c₂; auto.
  apply nat_compare_eq in Hc₂.
  apply Nat.add_cancel_r in Hc₂; subst a.
  exfalso; revert Hc₁; apply Nat.lt_irrefl.

  apply nat_compare_gt in Hc₂.
  apply Nat.add_lt_mono_r in Hc₂.
  eapply Nat.lt_trans in Hc₁; eauto .
  exfalso; revert Hc₁; apply Nat.lt_irrefl.

 apply nat_compare_gt in Hc₁.
 destruct c₂; auto.
  apply nat_compare_eq in Hc₂.
  apply Nat.add_cancel_r in Hc₂; subst a.
  exfalso; revert Hc₁; apply Nat.lt_irrefl.

  apply nat_compare_lt in Hc₂.
  apply Nat.add_lt_mono_r in Hc₂.
  eapply Nat.lt_trans in Hc₁; eauto .
  exfalso; revert Hc₁; apply Nat.lt_irrefl.
Qed.

Theorem list_in_cons_app : ∀ A (a : A) x y l,
  List.In a [x … l ++ [y]] → List.In a [x; y … l].
Proof.
intros A a x y l H.
simpl in H; simpl.
destruct H as [| H]; [ left; assumption | right ].
revert H; clear; intros.
induction l as [| x]; intros; [ assumption | simpl ].
simpl in H.
destruct H as [H| H].
 right; left; assumption.

 apply IHl in H.
 destruct H as [H| H]; [ left | right; right ]; assumption.
Qed.

Theorem list_map_app_at : ∀ A B (g : A → B) l x,
  List.map g l ++ [g x] = List.map g (l ++ [x]).
Proof.
intros.
induction l as [| b]; [ reflexivity | simpl ].
rewrite IHl; reflexivity.
Qed.

Theorem imp_or_tauto : ∀ A B : Prop, (A → B) → A → A ∧ B.
Proof. tauto. Qed.

Theorem list_last_cons_app : ∀ A x y (l : list A) d,
  List.last [x … l ++ [y]] d = y.
Proof.
intros A x y l d.
revert x.
induction l as [| z]; [ reflexivity | intros ].
simpl in IHl; simpl.
apply IHl.
Qed.

Theorem list_nth_nil : ∀ A n (d : A), List.nth n [] d = d.
Proof. intros A n d; destruct n; reflexivity. Qed.

Theorem list_skipn_nil : ∀ A n, List.skipn n [] = ([] : list A).
Proof. intros A n; destruct n; reflexivity. Qed.

Theorem list_skipn_overflow : ∀ A n (cl : list A),
  length cl ≤ n → List.skipn n cl = [].
Proof.
intros A n cl H.
revert n H.
induction cl as [| c]; intros.
 rewrite list_skipn_nil; reflexivity.

 destruct n; [ exfalso; simpl in H; fast_omega H | simpl ].
 apply IHcl, le_S_n; assumption.
Qed.

Theorem match_id : ∀ α a (b : α), match a with O => b | S _ => b end = b.
Proof. intros α a b; destruct a; reflexivity. Qed.

Theorem fold_sub_succ_l : ∀ a b,
  (match a with 0 => S b | S c => b - c end = S b - a)%nat.
Proof. reflexivity. Qed.

Theorem Sorted_inv_1 {A} : ∀ (f : A → A → Prop) x l,
  Sorted f [x … l]
  → Sorted f l.
Proof.
intros f x l H.
apply Sorted_LocallySorted_iff in H.
apply Sorted_LocallySorted_iff.
inversion H; [ constructor | assumption ].
Qed.

Theorem Sorted_inv_2 {A} : ∀ (f : A → A → Prop) x y l,
  Sorted f [x; y … l]
  → f x y ∧ Sorted f [y … l].
Proof.
intros f x y l H.
apply Sorted_LocallySorted_iff in H.
rewrite Sorted_LocallySorted_iff.
inversion H; subst a b l0.
split; assumption.
Qed.

Theorem Sorted_minus_2nd {A} : ∀ (f : A → A → Prop) x₁ x₂ xl,
  (∀ x y z, f x y → f y z → f x z)
  → Sorted f [x₁; x₂ … xl]
    → Sorted f [x₁ … xl].
Proof.
intros f x₁ x₂ l Ht H.
apply Sorted_LocallySorted_iff.
destruct l as [| x₃]; [ constructor | intros ].
constructor.
 apply Sorted_LocallySorted_iff.
 do 2 apply Sorted_inv_1 in H.
 assumption.

 apply Sorted_inv_2 in H; destruct H as (Hlt₁, H).
 apply Sorted_inv_2 in H; destruct H as (Hlt₂, H).
 eapply Ht; eassumption.
Qed.

Theorem Sorted_minus_3rd {A} : ∀ (f : A → A → Prop) x₁ x₂ x₃ xl,
  (∀ x y z, f x y → f y z → f x z)
  → Sorted f [x₁; x₂; x₃ … xl]
    → Sorted f [x₁; x₂ … xl].
Proof.
intros f x₁ x₂ x₃ l Ht H.
apply Sorted_LocallySorted_iff.
constructor.
 apply Sorted_inv_1 in H.
 apply Sorted_LocallySorted_iff.
 eapply Sorted_minus_2nd; eassumption.

 apply Sorted_inv_2 in H; destruct H; assumption.
Qed.

Theorem Z_div_mul_swap : ∀ a b c, (b | a)%Z → (a / b * c = a * c / b)%Z.
Proof.
intros a b c H.
destruct H as (d, H).
subst a.
destruct (Z_zerop b) as [Hb| Hb].
 subst b; rewrite Z.mul_0_r.
 reflexivity.

 rewrite Z.div_mul; [ idtac | assumption ].
 rewrite Z.mul_shuffle0.
 rewrite Z.div_mul; [ idtac | assumption ].
 reflexivity.
Qed.

Theorem Z_div_reg_r : ∀ a b c,
  (c | a)%Z → (c | b)%Z → (a / c = b / c)%Z → a = b.
Proof.
intros a b c Ha Hb Hab.
destruct Ha as (d, Ha).
destruct Hb as (e, Hb).
subst a b.
destruct (Z_zerop c) as [Hc| Hc].
 subst c.
 do 2 rewrite Z.mul_0_r; reflexivity.

 rewrite Z.div_mul in Hab; [ idtac | assumption ].
 rewrite Z.div_mul in Hab; [ idtac | assumption ].
 subst d; reflexivity.
Qed.

Theorem Z_gcd_pos_r_le : ∀ a b, (Z.gcd a (Zpos b) <= Zpos b)%Z.
Proof.
intros a b.
pose proof (Z.gcd_divide_r a (Zpos b)) as Hd.
destruct Hd as (c, Hc).
rewrite Hc in |- * at 2.
rewrite Z.mul_comm.
apply Z.le_mul_diag_r.
 pose proof (Z.gcd_nonneg a (Zpos b))%Z as H.
 assert (Z.gcd a (Zpos b) ≠ 0)%Z as HH.
  intros HH; apply Z.gcd_eq_0_r in HH.
  revert HH; apply Pos2Z_ne_0.

  lia.

 rename Hc into Hd.
 destruct (Z_zerop c) as [Hc| Hc].
  subst c; simpl in Hd.
  exfalso; revert Hd; apply Pos2Z_ne_0.

  destruct c as [| c| c].
   exfalso; apply Hc; reflexivity.

   pose proof (Pos2Z.is_pos c) as Hp.
   fast_omega Hp.

   exfalso; clear Hc.
   assert (Zpos b <= 0)%Z as HH.
    rewrite Hd.
    apply Z.mul_nonpos_nonneg.
     apply Pos2Z.neg_is_nonpos.

     apply Z.gcd_nonneg.

    apply Z.nlt_ge in HH.
    apply HH, Pos2Z.is_pos.
Qed.

Theorem Qlt_sub_lt_add_l : ∀ n m p, (n - m < p)%Q ↔ (n < m + p)%Q.
Proof.
intros n m p.
destruct p as (pn, pd).
destruct m as (mn, md).
destruct n as (nn, nd).
unfold Qlt; simpl.
split; intros H.
 rewrite Z.mul_add_distr_r.
 apply Z.lt_sub_lt_add_l.
 rewrite Z.mul_shuffle0, Pos2Z.inj_mul, Z.mul_assoc.
 rewrite <- Z.mul_sub_distr_r, Z.mul_shuffle0.
 rewrite <- Z.mul_assoc, <- Pos2Z.inj_mul.
 rewrite <- Z.add_opp_r.
 rewrite <- Z.mul_opp_l; assumption.

 rewrite Z.mul_add_distr_r.
 do 2 rewrite Z.mul_opp_l.
 rewrite Z.add_opp_r.
 apply Z.lt_sub_lt_add_l.
 rewrite Pos2Z.inj_mul, Z.mul_assoc.
 rewrite Pos2Z.inj_mul, Z.mul_assoc in H.
 rewrite Z.mul_add_distr_r in H.
 remember (nn * Zpos md * Zpos pd)%Z as x.
 rewrite Z.mul_shuffle0.
 remember (mn * Zpos pd * Zpos nd)%Z as y.
 rewrite Z.mul_shuffle0; assumption.
Qed.

Theorem Qle_sub_le_add_l : ∀ n m p, (n - m <= p)%Q ↔ (n <= m + p)%Q.
Proof.
intros n m p.
destruct p as (pn, pd).
destruct m as (mn, md).
destruct n as (nn, nd).
unfold Qle; simpl.
split; intros H.
 rewrite Z.mul_add_distr_r.
 apply Z.le_sub_le_add_l.
 rewrite Z.mul_shuffle0, Pos2Z.inj_mul, Z.mul_assoc.
 rewrite <- Z.mul_sub_distr_r, Z.mul_shuffle0.
 rewrite <- Z.mul_assoc, <- Pos2Z.inj_mul.
 rewrite <- Z.add_opp_r.
 rewrite <- Z.mul_opp_l; assumption.

 rewrite Z.mul_add_distr_r.
 do 2 rewrite Z.mul_opp_l.
 rewrite Z.add_opp_r.
 apply Z.le_sub_le_add_l.
 rewrite Pos2Z.inj_mul, Z.mul_assoc.
 rewrite Pos2Z.inj_mul, Z.mul_assoc in H.
 rewrite Z.mul_add_distr_r in H.
 remember (nn * Zpos md * Zpos pd)%Z as x.
 rewrite Z.mul_shuffle0.
 remember (mn * Zpos pd * Zpos nd)%Z as y.
 rewrite Z.mul_shuffle0; assumption.
Qed.

Theorem list_nth_in : ∀ A l n (d : A),
  (n < length l)%nat
  → List.nth n l d ∈ l.
Proof.
intros A l n d Hnl.
revert n Hnl.
induction l as [| x]; intros.
 exfalso; revert Hnl; apply Nat.nlt_0_r.

 simpl in Hnl.
 destruct n; [ left; reflexivity | simpl ].
 apply Nat.succ_lt_mono in Hnl.
 right; apply IHl; assumption.
Qed.

Theorem list_fold_right_map : ∀ A B C (f : B → A → A) (g : C → B) l a,
  List.fold_right f a (List.map g l) =
  List.fold_right (λ b acc, f (g b) acc) a l.
Proof.
intros A B C f g l a.
induction l as [| x]; [ reflexivity | simpl; f_equal; assumption ].
Qed.

Theorem Z_div_gcd_r_pos : ∀ a b, (0 < b)%Z → (0 < b / Z.gcd a b)%Z.
Proof.
intros a b Hb.
pose proof (Z.gcd_divide_r a b) as H.
destruct H as (c, Hc).
rewrite Hc in |- * at 1.
rewrite Z.divide_div_mul_exact.
 rewrite Z.div_same.
  rewrite Z.mul_1_r.
  destruct c as [| c| c].
   simpl in Hc; subst b; assumption.

   apply Pos2Z.is_pos.

   remember Hb as H; clear HeqH.
   rewrite Hc in H.
   apply Z.lt_0_mul in H.
   destruct H as [H| H].
    destruct H; assumption.

    destruct H as (H, _).
    apply Z.nle_gt in H.
    exfalso; apply H, Z.gcd_nonneg.

  intros H.
  rewrite H in Hc; simpl in Hc.
  rewrite Z.mul_0_r in Hc; subst b.
  revert Hb; apply Z.lt_irrefl.

 intros H.
 rewrite H in Hc; simpl in Hc.
 rewrite Z.mul_0_r in Hc; subst b.
 revert Hb; apply Z.lt_irrefl.

 exists 1%Z.
 rewrite Z.mul_1_l; reflexivity.
Qed.

Definition Qmin x y := if Qlt_le_dec x y then x else y.

Theorem Qmin_dec : ∀ n m, {Qmin n m = n} + {Qmin n m = m}.
Proof.
intros n m.
unfold Qmin.
destruct (Qlt_le_dec n m); [ left | right ]; reflexivity.
Qed.

Theorem Qmin_comm : ∀ n m, Qmin n m == Qmin m n.
Proof.
intros n m.
unfold Qmin.
destruct (Qlt_le_dec n m) as [H₁| H₁].
 destruct (Qlt_le_dec m n) as [H₂| H₂]; [ idtac | reflexivity ].
 apply Qlt_le_weak, Qle_not_lt in H₂.
 contradiction.

 destruct (Qlt_le_dec m n) as [H₂| H₂]; [ reflexivity | idtac ].
 apply Qle_antisym; assumption.
Qed.

Theorem Qmin_l : ∀ n m, (n <= m)%Q → Qmin n m == n.
Proof.
intros n m H.
unfold Qmin.
destruct (Qlt_le_dec n m) as [| Hge]; [ reflexivity | idtac ].
apply Qle_antisym; assumption.
Qed.

Theorem Q_sub_0_r : ∀ n, (n - 0)%Q == n.
Proof.
intros n.
unfold Qeq; simpl.
rewrite Z.mul_1_r, Z.add_0_r, Pos.mul_1_r; reflexivity.
Qed.

Theorem List_In_nth : ∀ α a la (d : α),
  a ∈ la
  → ∃ n, a = List.nth n la d.
Proof.
intros u a la d Ha.
revert a Ha.
induction la as [| b]; intros; [ contradiction | idtac ].
simpl in Ha.
destruct Ha as [Ha| Ha].
 subst b.
 exists O; reflexivity.

 apply IHla in Ha.
 destruct Ha as (n, Ha).
 exists (S n); simpl.
 assumption.
Qed.

Global Hint Resolve Pos2Z.is_nonneg : Arith.
Global Hint Resolve Pos2Nat.is_pos : Arith.
Global Hint Resolve Pos2Z_ne_0 : Arith.

(* compatibility with old version of Coq *)

Definition omodulo x y := if Nat.eq_dec y 0%nat then 0%nat else x mod y.
Notation "x 'omod' y" := (omodulo x y) (at level 40) : nat_scope.

Theorem omod_0_l : ∀ a, 0 omod a = 0%nat.
Proof.
intros.
destruct a; [ easy | apply Nat.sub_diag ].
Qed.

Theorem omod_divide : ∀ a b : nat, b ≠ 0%nat → a omod b = 0%nat ↔ (b | a).
Proof.
intros * Hbz.
unfold omodulo.
destruct (Nat.eq_dec b 0) as [H| H]; [ easy | ].
now apply Nat.mod_divide.
Qed.


(** Multisets of tuples *)
Require Import Coq.Sets.Ensembles.
Require Import Bedrock.Bedrock.
Require Import Coq.Relations.Relations.

(* This section copied from Fiat for convenience, to avoid circular dependencies across libraries! *)
Section IndexedEnsembles.
  Context {ElementType : Type}.

  Record IndexedElement :=
    { elementIndex : nat;
      indexedElement : ElementType }.

  Definition IndexedEnsemble := Ensemble IndexedElement.

  Definition IndexedEnsemble_In
             (ensemble : IndexedEnsemble)
             (item : ElementType) :=
    exists idx, Ensembles.In _ ensemble {| elementIndex := idx; indexedElement := item |}.

  Definition IndexedEnsembleSubtract
             (element : ElementType)
             (ens : IndexedEnsemble)
  : IndexedEnsemble :=
    fun element' => indexedElement element' <> element /\ ens element'.

  (* 'Deleting' a set of tuples [R] from a relation [F] is the same
   as taking the intersection of [F] and the complement of [R]. *)
  Definition EnsembleDelete
             (F : IndexedEnsemble)
             (R : Ensemble ElementType)
    := Intersection _ F (Complement _ (fun iel => R (indexedElement iel))).

  Definition IndexedEnsembleUpdate
             (ens : IndexedEnsemble)
             (cond : Ensemble ElementType)
             (updateR : relation ElementType)
  : IndexedEnsemble
    := fun e => (exists f: IndexedElement, ((ens f) /\ cond (indexedElement f) /\ updateR (indexedElement f) (indexedElement e))
                                           /\ elementIndex e = elementIndex f) \/
                ((ens e) /\ Complement _ (fun f => cond (indexedElement f)) e).

  Definition UnIndexedEnsembleListEquivalence
             (ensemble : IndexedEnsemble)
             (l : list ElementType)  :=
    exists l', (map indexedElement l') = l /\
               (forall x, Ensembles.In _ ensemble x <-> List.In x l') /\
               NoDup (map elementIndex l').

  Definition UnConstrFreshIdx
             (ensemble : IndexedEnsemble)
             (bound : nat) :=
  forall element,
    ensemble element
    -> lt (elementIndex element) bound.

  Definition EnsembleIndexedListEquivalence
             (ensemble : IndexedEnsemble)
             (l : list ElementType) :=
    (exists bound, UnConstrFreshIdx ensemble bound)
    /\ UnIndexedEnsembleListEquivalence ensemble l.
End IndexedEnsembles.

Definition tupl := list W.
Definition tuples := @IndexedEnsemble tupl.

Definition EnsembleInsert {A : Type}
           (a : A)
           (R : Ensemble A)
           (a' : A) :=
  a' = a \/ R a'.

Lemma in_ensemble_insert_iff :
  forall {A} table tup inserted,
    Ensembles.In A (EnsembleInsert inserted table) tup <->
    tup = inserted \/ Ensembles.In A table tup.
Proof.
  firstorder.
Qed.

Definition Equiv (ts1 ts2 : tuples) := forall t, ts1 t <-> ts2 t.

Theorem Equiv_refl : forall ts1 ts2, ts1 = ts2 -> Equiv ts1 ts2.
Proof.
  unfold Equiv; firstorder congruence.
Qed.

Hint Resolve Equiv_refl.

Definition insert (ts : tuples) (t : tupl) (ts' : tuples) : Prop :=
  exists idx,
    UnConstrFreshIdx ts idx
    /\ Equiv ts' (EnsembleInsert {| elementIndex := idx;
                                    indexedElement:= t |} ts).

Fixpoint allTuplesLen (len : nat) (ts : list (list W)) :=
  match ts with
  | nil => True
  | t :: ts' => length t = len /\ allTuplesLen len ts'
  end.

Definition Empty : tuples := fun _ => False.
Definition bounded (ts : tuples) := exists idx, UnConstrFreshIdx ts idx.
Definition minFreshIndex (ts : tuples) (idx : nat) :=
  UnConstrFreshIdx ts idx
  /\ forall idx', (idx' < idx)%nat -> ~UnConstrFreshIdx ts idx'.
Definition insertAt (ts : tuples) (idx : nat) (t : tupl) : tuples :=
  EnsembleInsert {| elementIndex := idx;
                    indexedElement:= t |} ts.
Definition keepEq (ts : tuples) (key k : W) : tuples :=
  fun tup => Ensembles.In _ ts tup /\ Array.sel (indexedElement tup) key = k.
Definition functional (ts : tuples) :=
  forall t1 t2, Ensembles.In _ ts t1 -> Ensembles.In _ ts t2
                -> elementIndex t1 = elementIndex t2 -> t1 = t2.


From Hammer Require Import Hammer.

Set Implicit Arguments.

Require Import List.
From QuicksortComplexity Require Import monads.
From QuicksortComplexity Require Import monoid_monad_trans.
From QuicksortComplexity Require qs_definitions.
Import qs_definitions.mon_nondet.
From QuicksortComplexity Require ne_tree_monad.
Require Import Plus.
From QuicksortComplexity Require Import monoid_tree_monad.
From QuicksortComplexity Require Import sort_order.

Section contents.

Variable X : E.

Definition M: Monad := MonoidMonadTrans.M NatAddMonoid ne_tree_monad.ext.

Definition cmp (x y : X) : M comparison :=
@ret ne_tree_monad.M _ (1%nat, sort_order.Ecmp X x y).

Definition pick := monoid_tree_monad.pick NatAddMonoid.

Lemma Mext: extMonad M.
Proof. hammer_hook "NDP" "NDP.Mext". exact (MonoidMonadTrans.Mext NatAddMonoid ne_tree_monad.ext). Qed.

Lemma partition d l: partition M cmp d l = ne_tree.Leaf (length l, qs_definitions.simplerPartition X d l).
Proof with auto. hammer_hook "NDP" "NDP.partition".
induction l...
simpl.
rewrite (@mon_assoc (ne_tree_monad.M)).
rewrite IHl.
simpl.
rewrite plus_0_r...
Qed.

Definition qs := qs cmp pick.

End contents.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults64.
Local Open Scope Z_scope.

Local Existing Instances default_parameters default_parameters_ok.
Local Definition m := 2^256 - 2^224 + 2^192 + 2^96 - 1.
Local Definition prefix := "p256_"%string. (* placed before function names *)

Instance names : names_of_operations.
Proof.  make_names_of_operations prefix. Defined.

Definition ops : wbwmontgomery_reified_ops m.
Proof.  make_reified_ops. Time Defined.

Instance p256_bedrock2_funcs : bedrock2_wbwmontgomery_funcs.
Proof. funcs_from_ops ops. Defined.

Instance p256_bedrock2_specs : bedrock2_wbwmontgomery_specs.
Proof. specs_from_ops ops m. Defined.

Instance p256_bedrock2_correctness : bedrock2_wbwmontgomery_correctness.
Proof. prove_correctness ops m. Qed.

(*
Require Import bedrock2.NotationsCustomEntry.
Require Import bedrock2.NotationsInConstr.
Require Import bedrock2.Syntax.
Local Open Scope bedrock_expr.
Coercion expr.var : string >-> Syntax.expr.
Eval cbv [add p256_bedrock2_funcs] in add.
Eval cbv [spec_of_add p256_bedrock2_specs] in spec_of_add.
*)


Set Implicit Arguments.

Section MonadClass.

  Class Monad (M: Type -> Type) :=
    {
      ret : forall A, A -> M A;
      bind : forall A B, M A -> (A -> M B) -> M B;
      left_unit : forall A B (x0: A) (f: A -> M B),
                    bind (ret x0) f = f x0;
      right_unit : forall A (ma: M A), bind ma (@ret A) = ma;
      bind_assoc: forall A B C (ma : M A) (f: A -> M B) (g: B -> M C),
                    bind ma (fun y => bind (f y) g) = bind (bind ma f) g
    }.

  Definition join (M: Type -> Type) `(Monad M) A (mmx : M (M A)) : M A := bind _ mmx (fun x => x).

  Global Arguments join [_] [_] [_].

End MonadClass.

Section FunctorClass.

  Class Functor (F: Type -> Type) :=
    {
      fmap : forall A B, (A -> B) -> F A -> F B;
      fmap_id : forall A (fx : F A), fmap (fun x => x) fx = fx;
      fmap_comp : forall A B C (f : B -> C) (g : A -> B) (fx : F A),
          fmap f (fmap g fx) = fmap (fun x => f (g x)) fx
    }.

End FunctorClass.


Require Import Syntax.
Require Import IL.

Set Implicit Arguments.

Inductive args_not_too_long : Stmt -> Prop :=
  | CallCase : forall x f args, goodSize (2 + length args) -> args_not_too_long (Call x f args)
  | SkipCase : args_not_too_long Skip
  | SeqCase : forall a b, args_not_too_long a -> args_not_too_long b -> args_not_too_long (Seq a b)
  | IfCase : forall e t f, args_not_too_long t -> args_not_too_long f -> args_not_too_long (If e t f)
  | WhileCase : forall e s, args_not_too_long s -> args_not_too_long (While e s)
  | LabelCase : forall x l, args_not_too_long (Label x l)
  | AssignCase : forall x e, args_not_too_long (Syntax.Assign x e).

Definition wellformed := args_not_too_long.


From Coq Require Import Basics.

From Coinduction Require Import
     coinduction rel tactics.

From ITree Require Import Core.Subevent.
From CTree Require Import
     CTree Eq.Equ Eq.Trans Eq.SBisim Eq.SSim.

(*|
Execution traces defined as colists and trace equivalence.
|*)

CoInductive trace {E} :=
| Cons (l : @label E) (s : trace)
| Nil.

Program Definition htr {E X} :
  mon (@trace E -> ctree E X -> Prop) :=
  {| body R s t :=
    match s with
    | Cons l s' => exists t', trans l t t' /\ R s' t'
    | Nil => True
    end
  |}.
Next Obligation.
  destruct a. destruct H0 as (? & ? & ?). eauto. apply I.
Defined.

Definition has_trace {E X} := gfp (@htr E X).

Definition tracincl {E X}
  (t t' : ctree E X) :=
  forall s, has_trace s t -> has_trace s t'.
Definition traceq {E X}
  (t t' : ctree E X) :=
  tracincl t t' /\ tracincl t' t.

(*|
Instances
|*)

#[global] Instance traceq_equ : forall {E X} s,
  Proper (equ eq ==> impl) (@has_trace E X s).
Proof.
  cbn. intros. step. destruct s; auto.
  step in H0. cbn in H0. destruct H0 as (? & ? & ?).
  rewrite H in H0. exists x0. auto.
Qed.

(*|
Tactics
|*)

Tactic Notation "__trace_play" "using" tactic(tac) :=
  eexists; rewrite ctree_eta;
  cbn; split; [now tac | auto].

Tactic Notation "__trace_play" := __trace_play using etrans.

Tactic Notation "__trace_play" "in" hyp(H) :=
  step in H; cbn in H;
  destruct H as (? & TR & H);
  rewrite ctree_eta in TR; cbn in TR;
  inv_trans; subst.

(*|
Trace inclusion is weaker than similarity,
and trace equivalence is weaker than bisimilarity.
|*)

Lemma ssim_tracincl : forall {E X} (t t' : ctree E X),
  ssim t t' -> tracincl t t'.
Proof.
  red. red. intros. revert t t' H s H0. coinduction R CH. intros.
  simpl. destruct s; auto.
  step in H0. cbn in H0. destruct H0 as (? & ? & ?).
  step in H. apply H in H0. destruct H0 as [? ? ?].
  exists x0. split. apply H0. eapply CH. apply H2. red. apply H1.
Qed.

Lemma sbisim_traceq : forall {E X} (t t' : ctree E X),
  sbisim t t' -> traceq t t'.
Proof.
  intros. split; apply ssim_tracincl; now apply sbisim_ssim.
Qed.


From FOL Require Import ND.
From FOL Require Import GenTarski.

(** ** Constructive Analysis *)

Definition stable P := ~ ~ P -> P.

Lemma stable_equiv P Q :
  P <-> Q -> stable P -> stable Q.
Proof.
  firstorder.
Qed.

Definition stab_class := forall Sigma, @theory Sigma -> Prop.
Definition map_closed (S : stab_class) {Sig Sig'} (f : @form Sig -> @form Sig') := forall T, S Sig T -> S Sig' (tmap f T).

Definition ST (S : stab_class) := forall Sigma T phi, closed_T T -> closed phi -> S Sigma T -> stable (T ⊩CE phi).

Section PropT.
  Definition dummy_sig : Signature := {| Funcs := False; Preds := False; pred_ar := @except nat ; fun_ar := @except nat |}.

  Definition prop_T (P : Prop) := fun phi : @form dummy_sig => phi = ⊥ /\ P.

  Lemma prop_T_correct P :
    prop_T P ⊩CE ⊥ <-> P.
  Proof.
    split.
    - intros ([ | x] & HA1 & HA2). 1: contradiction (Consistency HA2).
      destruct (HA1 x (or_introl eq_refl)). firstorder.
    - exists [⊥]; split. 2: ctx. now intros ? [<- | []].
  Qed.

  Global Instance False_enumT : enumT False.
  Proof.
    exists (fun _ => []). 1: auto. intros [].
  Qed.
End PropT.

Section StabilityClasses.
  (* **** Double Negation Elimination *)

  Section DN.
    Definition DN := forall P, stable P.

    Definition any_T : stab_class := fun Σ _ => exists (HdF : eq_dec Funcs) (HdP : eq_dec Preds)
                                                (HeF : enumT Funcs) (HeP : enumT Preds), True.

    Definition ST__a := ST any_T.

    Lemma any_T_map_closed {Sig Sig' : Signature} {HdF : eq_dec Funcs} {HdP : eq_dec Preds} {HeF : enumT Funcs} {HeP : enumT Preds} (f : @form Sig -> @form Sig') :
      map_closed any_T f.
    Proof.
      intros ? _.
      now exists HdF, HdP, HeF, HeP.
    Qed.

    Lemma dn_to_sta :
      DN -> ST__a.
    Proof.
      intros dn Sig T phi _ clT clphi. apply dn.
    Qed.

    Lemma sta_to_dn :
      ST__a -> DN.
    Proof.
      intros sta P. eapply stable_equiv. 1: apply (prop_T_correct P). apply sta.
      - intros phi n [-> H]. econstructor.
      - econstructor.
      - exists _. eexists. intros []. cbn.
        exists False_enumT, False_enumT. econstructor.
    Qed.
  End DN.

  (* **** Synthetic Markov's Principle *)

  Section SyntMP.
    Definition tsat (f : nat -> bool) := exists n, f n = true.
    Definition MP := forall f : nat -> bool, stable (tsat f).

    Definition enum_T : stab_class := fun _ T => exists (HdF : eq_dec Funcs) (HdP : eq_dec Preds)
                                                (HeF : enumT Funcs) (HeP : enumT Preds) L, enum T L.
    Definition ST__e := ST enum_T.

    Lemma enum_T_map_closed_closing {Sig : Signature} :
      @map_closed enum_T Sig (sig_ext Sig) (fun phi => (sig_lift phi)[ext_c]).
    Proof.
      intros T (? & ? & ? & ? & L & He). exists (dec_sig_ext_Funcs _), (dec_sig_ext_Preds _).
      exists (enumT_sig_ext_Funcs _), (enumT_sig_ext_Preds _), (L >> map (fun phi => (sig_lift phi)[ext_c])).
      now apply enum_tmap.
    Qed.

    Lemma enum_T_map_closed_homo {Sig : Signature} (f : @form Sig -> @form Sig) :
      map_closed enum_T f.
    Proof.
      intros T (HdF' & HdP' & HeF' & HeP' & L & He). exists HdF', HdP', HeF', HeP', (L >> map f).
      now apply enum_tmap.
    Qed.

    Section MPEnum.
      Hypothesis mp : MP.
      Variable (X : Type) (L : nat -> list X) (P : X -> Prop).
      Hypothesis (HL : enum P L) (HX : eq_dec X).

      Lemma enumeration_semi_decidable x :
        exists (f : nat -> bool), P x <-> tsat f.
      Proof.
        destruct HL as [_ H]. exists (fun n => if list_in_dec x (L n) HX then true else false).
        split.
        - intros [m ?] % H. exists m. now destruct (list_in_dec x (L m) HX).
        - intros [m Hm]. destruct (list_in_dec x (L m) HX) in Hm. 2: discriminate. firstorder.
      Qed.

      Lemma enumeration_stability x :
        stable (P x).
      Proof.
        intros Hn. destruct (enumeration_semi_decidable x) as [f Hf].
        apply Hf. apply mp. intros Hf'. apply Hn. intros [m Hm] % Hf. apply Hf'. now exists m.
      Qed.
    End MPEnum.

    Lemma mp_to_ste :
      MP -> ST__e.
    Proof.
      intros mp Sig T phi clT clphi (? & ? & ? & ? & L & He).  apply (enumeration_stability mp (enum_tprv He) (dec_form _ _)).
    Qed.

    Fixpoint L_tsat_T (f : nat -> bool) (n : nat) : list (@form dummy_sig) :=
      match n with
      | 0 => []
      | S n => L_tsat_T f n ++ if f n then [⊥] else []
      end.

    Lemma enum_tsat_T (f : nat -> bool) :
      enum (prop_T (tsat f)) (L_tsat_T f).
    Proof.
      split. 1: eauto. split.
      - intros [-> [n H]]. exists (S n). cbn. rewrite H. now in_app 2.
      - intros [n]. induction n in x, H |-*; cbn in *. 1: contradiction. inv_collect.
        destruct (f n) eqn:Hf.
        + destruct H as [<- | []]. firstorder.
        + contradiction.
    Qed.

    Lemma ste_to_mp :
      ST__e -> MP.
    Proof.
      intros ste f. eapply stable_equiv. 1: apply prop_T_correct.
      apply ste.
      - intros phi n [-> H]. econstructor.
      - econstructor.
      - unshelve eexists _, _, _, _, (L_tsat_T f); try exact _. apply (enum_tsat_T f).
    Qed.
  End SyntMP.

  (* **** Object Markov's Principle *)

  Section ObjMP.
    Definition fin_T : stab_class := fun Sig T => exists (HdF : eq_dec Funcs) (HdP : eq_dec Preds)
                                                (HeF : enumT Funcs) (HeP : enumT Preds) A, forall phi, phi ∈ T <-> phi el A.

    Definition ST__f := ST fin_T.

    Lemma fin_T_map_closed {Sig Sig'} {HdF : eq_dec Funcs} {HdP : eq_dec Preds} {HeF : enumT Funcs} {HeP : enumT Preds} (f : @form Sig -> @form Sig') :
      map_closed fin_T f.
    Proof.
      intros T (_ & _ & _ & _ & A & HA).
      exists HdF, HdP, HeF, HeP.
      exists (map f A). intros phi. split.
      - intros (psi & Hpsi1 % HA & <-). now apply in_map.
      - intros (psi & <- & Hpsi) % in_map_iff. firstorder.
    Qed.

    Section ConT.
      Context {Sigma : Signature}.
      Context {HdF : eq_dec Funcs} {HdP : eq_dec Preds} {HeF : enumT Funcs} {HeP : enumT Preds}.
      Context {p : peirce} {b : bottom}.

      Definition con_T A : theory := fun phi => phi el A.

      Lemma con_T_correct A phi :
         con_T A ⊩ phi <-> A ⊢ phi.
      Proof.
        firstorder. apply (Weak H0). firstorder.
      Qed.

      Lemma fin_T_con_T A :
        fin_T (con_T A).
      Proof.
        exists HdF, HdP, HeF, HeP.
        firstorder.
      Qed.
    End ConT.

    Lemma fin_T_to_context {Sig : Signature}  T phi :
      closed_T T -> fin_T T -> exists A, List.Forall closed A /\ (A ⊢CE phi <-> T ⊩CE phi).
    Proof.
      intros clT (_ & _ & _ & _ & A & HA). exists A. split; try split.
      - eapply Forall_forall. intros ? ? % HA n. now eapply clT.
      - intros; exists A; firstorder.
      - intros (B & HB1 & HB2). apply (Weak HB2). firstorder.
    Qed.

    Lemma stf_to_st_context :
      ST__f <-> (forall Sigma {HdF : eq_dec Funcs} {HdP : eq_dec Preds} {HeF : enumT Funcs} {HeP : enumT Preds} A (phi : @form Sigma), (List.Forall closed A) -> closed phi -> stable (A ⊢CE phi)).
    Proof.
      split.
      - intros stf HdF HdP HeF HeP Sig A phi clA clphi. eapply stable_equiv. 1: eapply con_T_correct.
        apply stf.
        + intros psi n Hpsi. eapply Forall_forall in clA. eapply clA. eassumption.
        + eassumption.
        + eapply fin_T_con_T.
      - intros stc Sig T phi clT clphi HT. destruct (fin_T_to_context phi clT HT) as [A [clA HA]].
        destruct HT as (HdF & HdP & HeF & HeP & HT).
        eapply stable_equiv. apply HA. apply stc; eauto.
    Qed.
  End ObjMP.
End StabilityClasses.


(**
Dependent product of diplayed bicategories.
If we have a type `J` and a family indexed by `J` of displayed bicategories on `J`,
then we can assemble this into a displayed bicategory whose objects are dependent functions.
*)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Univalence.

Local Open Scope cat.
Local Open Scope mor_disp.

Section DispDepprod.
  Context {B : bicat}
          (I : UU)
          (D : I → disp_bicat B).

  Definition disp_depprod_cat_ob_mor : disp_cat_ob_mor B.
  Proof.
    use tpair.
    - exact (λ x, ∏ (i : I), D i x).
    - exact (λ x y xx yy f, ∏ (i : I), xx i -->[ f ] yy i).
  Defined.

  Definition disp_depprod_cat_data : disp_cat_data B.
  Proof.
    use tpair.
    - exact disp_depprod_cat_ob_mor.
    - split.
      + exact (λ x xx i, id_disp (xx i)).
      + exact (λ x y z f g xx yy zz ff gg i, ff i;;gg i).
  Defined.

  Definition disp_depprod_disp_2cell_struct
    : disp_2cell_struct disp_depprod_cat_ob_mor
    := λ x y f g α xx yy ff gg, ∏ (i : I), ff i ==>[ α ] gg i.

  Definition disp_depprod_disp_prebicat_ops
    : disp_prebicat_ops (disp_depprod_cat_data,, disp_depprod_disp_2cell_struct).
  Proof.
    repeat split.
    - exact (λ a b f aa bb ff i, disp_id2 (ff i)).
    - exact (λ a b f aa bb ff i, disp_lunitor (ff i)).
    - exact (λ a b f aa bb ff i, disp_runitor (ff i)).
    - exact (λ a b f aa bb ff i, disp_linvunitor (ff i)).
    - exact (λ a b f aa bb ff i, disp_rinvunitor (ff i)).
    - exact (λ a b c d f g h aa bb cc dd ff gg hh i,
             disp_rassociator (ff i) (gg i) (hh i)).
    - exact (λ a b c d f g h aa bb cc dd ff gg hh i,
             disp_lassociator (ff i) (gg i) (hh i)).
    - exact (λ a b f g h x y aa bb ff gg hh xx yy i, xx i •• yy i).
    - exact (λ a b c f g1 g2 x aa bb cc ff gg1 gg2 xx i, ff i ◃◃ xx i).
    - exact (λ a b c f1 f2 g x aa bb cc ff1 ff2 gg xx i, xx i ▹▹ gg i).
  Defined.

  Definition disp_depprod_prebicat_data : disp_prebicat_data B.
  Proof.
    use tpair.
    - use tpair.
      + exact disp_depprod_cat_data.
      + exact disp_depprod_disp_2cell_struct.
    - exact disp_depprod_disp_prebicat_ops.
  Defined.

  Definition disp_depprod_prebicat_laws_help
             {a b : B}
             {f g : a --> b}
             {x y : f ==> g}
             {aa : ∏ (i : I), D i a} {bb : ∏ (i : I), D i b}
             {ff : ∏ (i : I), aa i -->[ f ] bb i}
             {gg : ∏ (i : I), aa i -->[ g ] bb i}
             (xx : ∏ (i : I), ff i ==>[ y ] gg i)
             (p : x = y)
             (i : I)
    : transportb (λ α : f ==> g, ff i ==>[ α ] gg i) p (xx i)
      =
      transportb (λ α : f ==> g, ∏ (i : I), ff i ==>[ α ] gg i) p xx i.
  Proof.
    induction p.
    apply idpath.
  Qed.

  Definition disp_depprod_prebicat_laws
    : disp_prebicat_laws disp_depprod_prebicat_data.
  Proof.
    repeat split
    ; intro ; intros
    ; use funextsec ; intro
    ; refine (_ @ disp_depprod_prebicat_laws_help _ _ _).
    - apply disp_id2_left.
    - apply disp_id2_right.
    - apply disp_vassocr.
    - apply disp_lwhisker_id2.
    - apply disp_id2_rwhisker.
    - apply disp_lwhisker_vcomp.
    - apply disp_rwhisker_vcomp.
    - apply disp_vcomp_lunitor.
    - apply disp_vcomp_runitor.
    - apply disp_lwhisker_lwhisker.
    - apply disp_rwhisker_lwhisker.
    - apply disp_rwhisker_rwhisker.
    - apply disp_vcomp_whisker.
    - apply disp_lunitor_linvunitor.
    - apply disp_linvunitor_lunitor.
    - apply disp_runitor_rinvunitor.
    - apply disp_rinvunitor_runitor.
    - apply disp_lassociator_rassociator.
    - apply disp_rassociator_lassociator.
    - apply disp_runitor_rwhisker.
    - apply disp_lassociator_lassociator.
  Qed.

  Definition disp_depprod_prebicat : disp_prebicat B.
  Proof.
    use tpair.
    - exact disp_depprod_prebicat_data.
    - exact disp_depprod_prebicat_laws.
  Defined.

  Definition disp_depprod_bicat : disp_bicat B.
  Proof.
    use tpair.
    - exact disp_depprod_prebicat.
    - intros a b f g x aa bb ff gg.
      use impred_isaset.
      intro i.
      apply (D i).
  Defined.

  Definition disp_2cells_isaprop_depprod
             (HD : ∏ (i : I), disp_2cells_isaprop (D i))
    : disp_2cells_isaprop disp_depprod_bicat.
  Proof.
    intro; intros.
    use impred.
    intro i.
    apply HD.
  Qed.

  Definition disp_depprod_bicat_disp_is_invertible_2cell_map
             {a b : B}
             {f g : B ⟦ a, b ⟧}
             {x : f ==> g}
             {xinv : is_invertible_2cell x}
             {aa : disp_depprod_bicat a}
             {bb : disp_depprod_bicat b}
             {ff : aa -->[ f] bb}
             {gg : aa -->[ g ] bb}
             (xx : ff ==>[ x ] gg)
             (Hx : ∏ (i : I), is_disp_invertible_2cell xinv (xx i))
    : is_disp_invertible_2cell xinv xx.
  Proof.
    use tpair.
    - exact (λ i, pr1 (Hx i)).
    - split.
      + use funextsec.
        intro i.
        refine (_ @ disp_depprod_prebicat_laws_help _ _ _).
        exact (disp_vcomp_rinv ((xx i ,, Hx i) : disp_invertible_2cell (x ,, xinv) _ _)).
      + use funextsec.
        intro i.
        refine (_ @ disp_depprod_prebicat_laws_help _ _ _).
        exact (disp_vcomp_linv ((xx i ,, Hx i) : disp_invertible_2cell (x ,, xinv) _ _)).
  Defined.

  Definition disp_locally_groupoid_depprod
             (HD : ∏ (i : I), disp_locally_groupoid (D i))
    : disp_locally_groupoid disp_depprod_bicat.
  Proof.
    intros a b f g x aa bb ff gg xx.
    apply disp_depprod_bicat_disp_is_invertible_2cell_map.
    intro i.
    apply HD.
  Qed.

  Definition disp_depprod_bicat_disp_invertible_2cell_map
             {a b : B}
             {f : B ⟦ a, b ⟧}
             {aa : disp_depprod_bicat a}
             {bb : disp_depprod_bicat b}
             (ff : aa -->[ f] bb)
             (gg : aa -->[ f] bb)
    : (∏ (i : I), disp_invertible_2cell (id2_invertible_2cell f) (ff i) (gg i))
        →
        disp_invertible_2cell (id2_invertible_2cell f) ff gg.
  Proof.
    intros x.
    use tpair.
    - exact (λ i, x i).
    - apply disp_depprod_bicat_disp_is_invertible_2cell_map.
      exact (λ i, pr2 (x i)).
  Defined.

  Definition disp_depprod_bicat_disp_is_invertible_2cell_pr
             {a b : B}
             {f g : B ⟦ a, b ⟧}
             {x : f ==> g}
             {xinv : is_invertible_2cell x}
             {aa : disp_depprod_bicat a}
             {bb : disp_depprod_bicat b}
             {ff : aa -->[ f] bb}
             {gg : aa -->[ g ] bb}
             (xx : ff ==>[ x ] gg)
             (Hx : is_disp_invertible_2cell xinv xx)
    : ∏ (i : I), is_disp_invertible_2cell xinv (xx i).
  Proof.
    intro i.
    use tpair.
    - exact (pr1 Hx i).
    - split.
      + refine (_ @ !(disp_depprod_prebicat_laws_help (disp_id2 ff) _ _)).
        exact (eqtohomot (disp_vcomp_rinv
                            ((xx ,, Hx) : disp_invertible_2cell (x ,, xinv) _ _)) i).
      + refine (_ @ !(disp_depprod_prebicat_laws_help (disp_id2 gg) _ _)).
        exact (eqtohomot (disp_vcomp_linv
                            ((xx ,, Hx) : disp_invertible_2cell (x ,, xinv) _ _)) i).
  Defined.

  Definition disp_depprod_bicat_disp_invertible_2cell_inv_map
             {a b : B}
             {f : B ⟦ a, b ⟧}
             {aa : disp_depprod_bicat a}
             {bb : disp_depprod_bicat b}
             (ff : aa -->[ f] bb)
             (gg : aa -->[ f] bb)
    : disp_invertible_2cell (id2_invertible_2cell f) ff gg
      →
      (∏ (i : I), disp_invertible_2cell (id2_invertible_2cell f) (ff i) (gg i)).
  Proof.
    intros x i.
    use tpair.
    - exact (pr1 x i).
    - exact (disp_depprod_bicat_disp_is_invertible_2cell_pr _ (pr2 x) i).
  Defined.

  Definition disp_depprod_bicat_disp_invertible_2cell_weq
             {a b : B}
             {f : B ⟦ a, b ⟧}
             {aa : disp_depprod_bicat a}
             {bb : disp_depprod_bicat b}
             (ff : aa -->[ f] bb)
             (gg : aa -->[ f] bb)
    : (∏ (i : I), disp_invertible_2cell (id2_invertible_2cell f) (ff i) (gg i))
        ≃
        disp_invertible_2cell (id2_invertible_2cell f) ff gg.
  Proof.
    use make_weq.
    - exact (disp_depprod_bicat_disp_invertible_2cell_map ff gg).
    - use isweq_iso.
      + exact (disp_depprod_bicat_disp_invertible_2cell_inv_map ff gg).
      + intros x.
        use funextsec.
        intro i.
        use subtypePath.
        { intro ; apply isaprop_is_disp_invertible_2cell. }
        apply idpath.
      + intros x.
        use subtypePath.
        { intro ; apply isaprop_is_disp_invertible_2cell. }
        apply idpath.
  Defined.

  Section DepProdBicatDispLocallyUnivalent.
    Variable (HD_2_1 : ∏ (i : I), disp_univalent_2_1 (D i)).

    Definition disp_depprod_bicat_idtotiso_2_1
               {a b : B}
               {f : B ⟦ a, b ⟧}
               {aa : disp_depprod_bicat a}
               {bb : disp_depprod_bicat b}
               (ff : aa -->[ f] bb)
               (gg : aa -->[ f] bb)
      : ff = gg ≃ disp_invertible_2cell (id2_invertible_2cell f) ff gg
      := ((disp_depprod_bicat_disp_invertible_2cell_weq ff gg)
            ∘ weqonsecfibers
            _ _ (λ i, make_weq _ (HD_2_1 i _ _ _ _ (idpath _) _ _ (ff i) (gg i)))
            ∘ invweq (weqfunextsec _ _ _))%weq.

    Definition disp_depprod_univalent_2_1
      : disp_univalent_2_1 disp_depprod_bicat.
    Proof.
      apply fiberwise_local_univalent_is_univalent_2_1.
      intros a b f aa bb ff gg.
      use weqhomot.
      - exact (disp_depprod_bicat_idtotiso_2_1 ff gg).
      - intros p.
        induction p.
        use subtypePath.
        { intro ; apply isaprop_is_disp_invertible_2cell. }
        apply idpath.
    Defined.
  End DepProdBicatDispLocallyUnivalent.

  Definition disp_depprod_bicat_disp_adjequiv_map
             {a : B}
             (aa bb : disp_depprod_bicat a)
    : (∏ (i : I), disp_adjoint_equivalence
                    (internal_adjoint_equivalence_identity a)
                    (aa i) (bb i))
      → disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) aa bb.
  Proof.
    intros f.
    use tpair.
    - exact (λ i, f i).
    - use tpair.
      + use tpair.
        * exact (λ i, disp_left_adjoint_right_adjoint _ (f i)).
        * split.
          ** exact (λ i, disp_left_adjoint_unit _ (f i)).
          ** exact (λ i, disp_left_adjoint_counit _ (f i)).
      + split.
        * split.
          ** abstract
               (use funextsec ;
                intro i ;
                refine (pr1 (pr122 (f i)) @ _) ;
                refine ((disp_depprod_prebicat_laws_help _ _ _))).
          ** abstract
               (use funextsec ;
                intro i ;
                refine (pr2 (pr122 (f i)) @ _) ;
                refine ((disp_depprod_prebicat_laws_help _ _ _))).
        * split.
          ** apply disp_depprod_bicat_disp_is_invertible_2cell_map.
             exact (λ i, pr1 (pr222 (f i))).
          ** apply disp_depprod_bicat_disp_is_invertible_2cell_map.
             exact (λ i, pr2 (pr222 (f i))).
  Defined.

  Definition disp_depprod_bicat_disp_adjequiv_inv
             {a : B}
             (aa bb : disp_depprod_bicat a)
    : disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) aa bb
      → (∏ (i : I), disp_adjoint_equivalence
                    (internal_adjoint_equivalence_identity a)
                    (aa i) (bb i)).
  Proof.
    intros f i.
    use tpair.
    - exact (pr1 f i).
    - use tpair.
      + use tpair.
        * exact (disp_left_adjoint_right_adjoint _ f i).
        * split.
          ** exact (disp_left_adjoint_unit _ f i).
          ** exact (disp_left_adjoint_counit _ f i).
      + split.
        * split.
          ** abstract
               (refine (eqtohomot (pr1 (pr122 f)) i @ _) ;
                refine (!(disp_depprod_prebicat_laws_help _ _ _))).
          ** abstract
               (refine (eqtohomot (pr2 (pr122 f)) i @ _) ;
                refine (!(disp_depprod_prebicat_laws_help _ _ _))).
        * split.
          ** exact (disp_depprod_bicat_disp_is_invertible_2cell_pr
                      _ (pr1 (pr222 f)) i).
          ** exact (disp_depprod_bicat_disp_is_invertible_2cell_pr
                      _ (pr2 (pr222 f)) i).
  Defined.

  Variable (HB : is_univalent_2_1 B)
           (HD_2_1 : ∏ (i : I), disp_univalent_2_1 (D i)).

  Definition disp_depprod_bicat_disp_adjequiv_weq
             {a : B}
             (aa bb : disp_depprod_bicat a)
    : (∏ x : I, disp_adjoint_equivalence
                  (internal_adjoint_equivalence_identity a)
                  (aa x) (bb x))
        ≃ disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) aa bb.
  Proof.
    use make_weq.
    - exact (disp_depprod_bicat_disp_adjequiv_map aa bb).
    - use isweq_iso.
      + exact (disp_depprod_bicat_disp_adjequiv_inv aa bb).
      + intros f.
        use funextsec.
        intros i.
        use subtypePath.
        { intro ; apply isaprop_disp_left_adjoint_equivalence
          ; [ exact HB | exact (HD_2_1 i) ].
        }
        apply idpath.
      + intros f.
        use subtypePath.
        { intro ; apply isaprop_disp_left_adjoint_equivalence
          ; [ exact HB | exact (disp_depprod_univalent_2_1 HD_2_1) ].
        }
        apply idpath.
  Defined.

  Section DepProdBicatDispGloballyUnivalent.
    Variable (HD_2_0 : ∏ (i : I), disp_univalent_2_0 (D i)).

    Definition disp_depprod_bicat_idtotiso_2_0
               {a : B}
               (aa bb : disp_depprod_bicat a)
      : (aa = bb)
          ≃
          disp_adjoint_equivalence (internal_adjoint_equivalence_identity a) aa bb
      := ((disp_depprod_bicat_disp_adjequiv_weq aa bb)
            ∘ weqonsecfibers
              _ _ (λ i, make_weq _ (HD_2_0 i _ _ (idpath a) _ _))
            ∘ invweq (weqfunextsec _ _ _))%weq.

    Definition disp_depprod_univalent_2_0
      : disp_univalent_2_0 disp_depprod_bicat.
    Proof.
      apply fiberwise_univalent_2_0_to_disp_univalent_2_0.
      intros a aa bb.
      use weqhomot.
      - exact (disp_depprod_bicat_idtotiso_2_0 aa bb).
      - intros p.
        induction p.
        use subtypePath.
        { intro ; apply isaprop_disp_left_adjoint_equivalence
          ; [ exact HB | exact (disp_depprod_univalent_2_1 HD_2_1) ].
        }
        apply idpath.
    Defined.
  End DepProdBicatDispGloballyUnivalent.
End DispDepprod.