Require Export BoilerplateFunctions.

(******************************************************************************)
(* Lemmas.                                                                    *)
(******************************************************************************)

Create HintDb interaction.
Ltac isimpl := simpl; intros; autorewrite with interaction; simpl.

Ltac specialize_suc :=
  progress
    match goal with
      | [ H : forall _ : nat, _, k : nat |- _ ] => apply (H (S k))
    end.
Ltac var_case :=
  match goal with
    | [ |- forall v i, _ ] =>
      induction v; simpl; intros; destruct i; auto; isimpl;
      try apply (f_equal (tshiftTy 0)) with (y := tvar _);
      try congruence; auto
  end.
Ltac ty_case T v :=
  induction T; simpl; intros;
  try solve [ try apply f_equal with (f := tvar); apply v
            | apply f_equal2 with (f := tarr); trivial
            | apply f_equal with (f := tall); specialize_suc; trivial
            | apply f_equal2 with (f := tprod); trivial
            ].

Lemma lengthExt_tshiftExt (c : nat) (Δ : Ext) :
  lengthExt (tshiftExt c Δ) = lengthExt Δ.
Proof.
  induction Δ; simpl; f_equal; auto.
Qed.
Hint Rewrite lengthExt_tshiftExt : interaction.

Lemma lengthExt_tsubstExt (X : nat) (T' : Ty) (Δ : Ext) :
  lengthExt (tsubstExt X T' Δ) = lengthExt Δ.
Proof.
  induction Δ; simpl; f_equal; auto.
Qed.
Hint Rewrite lengthExt_tsubstExt : interaction.

Lemma shiftIndex_comm_ind :
  forall v i c,
    shiftIndex (v + S c) (shiftIndex (v + O) i) =
    shiftIndex (v + O  ) (shiftIndex (v + c) i).
Proof.
  var_case.
Qed.

Lemma tshiftTy_comm_ind (T : Ty) :
  forall v c,
    tshiftTy (v + S c) (tshiftTy (v + O) T) =
    tshiftTy (v + O  ) (tshiftTy (v + c) T).
Proof.
  ty_case T shiftIndex_comm_ind.
Qed.

Lemma tshiftTy_comm (c : nat) (T : Ty) :
    tshiftTy (S c) (tshiftTy O T)
  = tshiftTy O     (tshiftTy c T).
Proof.
  apply (tshiftTy_comm_ind _ 0).
Qed.
Hint Rewrite tshiftTy_comm : interaction.

Lemma tsubstIndex_shiftIndex_reflection_ind :
  forall (k X : nat) (T : Ty),
    tsubstIndex (k + 0) T (shiftIndex (k + O) X) = tvar X.
Proof.
  var_case.
Qed.

Lemma tsubstTy_tshiftTy_reflection_ind (T : Ty) :
  forall k T',
    tsubstTy (k + 0) T' (tshiftTy (k + O) T) = T.
Proof.
  ty_case T tsubstIndex_shiftIndex_reflection_ind.
Qed.

Lemma tsubstTy_tshiftTy_reflection (T' T : Ty) :
  tsubstTy 0 T' (tshiftTy O T) = T.
Proof.
  apply (tsubstTy_tshiftTy_reflection_ind _ 0).
Qed.
Hint Rewrite tsubstTy_tshiftTy_reflection : interaction.

Lemma tshiftTy_tsubstIndex_comm_ind :
  forall (k X c : nat) (T : Ty),
    tshiftTy (k + c) (tsubstIndex (k + 0) T X) =
    tsubstIndex (k + 0) (tshiftTy c T) (shiftIndex (k + S c) X).
Proof.
  var_case.
Qed.

Lemma tshiftTy_tsubstTy_comm_ind (T : Ty):
  forall (k c : nat) (T' : Ty),
    tshiftTy (k + c) (tsubstTy (k + 0) T' T) =
    tsubstTy (k + 0) (tshiftTy c T') (tshiftTy (k + S c) T).
Proof.
  ty_case T tshiftTy_tsubstIndex_comm_ind.
Qed.

Lemma tshiftTy_tsubstTy_comm c (T T2 : Ty) :
    tshiftTy c (tsubstTy O T T2)
  = tsubstTy O (tshiftTy c T) (tshiftTy (S c) T2).
Proof.
  apply (tshiftTy_tsubstTy_comm_ind _ 0).
Qed.
Hint Rewrite tshiftTy_tsubstTy_comm : interaction.

Lemma tsubstIndex_shiftIndex_comm_ind :
  forall k Y X T',
    tsubstIndex (k + S X) T' (shiftIndex (k + 0) Y) =
    tshiftTy (k + 0) (tsubstIndex (k + X) T' Y).
Proof.
  var_case.
Qed.

Lemma tsubstTy_tshiftTy_comm_ind (T : Ty) :
  forall k X T',
    tsubstTy (k + S X) T' (tshiftTy (k + 0) T) =
    tshiftTy (k + 0) (tsubstTy (k + X) T' T).
Proof.
  ty_case T tsubstIndex_shiftIndex_comm_ind.
Qed.

Lemma tsubstTy_tshiftTy_comm :
  forall X T' T,
    tsubstTy (S X) T' (tshiftTy 0 T) =
    tshiftTy 0 (tsubstTy X T' T).
Proof.
  intros; apply (tsubstTy_tshiftTy_comm_ind _ 0).
Qed.
Hint Rewrite tsubstTy_tshiftTy_comm : interaction.

Lemma tsubstTy_tsubstIndex_comm_ind :
  forall k Y T1 T2 X,
    tsubstTy (k + X) T1 (tsubstIndex (k + 0) T2 Y) =
    tsubstTy (k + 0) (tsubstTy X T1 T2) (tsubstIndex (k + S X) T1 Y).
Proof.
  var_case.
Qed.

Lemma tsubstTy_tsubstTy_comm_ind (T : Ty) :
  forall k X T1 T2,
    tsubstTy (k + X) T1 (tsubstTy (k + 0) T2 T) =
    tsubstTy (k + 0) (tsubstTy X T1 T2) (tsubstTy (k + (S X)) T1 T).
Proof.
  ty_case T tsubstTy_tsubstIndex_comm_ind.
Qed.

Lemma tsubstTy_tsubstTy_comm :
  forall X T1 T2 T,
    tsubstTy X T1 (tsubstTy 0 T2 T) =
    tsubstTy 0 (tsubstTy X T1 T2) (tsubstTy (S X) T1 T).
Proof.
  intros; apply (tsubstTy_tsubstTy_comm_ind _ 0).
Qed.
Hint Rewrite tsubstTy_tsubstTy_comm : interaction.

(******************************************************************************)
(* Interaction between term substitutions and typevar shifting.               *)
(******************************************************************************)

(*
Lemma shiftTm_tshiftTm_comm (t : Tm) :
  ∀ ca cb,
    shiftTm  cb (tshiftTm ca t) =
    tshiftTm ca (shiftTm  cb t).
Proof.
  induction t; simpl; intros; f_equal; trivial.
Qed.
*)

(******************************************************************************)
(* Context extension                                                          *)
(******************************************************************************)

Lemma extend_append (Γ : Env) (Δ1 Δ2 : Ext) :
  extend Γ (append Δ1 Δ2) = extend (extend Γ Δ1) Δ2.
Proof.
  induction Δ2; simpl; f_equal; auto.
Qed.

Lemma lengthExt_append (Δ1 Δ2 : Ext) :
  lengthExt (append Δ1 Δ2) = lengthExt Δ2 + lengthExt Δ1.
Proof.
  induction Δ2; simpl; auto.
Qed.

Lemma tshiftExt_append (c : nat) (Δ1 Δ2 : Ext) :
  tshiftExt c (append Δ1 Δ2) = append (tshiftExt c Δ1) (tshiftExt c Δ2).
Proof.
  induction Δ2; simpl; f_equal; auto.
Qed.
Hint Rewrite tshiftExt_append : interaction.

Lemma tsubstExt_append (X : nat) (S : Ty) (Δ1 Δ2 : Ext) :
  tsubstExt X S (append Δ1 Δ2) = append (tsubstExt X S Δ1) (tsubstExt X S Δ2).
Proof.
  induction Δ2; simpl; f_equal; auto.
Qed.
Hint Rewrite tsubstExt_append : interaction.

(******************************************************************************)
(* Context insertions.                                                        *)
(******************************************************************************)

Inductive shift_etvar : nat → Env → Env → Prop :=
  | shift_etvar_here {Γ} :
      shift_etvar 0 Γ (etvar Γ)
  | shift_etvar_there_evar {Γ1 Γ2 c T} :
      shift_etvar c Γ1 Γ2 →
      shift_etvar c (evar Γ1 T) (evar Γ2 (tshiftTy c T))
  | shift_etvar_there_etvar {Γ1 Γ2 c} :
      shift_etvar c Γ1 Γ2 →
      shift_etvar (S c) (etvar Γ1) (etvar Γ2).
Hint Constructors shift_etvar.

Lemma weaken_shift_etvar {Γ1 : Env} {Γ2 : Env} {Δ : Ext} {c} :
  shift_etvar c Γ1 Γ2 →
  shift_etvar c (extend Γ1 Δ) (extend Γ2 (tshiftExt c Δ)).
Proof.
  revert c Γ2; induction Δ; simpl; intros; try constructor; auto.
Qed.
Hint Resolve weaken_shift_etvar.

Inductive shift_evar : nat → Env → Env → Prop :=
  | shift_evar_here {Γ T} :
      shift_evar 0 Γ (evar Γ T)
  | shift_evar_there_evar {Γ1 Γ2 c T} :
      shift_evar c Γ1 Γ2 →
      shift_evar (S c) (evar Γ1 T) (evar Γ2 T)
  | shift_evar_there_etvar {Γ1 Γ2 c} :
      shift_evar c Γ1 Γ2 →
      shift_evar c (etvar Γ1) (etvar Γ2).
Hint Constructors shift_evar.

Lemma weaken_shift_evar {Γ1 : Env} {Γ2 : Env} (Δ : Ext) {c} :
  shift_evar c Γ1 Γ2 →
  shift_evar (lengthExt Δ + c) (extend Γ1 Δ) (extend Γ2 Δ).
Proof.
  revert c Γ2; induction Δ; simpl; intros; try constructor; auto.
Qed.
Hint Resolve weaken_shift_evar.

(******************************************************************************)
(* Lemmas about shifting and context lookups.                                 *)
(******************************************************************************)

Lemma shift_etvar_lookup_etvar {Γ1 Γ2 c} (ib : shift_etvar c Γ1 Γ2) :
  ∀ X, lookup_etvar Γ1 X → lookup_etvar Γ2 (shiftIndex c X).
Proof.
  induction ib; inversion 1; isimpl; eauto.
Qed.
Hint Resolve shift_etvar_lookup_etvar.

Lemma shift_etvar_lookup_evar {Γ1 Γ2 c} (ib : shift_etvar c Γ1 Γ2) :
  ∀ x T, lookup_evar Γ1 x T → lookup_evar Γ2 x (tshiftTy c T).
Proof.
  induction ib; inversion 1; isimpl; eauto.
Qed.
Hint Resolve shift_etvar_lookup_evar.

Lemma shift_evar_lookup_etvar {Γ1 Γ2 c} (iv : shift_evar c Γ1 Γ2) :
  ∀ X, lookup_etvar Γ1 X → lookup_etvar Γ2 X.
Proof.
  induction iv; inversion 1; subst; simpl; eauto.
Qed.
Hint Resolve shift_evar_lookup_etvar.

Lemma shift_evar_lookup_evar {Γ1 Γ2 c} (iv : shift_evar c Γ1 Γ2) :
  ∀ x T, lookup_evar Γ1 x T → lookup_evar Γ2 (shiftIndex c x) T.
Proof.
  induction iv; inversion 1; subst; simpl; eauto.
Qed.
Hint Resolve shift_evar_lookup_evar.

(******************************************************************************)
(* Weakening lemmas for well-formedness                                       *)
(******************************************************************************)

Lemma shift_etvar_wftyp {Γ1 T} (wfT: wfTy Γ1 T) :
  ∀ {c Γ2}, shift_etvar c Γ1 Γ2 → wfTy Γ2 (tshiftTy c T).
Proof.
  induction wfT; simpl; econstructor; eauto.
Qed.
Hint Resolve shift_etvar_wftyp.

Lemma shift_evar_wftyp {Γ1 T} (wfT: wfTy Γ1 T) :
  ∀ {c Γ2}, shift_evar c Γ1 Γ2 → wfTy Γ2 T.
Proof.
  induction wfT; simpl; econstructor; eauto.
Qed.
Hint Resolve shift_evar_wftyp.


From Hammer Require Import Hammer.

Set Implicit Arguments.

From QuicksortComplexity Require Import util.
Require Import Le.
Require Import Lt.
Require Import Rbase.
Require Import Plus.
Require Import Mult.
Require Import Arith.
Require Import Omega.
Require Import Div2.
Require Import Recdef.
Require Import Rbase.
Require Import Morphisms.

Definition ltb (x y: nat): bool := negb (leb y x).
Definition geb (x y: nat): bool := leb y x.

Ltac subst_tac x y z :=
match z with
| x => y
| ?l + ?r =>
let l' := subst_tac x y l in
let r' := subst_tac x y r in
constr: (l' + r')
| ?l * ?r =>
let l' := subst_tac x y l in
let r' := subst_tac x y r in
constr: (l' * r')
| _ => z
end.

Ltac deep_le_trans h :=
match type of h with
| ?n <= ?u =>
match goal with
| |- ?l <= _ =>
let q := subst_tac n u l
in apply le_trans with q
end
end.

Instance Transitive_le: Transitive le := le_trans.

Lemma minus_plus_same (y x: nat): x <= x - y + y.
Proof. hammer_hook "arith_lems" "arith_lems.minus_plus_same". intros. omega. Qed.

Lemma ltb_complete m n: ltb m n = true -> m < n.
Proof with auto. hammer_hook "arith_lems" "arith_lems.ltb_complete".
unfold ltb.
intros.
apply leb_complete_conv.
apply negb_inv...
Qed.

Lemma ltb_complete_conv m n: ltb m n = false -> n <= m.
Proof. hammer_hook "arith_lems" "arith_lems.ltb_complete_conv". unfold ltb. intros. apply leb_complete. apply negb_inv; auto. Qed.

Lemma lt_0_mult x y: 0 < x -> 0 < y -> 0 < x * y.
Proof with auto. hammer_hook "arith_lems" "arith_lems.lt_0_mult".
destruct x.
intros.
inversion H.
simpl.
intros.
apply lt_plus_trans...
Qed.

Lemma mult_ne_0 a b: (a <> 0 -> b <> 0 -> mult a b <> 0)%nat.
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.mult_ne_0".
destruct a... destruct b...
intros. simpl. discriminate.
Qed.

Lemma weak_lt_S_n n m: S n < m -> n < m.
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.weak_lt_S_n".
intros.
apply lt_S_n.
apply lt_trans with m...
Qed.

Lemma le_exists_plus (x y: nat) (p: x <= y): exists d, y = x + d.
Proof with auto. hammer_hook "arith_lems" "arith_lems.le_exists_plus".
induction p.
exists 0...
destruct IHp.
exists (S x0).
subst...
Qed.

Lemma lt_exists_plus (x y: nat) (p: x < y): exists d, y = S (x + d).
Proof. hammer_hook "arith_lems" "arith_lems.lt_exists_plus".
unfold lt in p.
destruct (le_exists_plus p).
exists x0.
assumption.
Qed.

Lemma n_lt_n_plus_Sm n m: n < n + S m.
Proof. hammer_hook "arith_lems" "arith_lems.n_lt_n_plus_Sm". intros. omega. Qed.

Lemma ne_le_impl_lt x y: x <> y -> x <= y -> x < y.
Proof. hammer_hook "arith_lems" "arith_lems.ne_le_impl_lt". auto with *. Qed.

Hint Rewrite plus_0_r : arith_norm.
Hint Rewrite mult_plus_distr_r mult_plus_distr_l plus_assoc : arith_norm.

Lemma beq_nat_false x y: x <> y -> beq_nat x y = false.
Proof with auto. hammer_hook "arith_lems" "arith_lems.beq_nat_false".
intros.
case_eq (beq_nat x y)...
intros.
elimtype False.
apply H.
apply beq_nat_eq...
Qed.

Lemma minus_lt_compat_l x y z: (y <= x -> z < y -> x - y < x - z)%nat.
Proof with auto. hammer_hook "arith_lems" "arith_lems.minus_lt_compat_l".
intros.
omega.
Qed.

Lemma minus_eq_inv_r d x y: (x <= d -> y <= d -> (d - x = d - y) -> x = y)%nat.
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.minus_eq_inv_r".
revert x y.
induction d.
simpl.
intros.
destruct x...
inversion H.
simpl.
intros.
destruct x.
destruct y...
elimtype False.
apply le_Sn_n with d...
rewrite H1.
apply le_minus.
destruct y.
elimtype False.
apply le_Sn_n with d.
rewrite <- H1.
apply le_minus.
apply eq_S.
apply IHd...
Qed.

Lemma le_ne_lt x y: x <= y -> x <> y -> x < y.
Proof. hammer_hook "arith_lems" "arith_lems.le_ne_lt". intros. omega. Qed.

Lemma ne_nlt_lt x y: x <> y -> ~ x < y -> y < x.
Proof with auto. hammer_hook "arith_lems" "arith_lems.ne_nlt_lt".
intros.
destruct (le_gt_dec x y)...
destruct (le_lt_eq_dec _ _ l)...
elimtype False...
elimtype False...
Qed.

Lemma lt_not_eq x y: (x < y -> x <> y)%nat.
Proof. hammer_hook "arith_lems" "arith_lems.lt_not_eq". intros. omega. Qed.

Lemma lt_not_eq_sym x y: (y < x -> x <> y)%nat.
Proof. hammer_hook "arith_lems" "arith_lems.lt_not_eq_sym". intros. omega. Qed.

Hint Resolve lt_not_eq.
Hint Resolve lt_not_eq_sym.

Definition sqrd n := n * n.

Lemma sqrd_S n: sqrd (S n) = sqrd n + n + n + 1.
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.sqrd_S".
induction n...
rewrite IHn.
clear IHn.
unfold sqrd.
ring.
Qed.

Lemma sqrd_plus x y: sqrd x + sqrd y <= sqrd (x + y).
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.sqrd_plus".
intros.
unfold sqrd.
autorewrite with arith_norm...
Qed.

Lemma sqrd_le x y: x <= y -> sqrd x <= sqrd y.
intros.
unfold sqrd.
apply mult_le_compat; auto.
Qed.

Hint Resolve sqrd_plus sqrd_le.

Lemma div2_preserves_le x y: x <= y -> div2 x <= div2 y.
Proof. hammer_hook "arith_lems" "arith_lems.div2_preserves_le".
rewrite !Nat.div2_div. now apply Nat.div_le_mono.
Qed.

Lemma Sdiv2_eq_div2SS x: S (div2 x) = div2 (S (S x)).
Proof. hammer_hook "arith_lems" "arith_lems.Sdiv2_eq_div2SS". reflexivity. Qed.

Lemma div2S_le_Sdiv2 x: div2 (S x) <= S (div2 x).
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.div2S_le_Sdiv2".
destruct x...
rewrite <- Sdiv2_eq_div2SS.
apply -> Nat.succ_le_mono. apply div2_preserves_le...
Qed.

Lemma div2_x_plus_Sx b: div2 (b + S b) = b.
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.div2_x_plus_Sx".
induction b...
rewrite plus_Sn_m.
rewrite <- plus_Snm_nSm.
rewrite plus_Sn_m.
simpl...
Qed.

Lemma div2_x_plus_2y a b: div2 (a + 2 * b) = div2 a + b.
Proof. hammer_hook "arith_lems" "arith_lems.div2_x_plus_2y".
rewrite !Nat.div2_div, Nat.mul_comm. now apply Nat.div_add.
Qed.

Lemma div2_sqrdSn n: div2 (sqrd n) + n <= div2 (sqrd (S n)).
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.div2_sqrdSn".
intros.
unfold sqrd.
replace (S n * S n) with (n * n + 2 * n + 1) by ring.
replace (div2 (n * n) + n) with (div2 (n * n + 2 * n)).
apply div2_preserves_le...
rewrite div2_x_plus_2y...
Qed.

Lemma le_div2 n: div2 n <= n.
Proof. hammer_hook "arith_lems" "arith_lems.le_div2". apply Nat.div2_decr; auto with arith. Qed.

Lemma div2_lt_inv0 x y: div2 x < div2 y -> x < y.
Proof. hammer_hook "arith_lems" "arith_lems.div2_lt_inv0".
rewrite !Nat.lt_nge. intros H H'. contradict H. now apply div2_preserves_le.
Qed.

Lemma div2_lt_inv x y: div2 x < div2 y -> x <= y.
Proof. hammer_hook "arith_lems" "arith_lems.div2_lt_inv".
intros. now apply Nat.lt_le_incl, div2_lt_inv0.
Qed.

Lemma div2_le_div2_inv x y: div2 x <= div2 y -> x <= S y.
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.div2_le_div2_inv".
destruct x as [|[|x]]...
simpl. intros H. apply div2_lt_inv0 in H...
Qed.

Lemma div2_cancel n: div2 (2 * n) = n.
Proof with auto. hammer_hook "arith_lems" "arith_lems.div2_cancel".
induction n...
simpl mult.
rewrite <- plus_n_Sm.
simpl in *...
Qed.

Lemma div2_le_inv x n: div2 x <= n -> x <= S (2 * n).
Proof. hammer_hook "arith_lems" "arith_lems.div2_le_inv". intros. rewrite <- (div2_cancel n) in H. apply (div2_le_div2_inv _ _ H). Qed.

Fixpoint pow (b e: nat) {struct e}: nat :=
match e with
| 0 => 1
| S e' => b * pow b e'
end.

Lemma pow_S x y: pow x (S y) = x * pow x y.
Proof. hammer_hook "arith_lems" "arith_lems.pow_S". auto. Qed.

Lemma pow_min x: x <> 0%nat -> forall y, 0 < pow x y.
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.pow_min".
intros H.
induction y...
simpl.
apply lt_0_mult...
destruct x...
Qed.

Function ceil_log2_S (n: nat) {wf lt n}: nat :=
match n with
| 0 => 0
| S _ => S (ceil_log2_S (div2 n))
end.
Proof.
intros.
apply lt_div2; auto with arith.
apply lt_wf.
Defined.

Lemma ceil_log2_S_def n: ceil_log2_S n =
match n with
| 0 => 0
| S _ => S (ceil_log2_S (div2 n))
end.
Proof. hammer_hook "arith_lems" "arith_lems.ceil_log2_S_def". functional induction (ceil_log2_S n); auto. Qed.

Definition log2ceil (n: nat): nat :=
match n with
| 0 => 0
| S n' => ceil_log2_S n'
end.

Function floor_log2_S (n: nat) {wf lt n}: nat :=
match n with
| 0 => 0
| S n' => S (floor_log2_S (div2 n'))
end.
Proof. hammer_hook "arith_lems" "arith_lems.log2ceil".
intros.
apply le_lt_trans with n'; auto with arith.
apply le_div2.
apply lt_wf.
Defined.

Lemma pow2_ceil_log2: forall n, S n <= pow 2 (ceil_log2_S n).
Proof with auto. hammer_hook "arith_lems" "arith_lems.pow2_ceil_log2".
intro.
functional induction (ceil_log2_S n).
simpl...
rewrite pow_S.
cset' (pow 2 (ceil_log2_S (div2 (S _x)))).
destruct H.
inversion IHn0.
cset (le_S_n _ _ IHn0).
cset (div2_le_inv (S _x) H0).
omega.
Qed.

Lemma ceil_log2_Sn_le_n: forall n, ceil_log2_S n <= n.
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.ceil_log2_Sn_le_n".
intro.
functional induction (ceil_log2_S n)...
apply le_n_S.
apply le_trans with (div2 (S _x))...
apply lt_n_Sm_le.
apply lt_div2...
Qed.

Lemma log2ceil_lt: forall n, 0 < n -> log2ceil n < n.
Proof with auto. hammer_hook "arith_lems" "arith_lems.log2ceil_lt".
destruct n...
simpl.
unfold lt.
intros.
apply le_n_S.
apply ceil_log2_Sn_le_n.
Qed.

Lemma log2ceil_le: forall n, log2ceil n <= n.
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.log2ceil_le".
destruct n...
apply lt_le_weak.
apply log2ceil_lt...
Qed.

Lemma log2ceil_S_preserves_le x y: x <= y -> ceil_log2_S x <= ceil_log2_S y.
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.log2ceil_S_preserves_le".
revert y.
functional induction (ceil_log2_S x)...
intros.
destruct y.
inversion H.
apply le_trans with (S (ceil_log2_S (div2 (S y)))).
apply le_n_S...
apply IHn.
apply div2_preserves_le...
rewrite (ceil_log2_S_def (S y))...
Qed.

Lemma log2ceil_preserves_le x y: x <= y -> log2ceil x <= log2ceil y.
Proof with auto with arith. hammer_hook "arith_lems" "arith_lems.log2ceil_preserves_le".
destruct x.
destruct y...
destruct y.
intros.
inversion H.
simpl.
intros.
apply log2ceil_S_preserves_le...
Qed.

Lemma INR_S_ne_0 n: INR (S n) <> 0%R.
Proof. hammer_hook "arith_lems" "arith_lems.INR_S_ne_0". apply not_O_INR. discriminate. Qed.

Hint Resolve INR_S_ne_0.

Lemma O_le_inv_INR_S n: (0 <= / INR (S n))%R.
Proof. hammer_hook "arith_lems" "arith_lems.O_le_inv_INR_S". intros. apply Rlt_le. apply Rinv_0_lt_compat. apply lt_INR_0. auto with arith. Qed.

Hint Resolve O_le_inv_INR_S.

Lemma INR_0_inv n: INR n = 0%R -> n = 0.
Proof with auto. hammer_hook "arith_lems" "arith_lems.INR_0_inv".
destruct n...
intros.
elimtype False.
apply (INR_S_ne_0 _ H).
Qed.

Lemma O_lt_INR_S n: (0 < INR (S n))%R.
Proof. hammer_hook "arith_lems" "arith_lems.O_lt_INR_S". intros. apply lt_INR_0. auto with arith. Qed.

Hint Resolve O_lt_INR_S.

Require Import Fourier.

Ltac deep_Rle_trans h :=
match type of h with
| ?n <= ?u =>
match goal with
| |- (?l <= _)%R =>
let q := subst_tac n u l
in apply Rle_trans with q
| _ => assert (False)
end
end.

Lemma Rmult_eq_compat_r (r r1 r2: R): (r1 = r2 -> r1 * r = r2 * r)%R.
Proof. hammer_hook "arith_lems" "arith_lems.Rmult_eq_compat_r". intros. subst. reflexivity. Qed.

Lemma Rle_eq_trans x y z: (x <= y -> y = z -> x <= z)%R.
Proof. hammer_hook "arith_lems" "arith_lems.Rle_eq_trans". intros. fourier. Qed.

Lemma Req_ne_dec (x y: R): { x = y } + { x <> y }.
Proof with auto. hammer_hook "arith_lems" "arith_lems.Req_ne_dec".
intros.
destruct (Rlt_le_dec x y).
right. intro. subst. apply (Rlt_irrefl y)...
destruct (Rle_lt_or_eq_dec _ _ r); [right | left]...
intro. subst. apply (Rlt_irrefl y)...
Qed.

Lemma Rmult_0_inv (a b: R): (a * b)%R = 0%R -> (a = 0%R \/ b = 0%R).
Proof with auto with real. hammer_hook "arith_lems" "arith_lems.Rmult_0_inv".
intros.
destruct (Req_ne_dec a 0%R)...
destruct (Req_ne_dec b 0%R).
right...
elimtype False.
apply (prod_neq_R0 a b)...
Qed.

Lemma Req_le_trans x y z: x = y -> y <= z -> x <= z.
Proof. hammer_hook "arith_lems" "arith_lems.Req_le_trans". intros. subst. assumption. Qed.

Lemma Rle_plus_trans_l r a b c: a <= r -> r + b <= c -> a + b <= c.
Proof. hammer_hook "arith_lems" "arith_lems.Rle_plus_trans_l". intros. apply Rle_trans with (r + b); auto with real. Qed.

Lemma Rne_nlt_lt x y: x <> y -> ~ x < y -> y < x.
Proof with auto with real. hammer_hook "arith_lems" "arith_lems.Rne_nlt_lt".
intros.
destruct (Rlt_le_dec x y)...
elimtype False...
destruct (Rle_lt_or_eq_dec y x r)...
elimtype False...
Qed.

Lemma Rdiv_le_1 a b: 0 < a -> a <= b -> 1 <= b / a.
Proof with auto with real. hammer_hook "arith_lems" "arith_lems.Rdiv_le_1".
intros.
unfold Rdiv.
rewrite <- (Rinv_r a)...
Qed.

Lemma Rdiv_lt_1 n m: 0 <= n -> n < m -> n / m < 1.
Proof with auto with real. hammer_hook "arith_lems" "arith_lems.Rdiv_lt_1".
unfold Rdiv.
intros.
rewrite <- (Rinv_r m)...
apply Rmult_lt_compat_r...
apply Rinv_0_lt_compat...
fourier.
intro.
subst.
apply (Rlt_not_le _ _ H0 H).
Qed.

Lemma zero_le_2_div_Sn n: 0 <= (2 * / INR (S n))%R.
Proof with auto with real. hammer_hook "arith_lems" "arith_lems.zero_le_2_div_Sn".
intros.
unfold Rdiv...
apply Rle_mult_inv_pos...
Qed.

Hint Resolve zero_le_2_div_Sn.

Definition bigO (f g: nat -> R): Prop := exists c, exists n, forall x, (n <= x)%nat -> f x <= c * g x.

Definition measured_bigO (X: Set) (m: X -> nat) (f: X -> R) (g: nat -> R): Prop
:= exists c, exists n, forall x, (n <= m x)%nat -> f x <= c * g (m x).

Notation "'over' m , f =O( g )" := (measured_bigO m f g).


Require Import init.

Require Export analysis_base.
Require Import analysis_topology.
Require Import analysis_sequence.

(* begin hide *)
Section SubspaceMetric.

Context {U} `{Metric U}.
(* end hide *)
Variable X : U → Prop.

Program Instance subspace_metric : Metric (set_type X) := {
    d x y := d [x|] [y|]
}.
Next Obligation.
    destruct x as [x Xx], y as [y Xy]; cbn.
    split.
    -   intros eq.
        apply set_type_eq; cbn.
        apply d_ind.
        exact eq.
    -   intros eq.
        inversion eq.
        rewrite d_zero.
        reflexivity.
Qed.
Next Obligation.
    destruct x as [x Xx], y as [y Xy]; cbn.
    apply d_sym.
Qed.
Next Obligation.
    destruct x as [x Xx], y as [y Xy], z as [z Xz]; cbn.
    apply d_tri.
Qed.

Theorem complete_sub_closed : complete U → closed X ↔ complete (set_type X).
Proof.
    intros U_complete.
    split.
    -   intros X_closed Xf Xf_cauchy.
        pose (f n := [Xf n|]).
        specialize (U_complete f Xf_cauchy) as [x fx].
        rewrite metric_seq_closed in X_closed.
        assert (∀ n, X (f n)) as f_in_X.
        {
            intros n.
            unfold f.
            exact [|Xf n].
        }
        specialize (X_closed f x f_in_X fx) as Xx.
        exists [x|Xx].
        rewrite metric_seq_lim.
        rewrite metric_seq_lim in fx.
        apply fx.
    -   intros X_complete.
        apply metric_seq_closed.
        intros f x f_in_X fx.
        pose (Xf n := [f n|f_in_X n]).
        assert (seq_converges f) as f_cauchy by (exists x; exact fx).
        apply converges_cauchy in f_cauchy.
        specialize (X_complete Xf f_cauchy) as [[x' Xx'] Xfx'].
        assert (seq_lim f x') as fx'.
        {
            rewrite metric_seq_lim.
            rewrite metric_seq_lim in Xfx'.
            exact Xfx'.
        }
        rewrite (seq_lim_unique _ _ _ fx fx').
        exact Xx'.
Qed.

(* begin hide *)
End SubspaceMetric.

Section SubspaceMetricEquiv.

Existing Instance subspace_metric.
(* end hide *)
Theorem metric_subspace_topology {U} `{Metric U} : ∀ X,
    subspace_topology X = (basis_topology (b := metric_topology)).
Proof.
    intros X.
    apply topology_equal.
    intros S.
    split.
    -   intros [T [T_open S_eq]]; subst S.
        intros [x Xx] Tx.
        specialize (T_open x Tx) as [B [[y [ε B_eq]] [Bx sub]]]; subst B.
        pose proof (open_ball_ex _ _ _ Bx) as [δ δ_sub].
        exists (to_set_type X (open_ball x δ)).
        split.
        2: split.
        +   unfold top_basis; cbn.
            exists [x|Xx], δ.
            reflexivity.
        +   apply open_ball_self.
        +   apply to_set_type_sub.
            exact (trans δ_sub sub).
    -   rewrite <- subspace_basis_eq.
        unfold open; cbn.
        intros S_open x Sx.
        specialize (S_open x Sx) as [B [[y [ε B_eq]] [Bx B_sub]]].
        subst B.
        exists (open_ball y ε).
        split.
        2: split.
        +   exists (open_ball [y|] ε).
            split.
            *   exists [y|], ε; reflexivity.
            *   reflexivity.
        +   exact Bx.
        +   exact B_sub.
Qed.
(* begin hide *)

End SubspaceMetricEquiv.
(* end hide *)


(** * Transform Language *)
(** This file describes the Ab Intio Transform Language.  In this language, everything is
    a transformation.  Ab Initio programs are sequences of transformations.  An example
    Ab Initio program is:
        field1 :: 10
        field2 :: field1 * 4
        field3 :: field1 + field2
    *)

Set Warnings "-notation-overridden,-parsing".
From LF Require Import imports.

(* DECLARATIONS OF AB INITIO TYPES *)

(* Numerical expressions *)
Inductive AbNumExpr : Type :=
  | AbNatLit (n : prog_value) (* Natural number literals *)
  | AbIdNat (s : string) (* ID of a natural number stored in the program state *)
  | AbVectorValue (s : string) (n : nat) (* Natural number stored in a vector *)
  | AbAdd (a1 : AbNumExpr) (a2 : AbNumExpr) (* Adding two natural numbers *)
  | AbSub (a1 : AbNumExpr) (a2 : AbNumExpr) (* Subtracting two natural numbers *)
  | AbMulti (a1 : AbNumExpr) (a2 : AbNumExpr) (* Multiplying two natural numbers *)
  .

(* Values that result in a bool *)
Inductive AbBoolExpr : Type :=
  | BinTrue (* True *)
  | BinFalse (* False *)
  | AbIdBool (s : string) (* ID of a boolean stored in the program state *)
  | AbUnaryOp (b : AbBoolExpr) (* Unary Op on a boolean *)
  | AbLe (a1 : AbNumExpr) (a2 : AbNumExpr) (* Less than op on two natural numbers *)
  | AbEq (a1 : AbNumExpr) (a2 : AbNumExpr) (* Equal op on two natural numbers *)
  | AbNotEq (a1 : AbNumExpr) (a2 : AbNumExpr) (* Not equal op on two natural numbers *)
  | AbAnd (b1 : AbBoolExpr) (b2 : AbBoolExpr) (* And op on two booleans *)
  | AbOr (b1 : AbBoolExpr) (b2 : AbBoolExpr) (* Or op on two booleans *)
  .

(* Expressions from the transform language *)
Inductive AbExpr : Type :=
  | Ab_Num_Expr (a : AbNumExpr)
  | Ab_Bin_Expr (b : AbBoolExpr)
  | Ab_Enc_Expr (e : AbExpr).

(* Commands from the transform language *)
Inductive AbCommand : Type :=
  | AbTransform (x : string) (a : AbExpr)
  | AbSeq (c1 c2 : AbCommand).

(* EVALUATIONS OF AB INITIO TYPES *)

(* Evaluation of numerical expressions *)
Fixpoint AbEvalNum (st : state) (a : AbNumExpr) : prog_value :=
  match a with
  | AbNatLit l => l
  | AbIdNat s => match st s with
                 | pNat n => pNat n
                 | _ => pNull
                 end
  | AbVectorValue s n => match st s with
                            | pList v => getValueList v n
                            | _ => pNull
                            end
  | AbAdd a1 a2 => pNat (pullOutNat (AbEvalNum st a1) + pullOutNat (AbEvalNum st a2))
  | AbSub a1 a2 => pNat (pullOutNat (AbEvalNum st a1) - pullOutNat (AbEvalNum st a2))
  | AbMulti a1 a2 => pNat (pullOutNat (AbEvalNum st a1) * pullOutNat (AbEvalNum st a2))
  end.

(* Evaluation of bool expressions *)
Fixpoint AbEvalBin (st : state) (b : AbBoolExpr) : prog_value :=
  match b with
  | BinTrue => pBool true
  | BinFalse => pBool false
  | AbIdBool s => match st s with
                 | pBool b => pBool b
                 | _ => pNull
                 end
  | AbUnaryOp b => pBool (negb (pullOutBool (AbEvalBin st b)))
  | AbLe a1 a2 => pBool (leb (pullOutNat (AbEvalNum st a1)) (pullOutNat (AbEvalNum st a2)))
  | AbEq a1 a2 => pBool (Nat.eqb (pullOutNat (AbEvalNum st a1)) (pullOutNat (AbEvalNum st a2)))
  | AbNotEq a1 a2 => pBool (negb (Nat.eqb (pullOutNat (AbEvalNum st a1)) (pullOutNat (AbEvalNum st a2))))
  | AbAnd b1 b2 => pBool (andb (pullOutBool (AbEvalBin st b1)) (pullOutBool (AbEvalBin st b2)))
  | AbOr b1 b2 => pBool (orb (pullOutBool (AbEvalBin st b1)) (pullOutBool (AbEvalBin st b2)))
  end.

(* Evaluation of expressions *)
Fixpoint AbEval (st : state) (a : AbExpr) : prog_value :=
  match a with
  | Ab_Num_Expr a => AbEvalNum st a
  | Ab_Bin_Expr b => AbEvalBin st b
  | Ab_Enc_Expr e => AbEval st e
  end.

(* OPERATIONAL SEMANTICS OF AB INITIO COMMANDS *)

(* Execution of commands *)
Inductive AbInitioProgram : AbCommand -> state -> state -> Prop :=
  | Ab_Transform  : forall st a1 n x,
      AbEvalNum st a1 = n ->
      (AbTransform x (Ab_Num_Expr (AbNatLit n))) / st \\ st & { x --> n }
  | Ab_Seq : forall c1 c2 st st' st'',
      c1 / st \\ st' ->
      c2 / st' \\ st'' ->
      (AbSeq c1 c2) / st \\ st''
  where "c1 '/' st '\\' st'" := (AbInitioProgram c1 st st').


Require Import Program.Basics.

Open Scope program_scope.

(** Catamorphism for [sum]. Folds a sum type [A + B] into [C]. *)
Definition sum_fold {A B C} (l : A -> C) (r : B -> C) (s : A + B) : C :=
  match s with
  | inl a => l a
  | inr b => r b
  end.

(** A function being applied after fold is the same as composing the very same
    function with the original constructors and fold with them.  *)
Theorem sum_fold_f :
  forall {A B C D} (l : A -> C) (r : B -> C) (f : C -> D) (apb : A + B),
  @sum_fold A B D (fun a => f (l a)) (fun b => f (r b)) apb = f (sum_fold l r apb).
Proof.
  destruct apb; auto.
Qed.

Theorem sum_fold_fg :
  forall A A1 B B1 C
        (l1 : A -> A1) (l2 : A1 -> C) (r1 : B -> B1) (r2 : B1 -> C) (x : A + B),
    sum_fold l2 r2 (sum_fold (inl ∘ l1) (inr ∘ r1) x) = sum_fold (l2 ∘ l1) (r2 ∘ r1) x.
Proof.
  intros.
  destruct x; auto.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Init.Peano.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith Coq.ZArith.Zdiv Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.NArith.Nnat.
Require Import Coq.ZArith.Znat.

Require Import Crypto.Algebra.Hierarchy Crypto.Algebra.Field.
Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.ModularArithmeticTheorems Crypto.Arithmetic.PrimeFieldTheorems.

Require Import Crypto.Util.Decidable. (* Crypto.Util.Notations. *)
Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac.
Require Import Ring.

From Circom Require Import Circom Default Util DSL Tuple ListUtil LibTactics Simplify.
From Circom Require Import Repr ReprZ Signed.
From Circom.CircomLib Require Import Bitify Comparators Gates.
From Circom.BigInt.Definition Require Import CheckCarryToZero.
(* Circuit:Z
* https://github.com/yi-sun/circom-pairing/blob/master/circuits/bigint.circom
*)

Module CheckCarryToZero.

Module B := Bitify.
Module D := DSL.
Module Cmp := Comparators.
Module RZS := ReprZSigned.
Module RZ := RZS.RZ.

Import B.

Local Open Scope list_scope.
Local Open Scope Z_scope.
Local Open Scope F_scope.
Local Open Scope circom_scope.
Local Open Scope tuple_scope.

Local Coercion Z.of_nat: nat >-> Z.
Local Coercion N.of_nat: nat >-> N.

Lemma Nat_of_nat_add_1: forall (n: nat),
  (N.of_nat n + 1%N)%N = N.of_nat (n+1)%nat.
Proof. lia. Qed.

Section _CheckCarryToZero.
Context {n m k: nat}.

Local Notation "[| xs |]" := (RZ.as_le n xs).

Definition cons (_in: F^k) :=
  let EPSILON := 1%nat in
  exists
  (carry: F^k)
  (carryRangeChecks: (@Num2Bits.t (m + EPSILON - n)) ^ k),
    D.iter (fun (i: nat) _cons => _cons /\
      (if (dec (i=0))%nat then
        _in[i] = carry[i] * 2^n
      else
        _in[i] + carry[i-1] = carry[i] * 2^n) /\
      carryRangeChecks[i].(Num2Bits._in) = carry[i] + 2^(m+EPSILON-n-1)
      )
      (k-1) True /\
    _in[k-1] + carry[k-2] = 0.

Local Close Scope F_scope.

Record t := {
  _in: F^k;
  _cons: cons _in
}.

Local Open Scope F_scope.

Lemma pow_S: forall (i:nat),
  (2 * 2^i = 2^(i+1))%Z.
Proof.
  intros.
  rewrite Zpower_exp; lia.
Qed.

Lemma pow_sub_le: forall x (j i: Z),
  0 <= j ->
  0 <= i <= j ->
  (x <= 2^(j-i))%Z ->
  (2^i * x <= 2^j)%Z.
Proof.
  intros.
  apply Z.mul_le_mono_nonneg_l with (p:=(2^i)%Z) in H1; try nia.
  rewrite <- Zpower_exp in H1 by lia.
  replace (i + (j - i))%Z with j%Z in H1 by lia.
  lia.
Qed.

Lemma pow_sub_le_sub1: forall x (j i: Z),
  0 <= j ->
  0 <= i <= j ->
  (x <= 2^(j-i)-1)%Z ->
  (2^i * x <= 2^j - 2^i)%Z.
Proof.
  intros.
  apply Z.mul_le_mono_nonneg_l with (p:=(2^i)%Z) in H1; try nia.
  rewrite Z.mul_sub_distr_l in H1.
  rewrite <- Zpower_exp in H1 by lia.
  replace (i + (j - i))%Z with j%Z in H1 by lia.
  lia.
Qed.

Notation "| x |" := (Z.abs x) (at level 60).

Lemma le_2pow_add1: forall x y l,
  x <= 2^l ->
  y <= 2^l ->
  x+y <= 2^(l+1).
Admitted.

Lemma le_pow_trans: forall b x l1 l2,
  b > 0 ->
  0 <= l1 ->
  0 <= l2 ->
  x <= b^l1 ->
  l1 <= l2 ->
  x <= b^l2.
Proof.
  intros.
  transitivity (b^l1)%Z. lia.
  apply Zpow_facts.Zpower_le_monotone; try lia.
Qed.

Lemma pow_lt_trans: forall b x l1 l2,
  b > 1 ->
  0 <= l1 ->
  0 <= l2 ->
  l1 < l2 ->
  b^l2 <= x ->
  b^l1 < x.
Proof.
  intros.
  apply Z.lt_le_trans with (m:=(b^l2)%Z); try lia.
  apply Zpow_facts.Zpower_lt_monotone; try lia.
Qed.

Theorem soundness: forall (c: t),
  1 <= n <= m ->
  2 <= k ->
  m <= C.k-2 ->
  Forall (fun x => |$x| <= 2^(m-1)%Z) ('c.(_in)) ->
  [| 'c.(_in) |] = 0%Z.
Proof.
  unwrap_C.
  intros c H_n H_k H_m H_xm.
  destruct c as [x _cons]. destruct _cons as [carry [check [iter last] ] ].
  simpl in *.
  rem_iter.
  pose_lengths.
  pose proof Signed.half_lb as half_lb.
  replace (m + 1 - n - 1)%N with (m-n)%N in * by lia.

  assert (Hnm: 0 <= 2^n <= 2^m). split. nia. apply Zpow_facts.Zpower_le_monotone; lia.
  assert (Hmr: 0 <= 2*2^m <= 2^C.k). split. nia. rewrite pow_S. apply Zpow_facts.Zpower_le_monotone; lia.
  (* assert (Hrk: 0 <= 2^r <= 2^C.k). split. nia. apply Zpow_facts.Zpower_le_monotone; lia. *)

  (* carry's are bounded by 2^(m-n) *)
  pose (Inv_carry_range := fun (i: nat) _cons => _cons ->
    forall (j: nat), j < i ->
      |$'carry!j| <= 2^(m-n)).
  assert (Hinv_carry_range: Inv_carry_range (k-1)%nat (D.iter f (k-1)%nat (True))). {
    apply D.iter_inv; unfold Inv_carry_range.
    - lia.
    - intros i _cons IH Hi Hstep j Hj. subst f.
      lift_to_list.
      assert (N2B_range: Num2Bits._in (' check ! i) | ((m + 1- n)%nat)). {
        apply (@Num2Bits.range_check _ (' check ! i)). lia.
      }
      lift_to_list.
      intuit.
      rewrite H8 in N2B_range.
      destruct (dec (j<i)). auto.
      assert (j=i) by lia. subst j.
      replace (Z.sub (Z.of_nat m) (Z.of_nat n)) with (Z.of_N (N.sub (N.of_nat m) (N.of_nat n))) by lia.
      apply Signed.range_check; try lia.
      transitivity (2^(m+1-n)%nat-1)%Z. auto.
      match goal with
      | [ |- 2^?a - 1 <= 2^?b]  => assert (Hpow: a = b) by lia; rewrite Hpow
      end. lia.
  }

  (* prefix is equal to carry!j * 2^n(j+1) *)
  pose (Inv_sum := fun (i: nat) _cons => _cons ->
    forall (j: nat) , j<i ->
      (2^(n*(j+1)) * $'carry!j = [| 'x[:j+1] |])%Z).
  assert (Hinv_sum: Inv_sum (k-1)%nat (D.iter f (k-1)%nat (True))). {
    apply D.iter_inv; unfold Inv_sum.
    - lia.
    - intros i _cons IH Hi Hstep j Hj.
      assert (Hcarry: | $ ' carry ! j | <= 2 ^ (m - n)). apply Hinv_carry_range. auto. lia.
      assert (Hcarry': | $ ' carry ! (j-1)%nat | <= 2 ^ (m - n)). apply Hinv_carry_range. auto. lia.
      assert (Hcarry_2n: ($('carry!j * (1+1)^n) = $'carry!j * 2^n)%Z). {
        (* range check: distribute sum *)
        rewrite Signed.to_Z_mul, Signed.to_Z_2_pow, Signed.to_Z_2. nia. lia.
        rewrite Signed.to_Z_2_pow, Signed.to_Z_2 by lia.
        rewrite Signed.abs_nonneg with (x:=(Z.pow (Zpos (xO xH)) (Z.of_N (N.of_nat n)))) by lia.
        eapply Z.le_lt_trans.
        apply Z.mul_le_mono_nonneg_r. lia. eauto.
        rewrite <- Zpower_exp, nat_N_Z by lia.
        apply pow_lt_trans with ((C.k-1))%Z; try lia.
      }
      subst f. lift_to_list.
      split_dec.
      + assert (j = 0)%nat by lia. subst i j.
        simplify.
        erewrite firstn_1 by lia. fold_default. simpl. unfold RZ.ToZ.to_Z. simplify.
        intuit.
        rewrite H7.
        rewrite Hcarry_2n. lia.
      + destruct (dec (j<i)). intuit. auto.
        assert (j=i) by lia. subst j.
        intuit.
        specialize (H6 (i-1))%nat.
        apply f_equal with (f:=Signed.to_Z) in H7.
        rewrite Hcarry_2n in H7.
        rewrite Signed.to_Z_add in H7.

        rewrite RZ.as_le_split_last' with (i:=i).
        rewrite firstn_firstn. rewrite Nat.min_l by lia.
        unfold_default. rewrite firstn_nth by lia. fold_default.
        unfold RZ.ToZ.to_Z.
        replace (i-1+1)%nat with i in H6 by lia.
        rewrite <- H6 by lia.
        replace ((i - 1)%nat + 1)%Z with (Z.of_nat i) by lia.
        rewrite Z.mul_add_distr_l, Zpower_exp by lia.
        simplify.
        rewrite firstn_length_le; lia.

        (* range check: distribute sum *)
        eapply Z.le_lt_trans with (2^((m-1)+1))%Z.
        apply le_2pow_add1.
        (* |$'x!i| <= 2^(m-1) *)
        unfold_default. apply Forall_nth. auto. lia.
        apply le_pow_trans with (m-n)%Z; try lia.
        eapply pow_lt_trans with ((C.k-1)%Z); try lia.
  }
  (* last carry is in range *)
  assert (Hcarry_k_2_range: | $ ' carry ! (k - 2) | <= 2 ^ (m - n)). apply Hinv_carry_range. auto. lia.
  (* (k-1)-prefix *)
  assert (Hcarry_k_2: (2 ^ (n * ((k - 2)%nat + 1)) * $ ' carry ! (k - 2))%Z = [|' x [:k - 2 + 1]|]). apply Hinv_sum. auto. lia.
  replace (k - 2 + 1)%nat with (k-1)%nat in Hcarry_k_2 by lia.
  replace ((k - 2)%nat + 1)%Z with (k-1)%Z in Hcarry_k_2 by lia.
  lift_to_list.
  (* distribute sum *)
  apply f_equal with (f:=Signed.to_Z) in last.
  rewrite Signed.to_Z_add, Signed.to_Z_0 in last.
  rewrite RZ.as_le_split_last' with (i:=(k-1)%nat). unfold RZ.ToZ.to_Z.
  rewrite <- Hcarry_k_2.
  rewrite Nat2Z.inj_sub by lia. simpl. lia.
  lia.
  (* range check: distribute sum *)
  eapply Z.le_lt_trans with (2^((m-1)+1))%Z.
  apply le_2pow_add1.
  (* |$'x!i| <= 2^(m-1) *)
  unfold_default. apply Forall_nth. auto. lia.
  apply le_pow_trans with (m-n)%Z; try lia.
  eapply pow_lt_trans with ((C.k-1)%Z); try lia.
Unshelve. exact F.zero.
Qed.

End _CheckCarryToZero.
End CheckCarryToZero.


From Undecidability.L Require Export Util.L_facts.
From Undecidability.L.Tactics Require Export LTactics GenEncode.
Require Import Undecidability.Shared.Libs.PSL.Numbers.

Require Import Nat.
From Undecidability.L Require Import Datatypes.LBool Functions.EqBool Datatypes.LProd.
Import GenEncode. Import Nat.
(* ** Encoding of natural numbers *)

MetaCoq Run (tmGenEncode "nat_enc" nat).
#[export] Hint Resolve nat_enc_correct : Lrewrite.

Instance termT_S : computableTime' S (fun _ _ => (1,tt)).
Proof.
  extract constructor.
  solverec.
Qed.

Instance termT_pred : computableTime' pred (fun _ _ => (5,tt)).
Proof.
  extract.
  solverec.
Qed.

Definition c__add := 11.
Definition c__add1 := 5.
Definition add_time x := (x + 1) * c__add.
Instance termT_plus' : computableTime' add (fun x xT => (c__add1,(fun y yT => (add_time x,tt)))).
Proof.
  extract.
  fold add. solverec.
  all: unfold add_time, c__add1, c__add; solverec.
Qed.

Definition c__mult1 := 5.
Definition c__mult := c__add + c__add1 + 10.
Definition mult_time x y := x * y * c__mult + c__mult * (x+ 1) .
Instance termT_mult : computableTime' mult (fun x xT => (c__mult1,(fun y yT => (mult_time x y,tt)))).
Proof.
  extract. solverec.
  all: unfold mult_time, c__mult1, c__mult, add_time, c__add1, c__add; solverec.
Qed.

Definition c__sub1 := 5.
Definition c__sub := 14.
Definition sub_time x y := (min x y + 1) * c__sub.
Instance term_sub : computableTime' Nat.sub (fun n _ => (c__sub1,fun m _ => (sub_time n m ,tt)) ).
Proof.
  extract. solverec.
  all: unfold sub_time, c__sub1, c__sub; solverec.
Qed.

Definition c__leb := 14.
Definition c__leb2 := 5.
Definition leb_time (x y : nat) := c__leb * (1 + min x y).
Instance termT_leb : computableTime' leb (fun x xT => (c__leb2,(fun y yT => (leb_time x y,tt)))).
Proof.
  extract.
  solverec. all: unfold leb_time, c__leb, c__leb2; solverec.
Qed.

Definition c__ltb := c__leb2 + 4.
Definition ltb_time (a b : nat) := leb_time (S a) b + c__ltb.
Instance term_ltb : computableTime' Nat.ltb (fun a _ => (1, fun b _ => (ltb_time a b, tt))).
Proof.
  extract. recRel_prettify2.
  - lia.
  - unfold ltb_time, c__ltb. solverec.
Qed.

Instance eqbNat_inst : eqbClass Nat.eqb.
Proof.
  exact Nat.eqb_spec.
Qed.

Instance eqbComp_nat : eqbCompT nat.
Proof.
  evar (c:nat). exists c. unfold Nat.eqb.
  unfold enc;cbn.
  extract.
  solverec.
  [c]:exact 5.
  all:unfold c;try lia.
Qed.
(*Qed.*)

Definition c__min1 := 5.
Definition c__min2 := 15.
Definition min_time x y := (min x y + 1) * c__min2.
Instance termT_nat_min : computableTime' Nat.min (fun x _ => (c__min1, fun y _ => (min_time x y, tt))).
Proof.
  extract. solverec.
  all: unfold min_time, c__min1, c__min2; solverec.
Qed.

Definition c__max1 := 5.
Definition c__max2 := 15.
Definition max_time x y := (min x y + 1) * c__max2.
Instance termT_nat_max : computableTime' Nat.max (fun x _ => (c__max1, fun y _ => (max_time x y, tt))).
Proof.
  extract. solverec.
  all: unfold max_time, c__max1, c__max2; solverec.
Qed.

Definition c__pow1 := 5.
Definition c__pow2 := 10 + c__mult1.
Fixpoint pow_time x n := match n with
  | 0 => c__pow2
  | S n => pow_time x n + mult_time x (x ^n) + c__pow2
end.
Instance termT_pow:
  computableTime' Init.Nat.pow   (fun (x : nat) _ => (c__pow1,fun (n : nat) _ => (pow_time x n, tt))).
Proof.
  extract. fold Nat.pow. solverec.
  all: unfold pow_time, c__pow1, c__pow2; solverec.
Qed.

Definition c__divmod := 20.
Definition divmod_time (x: nat) := c__divmod * (1+x).
Instance termT_divmod :
  computableTime' divmod (fun (x : nat) _ => (5, fun (y : nat) _ => (5, fun (q : nat) _ => (1, fun (u : nat) _ => (divmod_time x, tt))))).
Proof.
  extract. solverec. all: unfold divmod_time, c__divmod; solverec.
Qed.

Definition c__modulo := 21 + c__sub1.
Definition modulo_time (x :nat) (y : nat) := divmod_time x + c__sub * y + c__modulo.
Instance termT_modulo :
  computableTime' Init.Nat.modulo (fun x _ => (1, fun y _ => (modulo_time x y, tt))).
Proof.
  extract. solverec.
  - unfold modulo_time, c__modulo; solverec.
  - unfold sub_time. rewrite Nat.le_min_l. unfold modulo_time, c__modulo. solverec.
Qed.

(* now some more encoding-related properties:*)

Fixpoint nat_unenc (s : term) :=
  match s with
  | lam (lam #1) => Some 0
  | lam (lam (app #0 s)) => match nat_unenc s with Some n => Some (S n) | x=>x end
  | _ => None
  end.

Lemma unenc_correct m : (nat_unenc (nat_enc m)) = Some m.
Proof.
  induction m; simpl; now try rewrite IHm.
Qed.

Lemma unenc_correct2 t n : nat_unenc t = Some n -> nat_enc n = t.
Proof with try solve [Coq.Init.Tactics.easy].
  revert n. eapply (size_induction (f := size) (p := (fun t => forall n, nat_unenc t = Some n -> nat_enc n = t))). clear t. intros t IHt n H.
  destruct t as [ | | t]. easy. easy.
  destruct t as [ | | t]. easy. easy.
  destruct t. 3:easy.
  -destruct n0. easy. destruct n0. 2:easy. inv H. easy.
  -destruct t1. 2-3:easy. destruct n0. 2:easy. simpl in H. destruct (nat_unenc t2) eqn:A.
   +apply IHt in A;simpl;try lia. destruct n. inv H. simpl. congruence.
   +congruence.
Qed.

Lemma dec_enc t : dec (exists n, t = nat_enc n).
Proof.
  destruct (nat_unenc t) eqn:H.
  - left. exists n. now eapply unenc_correct2 in H.
  - right. intros [n A]. rewrite A in H. rewrite unenc_correct in H. inv H.
Qed.

Definition c__natsizeO := 4.
Definition c__natsizeS := 4.
Lemma size_nat_enc (n:nat) :
  size (enc n) = n * c__natsizeS + c__natsizeO.
Proof.
  unfold c__natsizeS, c__natsizeO.
  induction n;cbv [enc registered_nat_enc] in *. all:cbn [size nat_enc] in *. all:solverec.
Qed.

Lemma size_nat_enc_r (n:nat) :
  n <= size (enc n).
Proof.
    induction n;cbv [enc registered_nat_enc] in *. all:cbn [size nat_enc] in *. all:solverec.
Qed.

(* This is an example for an function in which the run-time of the fix itself is not constant (in add, the fix on the first argument always returns an function in ~5 steps)*)
(* Instance termT_testId : computableTime' (fix f x := *)
(*                                             match x with *)
(*                                               0 => 0 *)
(*                                             | S x => S (f x) *)
(*                                             end). *)
(* Proof. *)
(*   extract. *)
(*   eexists (fun x xT => (x*9+7,tt)). *)
(*   abstract (repeat (cbn;intros;intuition;try destruct _;try ring_simplify)). *)
(* Qed. *)


From Undecidability.Shared.Libs.PSL Require Import BaseLists.

(* *** Filter *)

Section Filter.
  Variable X : Type.
  Implicit Types (x y: X) (A B C: list X) (p q: X -> bool).

  (* Fixpoint filter p A : list X := *)
  (*   match A with *)
  (*   | nil => nil *)
  (*   | x::A' => if p x then x :: filter p A' else filter p A' *)
  (*   end. *)

  Lemma in_filter_iff x p A :
    x el filter p A <-> x el A /\ p x.
  Proof.
    induction A as [|y A]; cbn.
    - tauto.
    - destruct (p y) eqn:E; cbn;
        rewrite IHA; intuition; subst; auto.
      destruct (p x); auto.
  Qed.

  Lemma filter_incl p A :
    filter p A <<= A.
  Proof.
    intros x D. apply in_filter_iff in D. apply D.
  Qed.

  Lemma filter_mono p A B :
    A <<= B -> filter p A <<= filter p B.
  Proof.
    intros D x E. apply in_filter_iff in E as [E E'].
    apply in_filter_iff. auto.
  Qed.

  Lemma filter_id p A :
    (forall x, x el A -> p x) -> filter p A = A.
  Proof.
    intros D.
    induction A as [|x A]; cbn.
    - reflexivity.
    - destruct (p x) eqn:E.
      + f_equal; auto.
      + exfalso. apply bool_Prop_false in E. auto.
  Qed.

  Lemma filter_app p A B :
    filter p (A ++ B) = filter p A ++ filter p B.
  Proof.
    induction A as [|y A]; cbn.
    - reflexivity.
    - rewrite IHA. destruct (p y); reflexivity.
  Qed.

  Lemma filter_fst p x A :
    p x -> filter p (x::A) = x::filter p A.
  Proof.
    cbn. destruct (p x); auto.
  Qed.

  Lemma filter_fst' p x A :
    ~ p x -> filter p (x::A) = filter p A.
  Proof.
    cbn. destruct (p x); auto.
  Qed.

  Lemma filter_pq_mono p q A :
    (forall x, x el A -> p x -> q x) -> filter p A <<= filter q A.
  Proof.
    intros D x E. apply in_filter_iff in E as [E E'].
    apply in_filter_iff. auto.
  Qed.

  Lemma filter_pq_eq p q A :
    (forall x, x el A -> p x = q x) -> filter p A = filter q A.
  Proof.
    intros C; induction A as [|x A]; cbn.
    - reflexivity.
    - destruct (p x) eqn:D, (q x) eqn:E.
      + f_equal. auto.
      + exfalso. enough (p x = q x) by congruence. auto.
      + exfalso. enough (p x = q x) by congruence. auto.
      + auto.
  Qed.

  Lemma filter_and p q A :
    filter p (filter q A) = filter (fun x => p x && q x) A.
  Proof.
    induction A as [|x A]; cbn. reflexivity.
    destruct (p x) eqn:E, (q x); cbn;
      try rewrite E; now rewrite IHA.
  Qed.

  Lemma filter_comm p q A :
    filter p (filter q A) = filter q (filter p A).
  Proof.
    rewrite !filter_and. apply filter_pq_eq.
    intros x _. now destruct (p x), (q x).
  Qed.

End Filter.

Lemma filter_map X Y p (f: X -> Y) A :
  filter p (map f A) = map f (filter (fun x => p (f x)) A).
Proof.
  induction A;cbn. reflexivity. destruct _;cbn; congruence.
Qed.


Require Export Coq.Relations.Relations.
Require Export Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid. (* DefaultRelation *)
Require Import Coq.Program.Program. (* compose *)

Definition id {A : Type} (a : A) := a.

Class Equiv A := equiv : relation A.

Infix "=" := equiv : type_scope.

Notation "(=)" := equiv (only parsing).

Typeclasses Transparent Equiv.
Typeclasses Transparent compose flip.

Instance equiv_default_relation {A} `{Equiv A} : DefaultRelation (=) | 3.

Definition ext_equiv {A B} `{Equiv A} `{Equiv B} : Equiv (A -> B) := ((=) ==> (=))%signature.
Hint Extern 10 (Equiv (_ -> _)) => apply @ext_equiv : typeclass_instances.
Hint Extern 10 (Equiv (relation _)) => apply @ext_equiv : typeclass_instances. (* Due to bug #2491 *)

Definition sig_equiv {A} `{Equiv A} (P: A -> Prop) : Equiv (sig P) := fun x y => `x = `y.

Class Setoid A `{Ae: Equiv A} : Prop :=
  setoid_eq :> Equivalence (@equiv A Ae).

Class SetoidMorphism {A B} `{Equiv A} `{Equiv B} (f:A->B) :=
  { setoidmor_a : Setoid A
  ; setoidmor_b : Setoid B
  ; sm_proper   :> Proper ((=) ==> (=)) f }.

Class Seq {A B} `{Equiv A} `{Equiv B} (s : A -> B) := {
  seq_proper :> Proper (equiv ==> equiv) s
}.

Class Le (A : Type) := le : relation A.

Class Lt (A : Type) := lt : relation A.

Infix "≤" := le (at level 50).

Notation "(≤)" := le (only parsing).

Infix "<" := lt (at level 70).

Notation "(<)" := lt (only parsing).

Typeclasses Transparent Le.

Definition sig_le {A} `{Le A} (P : A->Prop) : Le (sig P) := fun x y => `x ≤ `y.
Definition sig_lt {A} `{Lt A} (P : A->Prop) : Lt (sig P) := fun x y => `x < `y.

Infix "≥" := (flip le) (at level 50).

Notation "(≥)" := (flip le) (only parsing).

Infix ">" := (flip lt) (at level 70).
Notation "(>)" := (flip lt) (only parsing).

Class Inverse {A} {B} (f: A->B) := inverse : B->A.
Arguments inverse {A B} _ {Inverse} _.
Typeclasses Transparent Inverse.

Class AntiSymmetric {A} `{Equiv A} (R: relation A) : Prop :=
  antisymmetry : forall {x y}, R x y -> R y x -> x = y.

Class TotalRelation {A} `(R : relation A) : Prop :=
  total : forall x y : A, R x y \/ R y x.

Section jections.

  Context {A B} {Ae : Equiv A} {Be : Equiv B} (f : A->B) `{inv: !Inverse f}.

  Class Injective : Prop :=
   { injective : forall x y, f x = f y -> x = y
   ; injective_mor : SetoidMorphism f }.

  Class Surjective : Prop :=
   { surjective : compose f (inverse f) = id
   ; surjective_mor : SetoidMorphism f }.

  Class Bijective : Prop :=
   { bijective_injective :> Injective
   ; bijective_surjective :> Surjective }.

End jections.

Definition emptyset {A} := fun _ : A => False.

Definition nonempty {A} (P : A ->Prop) : Prop := exists x, P x.

Notation "∅" := emptyset.


(** Just an union-find *)
Require Import Arith.Peano_dec.
Require Import String.
Require Import List.
Require Import Cybele.Cybele.
Require Import Cybele.DataStructures.

Set Implicit Arguments.
Set Transparent Obligation.
Import Monad ListNotations.

(** Normal union-find with array of integers *)
Module UnionFind.
  Definition Sig: Sig.t := Sig.Make nil ((Array.internal_t nat: Type) :: nil).
  Definition Array := Array.t Sig nat.
  Definition M := M Sig.

  (** The representative of [i] *)
  Definition Find (array: Array) (i: nat): M nat :=
    fix_ (fun f i =>
      let! j := Array.read array i in
      match eq_nat_dec i j with
      | left _ => ret i
      | right _ => f j
      end) i.

  (** Merge the equivalent classes of [i] and [j] *)
  Definition Unify (array: Array) (i j: nat): M unit :=
    let! i' := Find array i in
    let! j' := Find array j in
    Array.write array i' j'.

  (** Do the union-find with a list of equalities and return
      the list of representatives *)
  Definition UnionFind (n: nat) (unions: list (nat * nat))
    : M (list nat) :=
    let! array := tmp_ref Sig 0 (seq 0 n) in
    do! List.iter (fun (ij: nat * nat) =>
      let (i, j) := ij in
      Unify array i j)
      unions in
    Array.to_list array.

  Definition Eval (n: nat) (l: list (nat * nat)) (nb_steps: nat) :=
    UnionFind n l (State.of_prophecy (Prophecy.of_nat _ nb_steps)).

  Compute Eval 10 nil 0.
  Compute Eval 10 [(0, 1); (0, 0); (2, 9); (1, 4); (4, 1)] 2.
End UnionFind.


Set Implicit Arguments.

(*** preliminary Meta Theory assumptions ***)
Require Export Prelim.

Module Type TG.

Parameter set : Type.

(** * Axioms of set theory **)

(** Finally, we add the primitive operators and axioms of Tarski-Grothendieck Set Theory (Zermelo-Fraenkel with Grothendieck Universes). ***)

(** In is the membership relation on i.  We use x :e y as notation to mean "x is a member of y" and x /:e y as notation for "x is not a member of y." **)
Parameter In : set -> set -> Prop.

Notation "x ':e' y" := (In x y) (at level 70).
Notation "x '/:e' y" := (~(In x y)) (at level 70).

(** Subq is the subset relation on set.  We use X c= Y as notation to mean "X is a subset of Y" and X /c= Y as notation for "X is not a subset of Y." **)

Definition Subq : set -> set -> Prop :=
fun X Y => forall x : set, x :e X -> x :e Y.

Notation "X 'c=' Y" := (Subq X Y) (at level 70).
Notation "X '/c=' Y" := (~(Subq X Y)) (at level 70).

(** Two sets are equal if they have the same elements. Equivalently, we can always prove two sets are equal by proving they are subsets of each other. **)

Axiom set_ext : forall X Y : set, X c= Y -> Y c= X -> X = Y.

(** Sets are formed iteratively, so we can prove properties about all sets by induction on membership.
Suppose P is a property of sets. If we can prove P holds for X from the inductive hypothesis that P holds for all member of X,
then P must hold for all sets. **)

Axiom In_ind : forall P : set -> Prop, (forall X : set, (forall x, x :e X -> P x) -> P X) -> forall X : set, P X.

(** Empty is the empty set. **)

Parameter Empty : set.

Axiom EmptyE : forall x : set, x /:e Empty.

(** Given two sets y and z, (UPair y z) is {y,z}. **)

Parameter UPair : set -> set -> set.

Axiom UPairI1 :
forall y z : set, y :e (UPair y z).

Axiom UPairI2 :
forall y z : set, z :e (UPair y z).

Axiom UPairE :
forall x y z : set, x :e (UPair y z) -> x = y \/ x = z.

(** Given a set X, (Union X) is the set {x | there is some Y such that x :e Y and Y :e X}. That is, Union gives the union of a set of sets. **)

Parameter Union : set -> set.

Axiom UnionI :
forall X x Y : set, x :e Y -> Y :e X -> x :e (Union X).

Axiom UnionE :
forall X x : set, x :e (Union X) -> exists Y : set, x :e Y /\ Y :e X.

(** Given a set X and a function F, (Repl F X) is the set {F x|x :e X}. That is, Repl allows us to form a set by
 replacing the elements x in a set X with corresponding elements F x. **)

Parameter Repl : (set -> set) -> set -> set.

Axiom ReplI :
forall X : set, forall F : set -> set, forall x : set, x :e X -> (F x) :e (Repl F X).

Axiom ReplE :
forall X : set, forall F : set -> set, forall y : set, y :e (Repl F X) -> exists x : set, x :e X /\ y = F x.

(** (Power X) is the set of all subsets of X. **)

Parameter Power : set -> set.

Axiom PowerI : forall X Y : set, Y c= X -> Y :e (Power X).

Axiom PowerE : forall X Y : set, Y :e (Power X) -> Y c= X.

(** Every set is a member of a Grothendieck universe. A Grothendieck universe is a transitive set closed under the previous
set theoretic operators. The assumption that Grothendieck universes exist is stronger than an axiom of infinity since (GU Empty) is infinite.
We also assume (GU X) is the least Grothendieck universe containing X. **)

Parameter GU : set -> set.

Axiom GUIn : forall N : set, N :e (GU N).

Axiom GUTrans : forall N X Y : set, X :e (GU N) -> Y :e X -> Y :e (GU N).

Axiom GUUPair : forall N X Y : set, X :e (GU N) -> Y :e (GU N) -> (UPair X Y) :e (GU N).

Axiom GUPower : forall N X : set, X :e (GU N) -> (Power X) :e (GU N).

Axiom GUUnion : forall N X : set, X :e (GU N) -> (Union X) :e (GU N).

Axiom GURepl : forall N X : set, forall F : set -> set, X :e (GU N) -> (forall x : set, x :e X -> (F x) :e (GU N)) -> (Repl F X) :e (GU N).

Axiom GUMin : forall N U : set, N :e U
  -> (forall X Y : set, X :e U -> Y :e X -> Y :e U)
  -> (forall X Y : set, X :e U -> Y :e U -> (UPair X Y) :e U)
  -> (forall X : set, X :e U -> (Power X) :e U)
  -> (forall X : set, X :e U -> (Union X) :e U)
  -> (forall X : set, forall F:set -> set, X :e U -> (forall x:set, x :e X -> (F x) :e U) -> (Repl F X) :e U)
  -> (GU N) c= U.

End TG.


From algebra Require Import Foundation.
From algebra.rings Require Ring Ideal RingHom.
From algebra Require Category.

Import Ring.Exports Ideal.Exports RingHom.Exports Category.Exports.

Section Quotient.
  Variable A : [Ring].
  Variable I : [Ideal: A].

  Local Open Scope ring_scope.

  Definition is_quotient (A_I : [Ring]) (e : [Ring] A A_I) : Prop :=
    ∀ B (f : [Ring] A B),
      (∀ x : A, I x → f x = 0)
      → exists! f_I : [Ring] A_I B, f_I ∘ e = f.

  Definition eqrel : EqRel A.
    unshelve econstructor.
    - move=> x y.
      exact: I (x + Ring.neg y).
    - split.
      + move=> x.
        autorewrite with ring.
        apply: Subgroup.zero.
      + move=> x y H.
        have: I (Ring.neg (x + Ring.neg y)).
        * by apply: Subgroup.neg.
        * by rewrite Ring.addC; autorewrite with ring.
      + move=> x y z H0 H1.
        replace (x + Ring.neg z) with (x + Ring.neg y + (y + Ring.neg z)).
        * by apply: Subgroup.add.
        * by rewrite
            -[(x + _) + _] Ring.addA
            [(Ring.neg y + (_ + _))] Ring.addA
            [Ring.neg y + y] Ring.addC Ring.negI Ring.addL.
  Defined.
End Quotient.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e383m187_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.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import coqutil.Byte.
Require Import coqutil.Word.Interface.
Require Import bedrock2.Semantics.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.ModOps.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Crypto.Bedrock.Specs.Field.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.ZeroBounds.

Section Representation.
  Context {p : Types.parameters} {field_parameters : FieldParameters}
          {p_ok : Types.ok}.
  Context (n : nat) (weight : nat -> Z)
          (loose_bounds tight_bounds : list (option zrange))
          (relax_bounds :
             forall X : list Z,
               list_Z_bounded_by tight_bounds X ->
               list_Z_bounded_by loose_bounds X).
  Existing Instance semantics_ok.

  Definition eval_words : list word -> F M_pos :=
    fun ws =>
      F.of_Z _ (Positional.eval weight n (map word.unsigned ws)).

  Definition eval_bytes : list byte -> F M_pos :=
    fun bs =>
      F.of_Z _ (Positional.eval
                           (ModOps.weight 8 1)
                           (Z.to_nat word_size_in_bytes)
                           (map byte.unsigned bs)).

  Local Instance frep : FieldRepresentation :=
    { felem := list word;
      feval := eval_words;
      feval_bytes := eval_bytes;
      felem_size_in_bytes := bytes_per_word Semantics.width * Z.of_nat n;
      FElem := Bignum n;
      bounds := list (option zrange);
      bounded_by :=
        fun bs ws =>
          list_Z_bounded_by bs (map word.unsigned ws);
      loose_bounds := loose_bounds;
      tight_bounds := tight_bounds;
    }.

  Local Instance frep_ok : FieldRepresentation_ok.
  Proof.
    constructor.
    { cbn [felem_size_in_bytes frep].
      push_Zmod. autorewrite with zsimplify_fast. reflexivity. }
    { cbv [Placeholder FElem felem_size_in_bytes frep]; repeat intro.
      assert (word_size_in_bytes = bytes_per_word width).
      { pose proof word.width_pos.
        rewrite word_size_in_bytes_eq; cbn [bytes_per].
        apply Z2Nat.id. cbv [bytes_per_word].
        Z.zero_bounds. }
      cbv [Lift1Prop.ex1]; split; intros;
        repeat match goal with
               | H : anybytes _ _ _ |- _ =>
                 apply Array.anybytes_to_array_1 in H
               | H : exists _, _ |- _ => destruct H
               | H : _ /\ _ |- _ => destruct H
               end.
      { match goal with
          | H : Array.array _ _ _ _ _ |- _ =>
            eapply Bignum_of_bytes with (n0:=n) in H;
              [ destruct H | (idtac + destruct Semantics.width_cases); nia.. ]
        end.
        eexists; eauto. }
      {
        pose proof word_size_in_bytes_pos.
        let H := match goal with
                 | H : Bignum _ _ _ _ |- _ => H end in
        eapply Bignum_to_bytes in H.
        sepsimpl.
        let H := match goal with
                 | H : Array.array _ _ _ _ _ |- _ => H end in
        eapply Array.array_1_to_anybytes in H.
        match goal with
        | H : anybytes ?p ?n1 ?m |- anybytes ?p ?n2 ?m =>
          replace n2 with n1 by nia; assumption
        end. } }
    { cbn [bounded_by frep]; intros.
      apply relax_bounds; auto. }
  Qed.
End Representation.


Theorem hoge : forall P Q R : Prop, P \/ ~(Q \/ R) -> (P \/ ~Q) /\ (P \/ ~R).
Proof.
  refine (fun P Q R => _).
  refine (fun H => _).
  refine (match H with
             | or_introl HP => _
             | or_intror HnQR => _
             end).
  -  refine (conj _ _).
    + refine (or_introl _).
      refine (HP).
    + refine (or_introl _).
      refine (HP).
  - refine (conj _ _).
    + refine (or_intror _).
      refine ((fun HQ : Q => _) : ~Q).
      refine (HnQR _).
      refine (or_introl _).
      refine (HQ).
    + refine (or_intror _).
      refine ((fun HR : R => _) : ~R).
      refine (HnQR _).
      refine (or_intror _).
      refine (HR).
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** A heap data structure. *)

(** The implementation uses splay heaps, following C. Okasaki,
    "Purely functional data structures", section 5.4.
    One difference: we eliminate duplicate elements.
    (If an element is already in a heap, inserting it again does nothing.)
*)

Require Import FunInd.
Require Import Coqlib.
Require Import FSets.
Require Import Ordered.

(* To avoid useless definitions of inductors in extracted code. *)
Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.

Module SplayHeapSet(E: OrderedType).

(** "Raw" implementation.  The "is a binary search tree" invariant
    is proved separately. *)

Module R.

Inductive heap: Type :=
  | Empty
  | Node (l: heap) (x: E.t) (r: heap).

Fixpoint partition (pivot: E.t) (h: heap) { struct h } : heap * heap :=
  match h with
  | Empty => (Empty, Empty)
  | Node a x b =>
      match E.compare x pivot with
      | EQ _ => (a, b)
      | LT _ =>
        match b with
        | Empty => (h, Empty)
        | Node b1 y b2 =>
            match E.compare y pivot with
            | EQ _ => (Node a x b1, b2)
            | LT _ =>
              let (small, big) := partition pivot b2
              in (Node (Node a x b1) y small, big)
            | GT _ =>
              let (small, big) := partition pivot b1
              in (Node a x small, Node big y b2)
            end
        end
     | GT _ =>
        match a with
        | Empty => (Empty, h)
        | Node a1 y a2 =>
            match E.compare y pivot with
            | EQ _ => (a1, Node a2 x b)
            | LT _ =>
              let (small, big) := partition pivot a2
              in (Node a1 y small, Node big x b)
            | GT _ =>
              let (small, big) := partition pivot a1
              in (small, Node big y (Node a2 x b))
            end
        end
    end
  end.

Definition insert (x: E.t) (h: heap) : heap :=
  let (a, b) := partition x h in Node a x b.

Fixpoint findMin (h: heap) : option E.t :=
  match h with
  | Empty => None
  | Node Empty x b => Some x
  | Node a x b => findMin a
  end.

Fixpoint deleteMin (h: heap) : heap :=
  match h with
  | Empty => Empty
  | Node Empty x b => b
  | Node (Node Empty x b) y c => Node b y c
  | Node (Node a x b) y c => Node (deleteMin a) x (Node b y c)
  end.

Fixpoint findMax (h: heap) : option E.t :=
  match h with
  | Empty => None
  | Node a x Empty => Some x
  | Node a x b => findMax b
  end.

Fixpoint deleteMax (h: heap) : heap :=
  match h with
  | Empty => Empty
  | Node b x Empty => b
  | Node b x (Node c y Empty) => Node b x c
  | Node a x (Node b y c) => Node (Node a x b) y (deleteMax c)
  end.

(** Induction principles for some of the operators. *)

Scheme heap_ind := Induction for heap Sort Prop.
Functional Scheme partition_ind := Induction for partition Sort Prop.
Functional Scheme deleteMin_ind := Induction for deleteMin Sort Prop.
Functional Scheme deleteMax_ind := Induction for deleteMax Sort Prop.

(** Specification *)

Fixpoint In (x: E.t) (h: heap) : Prop :=
  match h with
  | Empty => False
  | Node a y b => In x a \/ E.eq x y \/ In x b
  end.

(** Invariants *)

Fixpoint lt_heap (h: heap) (x: E.t) : Prop :=
  match h with
  | Empty => True
  | Node a y b => lt_heap a x /\ E.lt y x /\ lt_heap b x
  end.

Fixpoint gt_heap (h: heap) (x: E.t) : Prop :=
  match h with
  | Empty => True
  | Node a y b => gt_heap a x /\ E.lt x y /\ gt_heap b x
  end.

Fixpoint bst (h: heap) : Prop :=
  match h with
  | Empty => True
  | Node a x b => bst a /\ bst b /\ lt_heap a x /\ gt_heap b x
  end.

Definition le (x y: E.t) := E.eq x y \/ E.lt x y.

Lemma le_lt_trans:
  forall x1 x2 x3, le x1 x2 -> E.lt x2 x3 -> E.lt x1 x3.
Proof.
  unfold le; intros; intuition.
  destruct (E.compare x1 x3).
    auto.
    elim (@E.lt_not_eq x2 x3). auto. apply E.eq_trans with x1. apply E.eq_sym; auto. auto.
    elim (@E.lt_not_eq x2 x1). eapply E.lt_trans; eauto. apply E.eq_sym; auto.
    eapply E.lt_trans; eauto.
Qed.

Lemma lt_le_trans:
  forall x1 x2 x3, E.lt x1 x2 -> le x2 x3 -> E.lt x1 x3.
Proof.
  unfold le; intros; intuition.
  destruct (E.compare x1 x3).
    auto.
    elim (@E.lt_not_eq x1 x2). auto. apply E.eq_trans with x3. auto. apply E.eq_sym; auto.
    elim (@E.lt_not_eq x3 x2). eapply E.lt_trans; eauto. apply E.eq_sym; auto.
    eapply E.lt_trans; eauto.
Qed.

Lemma le_trans:
  forall x1 x2 x3, le x1 x2 -> le x2 x3 -> le x1 x3.
Proof.
  intros. destruct H. destruct H0. red; left; eapply E.eq_trans; eauto.
  red. right. eapply le_lt_trans; eauto. red; auto.
  red. right. eapply lt_le_trans; eauto.
Qed.

Lemma lt_heap_trans:
  forall x y, le x y ->
  forall h, lt_heap h x -> lt_heap h y.
Proof.
  induction h; simpl; intros.
  auto.
  intuition. eapply lt_le_trans; eauto.
Qed.

Lemma gt_heap_trans:
  forall x y, le y x ->
  forall h, gt_heap h x -> gt_heap h y.
Proof.
  induction h; simpl; intros.
  auto.
  intuition. eapply le_lt_trans; eauto.
Qed.

(** Properties of [partition] *)

Lemma In_partition:
  forall x pivot, ~E.eq x pivot ->
  forall h, bst h -> (In x h <-> In x (fst (partition pivot h)) \/ In x (snd (partition pivot h))).
Proof.
  intros x pivot NEQ h0. functional induction (partition pivot h0); simpl; intros.
- tauto.
- tauto.
- rewrite e3 in *; simpl in *; intuition.
- intuition. elim NEQ. eapply E.eq_trans; eauto.
- rewrite e3 in *; simpl in *; intuition.
- intuition. elim NEQ. eapply E.eq_trans; eauto.
- intuition.
- rewrite e3 in *; simpl in *; intuition.
- intuition. elim NEQ. eapply E.eq_trans; eauto.
- rewrite e3 in *; simpl in *; intuition.
Qed.

Lemma partition_lt:
  forall x pivot h,
  lt_heap h x -> lt_heap (fst (partition pivot h)) x /\ lt_heap (snd (partition pivot h)) x.
Proof.
  intros x pivot h0. functional induction (partition pivot h0); simpl; try tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
Qed.

Lemma partition_gt:
  forall x pivot h,
  gt_heap h x -> gt_heap (fst (partition pivot h)) x /\ gt_heap (snd (partition pivot h)) x.
Proof.
  intros x pivot h0. functional induction (partition pivot h0); simpl; try tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
- rewrite e3 in *; simpl in *; tauto.
Qed.

Lemma partition_split:
  forall pivot h,
  bst h -> lt_heap (fst (partition pivot h)) pivot /\ gt_heap (snd (partition pivot h)) pivot.
Proof.
  intros pivot h0. functional induction (partition pivot h0); simpl.
- tauto.
- intuition. eapply lt_heap_trans; eauto. red; auto.
- rewrite e3 in *; simpl in *. intuition.
  eapply lt_heap_trans; eauto. red; auto.
  eapply lt_heap_trans; eauto. red; auto.
- intuition.
  eapply lt_heap_trans; eauto. red; auto.
  eapply lt_heap_trans; eauto. red; auto.
  eapply gt_heap_trans with y; eauto. red. left. apply E.eq_sym; auto.
- rewrite e3 in *; simpl in *; intuition.
  eapply lt_heap_trans; eauto. red; auto.
  eapply gt_heap_trans with y; eauto. red; auto.
- intuition.
  eapply lt_heap_trans; eauto. red; auto.
  eapply gt_heap_trans; eauto. red; auto.
- intuition. eapply gt_heap_trans; eauto. red; auto.
- rewrite e3 in *; simpl in *. intuition.
  eapply lt_heap_trans with y; eauto. red; auto.
  eapply gt_heap_trans; eauto. red; auto.
- intuition.
  eapply lt_heap_trans with y; eauto. red; auto.
  eapply gt_heap_trans; eauto. red; auto.
  eapply gt_heap_trans with x; eauto. red; auto.
- rewrite e3 in *; simpl in *; intuition.
  eapply gt_heap_trans; eauto. red; auto.
  eapply gt_heap_trans; eauto. red; auto.
Qed.

Lemma partition_bst:
  forall pivot h,
  bst h ->
  bst (fst (partition pivot h)) /\ bst (snd (partition pivot h)).
Proof.
  intros pivot h0. functional induction (partition pivot h0); simpl; try tauto.
- rewrite e3 in *; simpl in *. intuition.
    apply lt_heap_trans with x; auto. red; auto.
    generalize (partition_gt y pivot b2 H7). rewrite e3; simpl. tauto.
- rewrite e3 in *; simpl in *. intuition.
    generalize (partition_gt x pivot b1 H3). rewrite e3; simpl. tauto.
    generalize (partition_lt y pivot b1 H4). rewrite e3; simpl. tauto.
- rewrite e3 in *; simpl in *. intuition.
    generalize (partition_gt y pivot a2 H6). rewrite e3; simpl. tauto.
    generalize (partition_lt x pivot a2 H8). rewrite e3; simpl. tauto.
- rewrite e3 in *; simpl in *. intuition.
    generalize (partition_lt y pivot a1 H3). rewrite e3; simpl. tauto.
    apply gt_heap_trans with x; auto. red; auto.
Qed.

(** Properties of [insert] *)

Lemma insert_bst:
  forall x h, bst h -> bst (insert x h).
Proof.
  intros.
  unfold insert. case_eq (partition x h). intros a b EQ; simpl.
  generalize (partition_bst x h H).
  generalize (partition_split x h H).
  rewrite EQ; simpl. tauto.
Qed.

Lemma In_insert:
  forall x h y, bst h -> (In y (insert x h) <-> E.eq y x \/ In y h).
Proof.
  intros. unfold insert.
  case_eq (partition x h). intros a b EQ; simpl.
  assert (E.eq y x \/ ~E.eq y x).
    destruct (E.compare y x); auto.
    right; red; intros. elim (E.lt_not_eq l). apply E.eq_sym; auto.
  destruct H0.
  tauto.
  generalize (In_partition y x H0 h H). rewrite EQ; simpl. tauto.
Qed.

(** Properties of [findMin] and [deleteMin] *)

Lemma deleteMin_lt:
  forall x h, lt_heap h x -> lt_heap (deleteMin h) x.
Proof.
Opaque deleteMin.
  intros x h0. functional induction (deleteMin h0) ; simpl; intros.
  auto.
  tauto.
  tauto.
  intuition. apply IHh. simpl. tauto.
Qed.

Lemma deleteMin_bst:
  forall h, bst h -> bst (deleteMin h).
Proof.
  intros h0. functional induction (deleteMin h0); simpl; intros.
  auto.
  tauto.
  tauto.
  intuition.
  apply IHh. simpl; auto.
  apply deleteMin_lt; auto. simpl; auto.
  apply gt_heap_trans with y; auto. red; auto.
Qed.

Lemma In_deleteMin:
  forall y x h,
  findMin h = Some x ->
  (In y h <-> E.eq y x \/ In y (deleteMin h)).
Proof.
Transparent deleteMin.
  intros y x h0. functional induction (deleteMin h0); simpl; intros.
  discriminate.
  inv H. tauto.
  inv H. tauto.
  destruct _x. inv H. simpl. tauto. generalize (IHh H). simpl. tauto.
Qed.

Lemma gt_heap_In:
  forall x y h, gt_heap h x -> In y h -> E.lt x y.
Proof.
  induction h; simpl; intros.
  contradiction.
  intuition. apply lt_le_trans with x0; auto. red. left. apply E.eq_sym; auto.
Qed.

Lemma findMin_min:
  forall x h, findMin h = Some x -> bst h -> forall y, In y h -> le x y.
Proof.
  induction h; simpl; intros.
  contradiction.
  destruct h1.
  inv H. simpl in *. intuition.
  red; left; apply E.eq_sym; auto.
  red; right. eapply gt_heap_In; eauto.
  assert (le x x1).
    apply IHh1; auto. tauto. simpl. right; left; apply E.eq_refl.
  intuition.
  apply le_trans with x1. auto.  apply le_trans with x0. simpl in H4. red; tauto.
  red; left; apply E.eq_sym; auto.
  apply le_trans with x1. auto. apply le_trans with x0. simpl in H4. red; tauto.
  red; right. eapply gt_heap_In; eauto.
Qed.

Lemma findMin_empty:
  forall h, h <> Empty -> findMin h <> None.
Proof.
  induction h; simpl; intros.
  congruence.
  destruct h1. congruence. apply IHh1. congruence.
Qed.

(** Properties of [findMax] and [deleteMax]. *)

Lemma deleteMax_gt:
  forall x h, gt_heap h x -> gt_heap (deleteMax h) x.
Proof.
Opaque deleteMax.
  intros x h0. functional induction (deleteMax h0); simpl; intros.
  auto.
  tauto.
  tauto.
  intuition. apply IHh. simpl. tauto.
Qed.

Lemma deleteMax_bst:
  forall h, bst h -> bst (deleteMax h).
Proof.
  intros h0. functional induction (deleteMax h0); simpl; intros.
  auto.
  tauto.
  tauto.
  intuition.
    apply IHh. simpl; auto.
    apply lt_heap_trans with x; auto. red; auto.
    apply deleteMax_gt; auto. simpl; auto.
Qed.

Lemma In_deleteMax:
  forall y x h,
  findMax h = Some x ->
  (In y h <-> E.eq y x \/ In y (deleteMax h)).
Proof.
Transparent deleteMax.
  intros y x h0. functional induction (deleteMax h0); simpl; intros.
  congruence.
  inv H. tauto.
  inv H. tauto.
  destruct _x1. inv H. simpl. tauto. generalize (IHh H). simpl. tauto.
Qed.

Lemma lt_heap_In:
  forall x y h, lt_heap h x -> In y h -> E.lt y x.
Proof.
  induction h; simpl; intros.
  contradiction.
  intuition. apply le_lt_trans with x0; auto. red. left. assumption.
Qed.

Lemma findMax_max:
  forall x h, findMax h = Some x -> bst h -> forall y, In y h -> le y x.
Proof.
  induction h; simpl; intros.
  contradiction.
  destruct h2.
  inv H. simpl in *. intuition.
  red; right. eapply lt_heap_In; eauto.
  red; left. auto.
  assert (le x1 x).
    apply IHh2; auto. tauto. simpl. right; left; apply E.eq_refl.
  intuition.
  apply le_trans with x1; auto.  apply le_trans with x0.
  red; right. eapply lt_heap_In; eauto.
  simpl in H6. red; tauto.
  apply le_trans with x1; auto. apply le_trans with x0.
  red; auto.
  simpl in H6. red; tauto.
Qed.

Lemma findMax_empty:
  forall h, h <> Empty -> findMax h <> None.
Proof.
  induction h; simpl; intros.
  congruence.
  destruct h2. congruence. apply IHh2. congruence.
Qed.

End R.

(** Wrapping in a dependent type *)

Definition t := { h: R.heap | R.bst h }.

(** Operations *)

Program Definition empty : t := R.Empty.

Program Definition insert (x: E.t) (h: t) : t := R.insert x h.
Next Obligation. apply R.insert_bst. apply proj2_sig. Qed.

Program Definition findMin (h: t) : option E.t := R.findMin h.

Program Definition deleteMin (h: t) : t := R.deleteMin h.
Next Obligation. apply R.deleteMin_bst. apply proj2_sig. Qed.

Program Definition findMax (h: t) : option E.t := R.findMax h.

Program Definition deleteMax (h: t) : t := R.deleteMax h.
Next Obligation. apply R.deleteMax_bst. apply proj2_sig. Qed.

(** Membership (for specification) *)

Program Definition In (x: E.t) (h: t) : Prop := R.In x h.

(** Properties of [empty] *)

Lemma In_empty: forall x, ~In x empty.
Proof.
  intros; red; intros.
  red in H. simpl in H. tauto.
Qed.

(** Properties of [insert] *)

Lemma In_insert:
  forall x h y,
  In y (insert x h) <-> E.eq y x \/ In y h.
Proof.
  intros. unfold In, insert; simpl. apply R.In_insert. apply proj2_sig.
Qed.

(** Properties of [findMin] *)

Lemma findMin_empty:
  forall h y, findMin h = None -> ~In y h.
Proof.
  unfold findMin, In; intros; simpl.
  destruct (proj1_sig h).
  simpl. tauto.
  exploit R.findMin_empty; eauto. congruence.
Qed.

Lemma findMin_min:
  forall h x y, findMin h = Some x -> In y h -> E.eq x y \/ E.lt x y.
Proof.
  unfold findMin, In; simpl. intros.
  change (R.le x y). eapply R.findMin_min; eauto. apply proj2_sig.
Qed.

(** Properties of [deleteMin]. *)

Lemma In_deleteMin:
  forall h x y,
  findMin h = Some x ->
  (In y h <-> E.eq y x \/ In y (deleteMin h)).
Proof.
  unfold findMin, In; simpl; intros.
  apply R.In_deleteMin. auto.
Qed.

(** Properties of [findMax] *)

Lemma findMax_empty:
  forall h y, findMax h = None -> ~In y h.
Proof.
  unfold findMax, In; intros; simpl.
  destruct (proj1_sig h).
  simpl. tauto.
  exploit R.findMax_empty; eauto. congruence.
Qed.

Lemma findMax_max:
  forall h x y, findMax h = Some x -> In y h -> E.eq y x \/ E.lt y x.
Proof.
  unfold findMax, In; simpl. intros.
  change (R.le y x). eapply R.findMax_max; eauto. apply proj2_sig.
Qed.

(** Properties of [deleteMax]. *)

Lemma In_deleteMax:
  forall h x y,
  findMax h = Some x ->
  (In y h <-> E.eq y x \/ In y (deleteMax h)).
Proof.
  unfold findMax, In; simpl; intros.
  apply R.In_deleteMax. auto.
Qed.

End SplayHeapSet.

(** Instantiation over type [positive] *)

Module PHeap := SplayHeapSet(OrderedPositive).


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Adjunction.Hom.
Require Export Category.Construction.Comma.
Require Export Category.Construction.Comma.Adjunction.Lib.
Require Export Category.Construction.Product.
Require Export Category.Instance.Cat.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.

Section AdjunctionComma.

Context {C : Category}.
Context {D : Category}.
Context {G : C ⟶ D}.
Context {F : D ⟶ C}.

(* Wikipedia: "Lawvere showed that the functors F : C → D and G : D → C are
   adjoint if and only if the comma categories (F ↓ Id[D]) and (Id[C] ↓ G) are
   isomorphic, and equivalent elements in the comma category can be projected
   onto the same element of C × D. This allows adjunctions to be described
   without involving sets, and was in fact the original motivation for
   introducing comma categories."

   From ncatlab: "To give an adjunction i ⊣ r it suffices to give, for each k
   : x → pe in B ↓ p, an object rk in E such that prk = x and an arrow irk =
   1x → k in B ↓ p that is universal from i to k."

   Lawvere's own statement of the theorem, from his thesis (page 40):

   "For each functor f : A ⟶ B, there exists a functor g : B ⟶ A such that g
   is adjoint to f iff for every object B ∈ |B| there exists an object A ∈ |A|
   and a map φ : B ~> Af in B such that for every object A′ ∈ |A| and every
   map x : B ~> A′f in B, there exists a unique map y : A ~> A′ in A such that
   x = φ(yf) in B."

   Repeating this using the names and syntax of this module:

   "∀ (G : C ⟶ D) (F : D ⟶ C), F ⊣ G ↔
      ∀ a : D, ∃ (b : C) (phi : a ~{D}~> G b),
        ∀ (b' : C) (psi : a ~{D}~> G b'),
          ∃! y : b ~{C}~> b',
            psi ≈ fmap[G] y ∘ phi" *)

Program Definition Adjunction_to_Comma (A : F ⊣ G) :
  @fibered_equivalence _ _ F G := {|
  fiber_iso := Comma_F_Id_Id_G_Iso A
|}.

Context (E : @fibered_equivalence _ _ F G).

Local Obligation Tactic := simpl; intros.

Program Instance comma_projF_iso (f : (F ↓ Id)) :
  `1 f ≅ `1 (to (fiber_iso E) f) := `1 (projF E) f.

(*
Program Instance comma_projF_iso_respects a b (f g : F a ~> b) :
  f ≈ g ->
  (a, b) ≅[D ∏ C] `1 (to (fiber_iso E) ((a, b); f)) ->
  (a, b) ≅[D ∏ C] `1 (to (fiber_iso E) ((a, b); g)).
Next Obligation.
  destruct H0; simpl in *.
  exact (fst (to H0), snd (to H0)).
Qed.
*)

Program Instance comma_projG_iso (f : (Id ↓ G)) :
  `1 f ≅ `1 (from (fiber_iso E) f) := `1 (projG E) f.

Definition comma_to a b (f : F a ~> b) : a ~> G b :=
  let g := ((a, b); f) in
  fmap[G] (snd (comma_projF_iso g)⁻¹)
    ∘ `2 (to (fiber_iso E) g)
    ∘ fst (to (comma_projF_iso g)).

Definition comma_from a b (f : a ~> G b) : F a ~> b :=
  let g := ((a, b); f) in
  snd (comma_projG_iso g)⁻¹
    ∘ `2 (from (fiber_iso E) g)
    ∘ fmap[F] (fst (to (comma_projG_iso g))).

Program Instance comma_to_respects a b :
  Proper (equiv ==> equiv) (comma_to a b).
Next Obligation.
  proper.
(*
  unfold comma_to.
  Notation "f ∘[ X ] g" :=
    (@compose _%category _%object X%object _%object f%morphism g%morphism)
    (at level 40, format "'[v' f '/'   ∘[  X  ] '//' g ']'") : morphism_scope.
  simpl.

  pose (snd (to (comma_projF_iso ((a, b); y)))
            ∘ y ∘ fmap[F] (fst (from (comma_projF_iso ((a, b); y))))) as g.
  given (hh : { f : (a ~{ D }~> fst `1 (to (fiber_iso E) ((a, b); y))) *
                    (b ~{ C }~> snd `1 (to (fiber_iso E) ((a, b); y)))
              & g ∘ fmap[F] (fst f) ≈ snd f ∘ x }).
    exists (fst (to (comma_projF_iso ((a, b); y))),
            snd (to (comma_projF_iso ((a, b); y)))).
    abstract (
      unfold g; simpl;
      rewrite <- !comp_assoc;
      rewrite <- !fmap_comp;
      srewrite (fst (iso_from_to (comma_projF_iso ((a, b); y))));
      rewrite fmap_id, id_right;
      rewrite X;
      reflexivity).
  destruct (`2 (projF E) ((a, b); x)
             ((fst `1 (to (fiber_iso E) ((a, b); y)),
               snd `1 (to (fiber_iso E) ((a, b); y))); g) hh).
  simpl in e, e0.
  unfold comma_projF_iso in *.
  rewrite e; clear e.
  comp_right.

  (* pose proof (`2 (@fmap _ _ (to (fiber_iso E)) *)
  (*                       ((a, b); x) *)
  (*                       ((fst `1 (to (fiber_iso E) ((a, b); y)), *)
  (*                         snd `1 (to (fiber_iso E) ((a, b); y))); g) hh)). *)
  (* simpl in X0. *)

  pose (snd (to (comma_projF_iso ((a, b); y)))
            ∘ y ∘ fmap[F] (fst (from (comma_projF_iso ((a, b); y))))) as h.
  given (ii : { f : (fst `1 (to (fiber_iso E) ((a, b); y)) ~{ D }~> a) *
                    (snd `1 (to (fiber_iso E) ((a, b); y)) ~{ C }~> b)
              & x ∘ fmap[F] (fst f) ≈ snd f ∘ h }).
    exists (fst (from (comma_projF_iso ((a, b); y))),
            snd (from (comma_projF_iso ((a, b); y)))).
    abstract (
      unfold h; simpl;
      rewrite !comp_assoc;
      srewrite (snd (iso_from_to (comma_projF_iso ((a, b); y))));
      rewrite id_left;
      rewrites.
      reflexivity).
  destruct (`2 (projF E) ((fst `1 (to (fiber_iso E) ((a, b); y)),
                           snd `1 (to (fiber_iso E) ((a, b); y))); h)
             ((a, b); x) ii).
  simpl in e, e1.
  unfold comma_projF_iso in *.
  rewrites.
  rewrite !fmap_comp.
  comp_left.

  pose proof (`2 (@fmap _ _ (to (fiber_iso E))
                        ((fst `1 (to (fiber_iso E) ((a, b); y)),
                          snd `1 (to (fiber_iso E) ((a, b); y))); h)
                        ((a, b); x) ii)).
  simpl in X.

  given (jj : { f : (a ~{ D }~> a) * (b ~{ C }~> b)
              & x ∘ fmap[F] (fst f) ≈ snd f ∘ y }).
    exists (id, id); abstract cat.
  pose proof (`2 (@fmap _ _ (to (fiber_iso E)) ((a, b); y) ((a, b); x) jj)).
  simpl in X1.
  rewrite !comp_assoc.
  rewrite <- fmap_comp.
*)

(*
  remember (fmap[G] (snd _ ∘ snd _)) as H.
  enough (H ≈ fmap[G] (snd `1 (@fmap _ _ (to (fiber_iso E))
                                     ((a, b); y) ((a, b); x) jj))).
    rewrites.
    rewrites.
    rewrite <- (id_right (`2 (to (fiber_iso E) ((a, b); x)))).
    comp_left.

  rewrites.
  apply fmap_respects.
  rewrite <- (id_left (snd _)).
  pose proof (snd (iso_to_from (comma_projF_iso ((a, b); x)))).
  unfold comma_projF_iso in X1; simpl in X1.
  rewrites.
  rewrite <- !comp_assoc.
  rewrite (comp_assoc (snd _) (snd _) (snd _)).
  rewrites.
  unfold jj.
*)
Admitted.

Program Instance comma_from_respects a b :
  Proper (equiv ==> equiv) (comma_from a b).
Next Obligation.
Admitted.

Theorem comma_to_from a b f : comma_to a b (comma_from a b f) ≈ f.
Proof.
Admitted.

Theorem comma_from_to a b f : comma_from a b (comma_to a b f) ≈ f.
Proof.
Admitted.

Program Definition comma_iso a b : F a ~> b ≊ a ~> G b := {|
  to   := {| morphism := comma_to   a b |};
  from := {| morphism := comma_from a b |}
|}.
Next Obligation. apply comma_to_from. Qed.
Next Obligation. apply comma_from_to. Qed.

Theorem comma_to_natural_dom a b c (f : F a ~> b) (g : c ~> a) :
  comma_to _ _ f ∘ g ≈ comma_to _ _ (f ∘ fmap[F] g).
Proof.
  unfold comma_to, comma_projF_iso.
  given (hh : { f0 : (c ~{ D }~> a) * (b ~{ C }~> b)
              & f ∘ fmap[F] (fst f0) ≈ snd f0 ∘ (f ∘ fmap[F] g) }).
    exists (g, id); abstract cat.
  destruct (`2 (projF E) ((c, b); f ∘ fmap[F] g) ((a, b); f) hh);
  simpl in e, e0; rewrite e at 1; clear e.
  rewrite <- !comp_assoc.
  rewrite (comp_assoc _ (fst _)).
  srewrite (fst (iso_to_from (comma_projF_iso ((a, b); f)))).
  rewrite id_left.
  comp_right.
  pose proof (`2 (@fmap _ _ (to (fiber_iso E))
                        ((c, b); f ∘ fmap[F] g) ((a, b); f) hh)).
  simpl in X.
  rewrite <- comp_assoc.
  rewrites.
  comp_right.
  rewrite <- fmap_comp.
  apply fmap_respects.
  symmetry.
  rewrite <- (id_left (snd _)).
  rewrites.
  comp_left.
  rewrite <- (id_right (snd _)) at 2.
  comp_left.
  sapply (snd (iso_to_from (comma_projF_iso ((c, b); f ∘ fmap[F] g)))).
Qed.

Theorem comma_to_natural_cod a b c (h : b ~{C}~> c) (f : F a ~> b) :
  fmap[G] h ∘ comma_to _ _ f ≈ comma_to _ _ (h ∘ f).
Proof.
  unfold comma_to, comma_projF_iso.
  given (hh : { f0 : (a ~{ D }~> a) * (b ~{ C }~> c)
              & h ∘ f ∘ fmap[F] (fst f0) ≈ snd f0 ∘ f }).
    exists (id, h); abstract cat.
  destruct (`2 (projF E) ((a, b); f) ((a, c); h ∘ f) hh);
  simpl in e, e0; rewrite e0 at 1; clear e0.
  rewrite !comp_assoc.
  rewrite <- fmap_comp.
  rewrite <- !comp_assoc.
  rewrite (comp_assoc _ (snd _)).
  srewrite (snd (iso_to_from (comma_projF_iso ((a, b); f)))).
  rewrite id_right.
  rewrite fmap_comp.
  comp_left.
  pose proof (`2 (@fmap _ _ (to (fiber_iso E))
                        ((a, b); f) ((a, c); h ∘ f) hh)).
  simpl in X.
  rewrite comp_assoc.
  rewrites.
  comp_left.
  symmetry.
  rewrite <- (id_right (fst _)).
  rewrites.
  comp_right.
  rewrite <- (id_left (fst `1 _)) at 2.
  comp_right.
  sapply (fst (iso_to_from (comma_projF_iso ((a, c); h ∘ f)))).
Qed.

Theorem comma_to_natural a b c d (h : b ~{C}~> c) (f : F a ~> b) (g : d ~> a) :
  fmap[G] h ∘ comma_to _ _ f ∘ g ≈ comma_to _ _ (h ∘ f ∘ fmap[F] g).
Proof.
  rewrite <- comp_assoc.
  rewrite comma_to_natural_dom.
  rewrite comma_to_natural_cod.
  rewrite comp_assoc.
  reflexivity.
Qed.

Theorem comma_from_natural_dom a b c (f : a ~> G b) (g : c ~> a) :
  comma_from _ _ f ∘ fmap[F] g ≈ comma_from _ _ (f ∘ g).
Proof.
Admitted.

Theorem comma_from_natural_cod a b c (h : b ~{C}~> c) (f : a ~> G b) :
  h ∘ comma_from _ _ f ≈ comma_from _ _ (fmap[G] h ∘ f).
Proof.
Admitted.

Theorem comma_from_natural a b c d (h : b ~{C}~> c) (f : a ~> G b) (g : d ~> a) :
  h ∘ comma_from _ _ f ∘ fmap[F] g ≈ comma_from _ _ (fmap[G] h ∘ f ∘ g).
Proof.
  rewrite <- comp_assoc.
  rewrite comma_from_natural_dom.
  rewrite comma_from_natural_cod.
  rewrite comp_assoc.
  reflexivity.
Qed.

Program Definition Adjunction_from_Comma : Adjunction_Hom F G := {|
  hom_adj :=
    {| to   := {| transform := fun X =>
         {| morphism := @comma_to _ _ |} |}
     ; from := {| transform := fun X =>
         {| morphism := @comma_from _ _ |} |} |}
|}.
Next Obligation. apply comma_to_natural. Qed.
Next Obligation. symmetry; apply comma_to_natural. Qed.
Next Obligation. apply comma_from_natural. Qed.
Next Obligation. symmetry; apply comma_from_natural. Qed.
Next Obligation. cat; apply (iso_to_from (comma_iso _ _) _). Qed.
Next Obligation. cat; apply (iso_from_to (comma_iso _ _) _). Qed.

End AdjunctionComma.