From st.STLCmuVS Require Import lang typing.
From st.STLCmu Require Import types.

Inductive expr_scoped (n : nat) : expr → Prop :=
 | Var_scoped x :
     x < n →
     expr_scoped n (Var x)
 | LetIn_scoped e1 e2 :
     expr_scoped n e1 →
     expr_scoped (S n) e2 →
     expr_scoped n (LetIn e1 e2)
 | Lam_scoped e :
     expr_scoped (S n) e →
     expr_scoped n (Lam e)
 | App_scoped e1 e2 :
     expr_scoped n e1 →
     expr_scoped n e2 →
     expr_scoped n (App e1 e2)
 | Lit_scoped (l : base_lit) :
     expr_scoped n (Lit l)
 | BinOp_scoped op e1 e2 :
     expr_scoped n e1 →
     expr_scoped n e2 →
     expr_scoped n (BinOp op e1 e2)
 | If_scoped e0 e1 e2 :
     expr_scoped n e0 →
     expr_scoped n e1 →
     expr_scoped n e2 →
     expr_scoped n (If e0 e1 e2)
 | Seq_scoped e1 e2 :
     expr_scoped n e1 →
     expr_scoped n e2 →
     expr_scoped n (Seq e1 e2)
 | Pair_scoped e1 e2 :
     expr_scoped n e1 →
     expr_scoped n e2 →
     expr_scoped n (Pair e1 e2)
 | Fst_scoped e :
     expr_scoped n e →
     expr_scoped n (Fst e)
 | Snd_scoped e :
     expr_scoped n e →
     expr_scoped n (Snd e)
 | InjL_scoped e :
     expr_scoped n e →
     expr_scoped n (InjL e)
 | InjR_scoped e :
     expr_scoped n e →
     expr_scoped n (InjR e)
 | Case_scoped e0 e1 e2 :
     expr_scoped n e0 →
     expr_scoped (S n) e1 →
     expr_scoped (S n) e2 →
     expr_scoped n (Case e0 e1 e2)
 | Fold_scoped e :
     expr_scoped n e →
     expr_scoped n (Fold e)
 | Unfold_scoped e :
     expr_scoped n e →
     expr_scoped n (Unfold e)
 | VirtStep_scoped e :
     expr_scoped n e →
     expr_scoped n (VirtStep e).

Lemma expr_Closed_n (e : expr) : ∀ n, Closed_n n e <-> expr_scoped n e.
Proof.
  induction e;
    (split;
     [ intro P; (try econstructor);
       try ((match goal with
            | H : ∀ n : nat, Closed_n n _ ↔ expr_scoped n _ |- _ => apply H
            end);
       closed_solver)
     | intro P; inversion P; intro σ; asimpl;
       repeat (match goal with
            | H : ∀ n : nat, Closed_n n _ ↔ expr_scoped n _ |- _ => rewrite (iffRL (H _) _)
            end);
       try done
    ]).
  - by apply Var_closed_n_lt.
  - by rewrite upn_lt.
Qed.

Lemma expr_typed_scoped Γ (e : expr) τ : typed Γ e τ → expr_scoped (length Γ) e.
Proof. intro de. apply expr_Closed_n. intro σ. by eapply typed_n_closed. Qed.

From st.STLCmuVS Require Import contexts.

Inductive ctx_item_scoped : ctx_item → nat → nat → Prop :=
  | CTX_Lam_scoped n :
      ctx_item_scoped CTX_Lam (S n) n
  | CTX_AppL_scoped n e2 :
      expr_scoped n e2 →
      ctx_item_scoped (CTX_AppL e2) n n
  | CTX_AppR_scoped n e1 :
      expr_scoped n e1 →
      ctx_item_scoped (CTX_AppR e1) n n
  | CTX_LetInL_scoped n e2 :
      expr_scoped (S n) e2 →
      ctx_item_scoped (CTX_LetInL e2) n n
  | CTX_LetInR_scoped n e1 :
      expr_scoped n e1 →
      ctx_item_scoped (CTX_LetInR e1) (S n) n
  | CTX_PairL_scoped n e2:
      expr_scoped n e2 →
      ctx_item_scoped (CTX_PairL e2) n n
  | CTX_PairR_scoped n e1 :
      expr_scoped n e1 →
      ctx_item_scoped (CTX_PairR e1) n n
  | CTX_Fst_scoped n :
      ctx_item_scoped (CTX_Fst) n n
  | CTX_Snd_scoped n :
      ctx_item_scoped (CTX_Snd) n n
  | CTX_InjL_scoped n :
      ctx_item_scoped (CTX_InjL) n n
  | CTX_InjR_scoped n :
      ctx_item_scoped (CTX_InjR) n n
  | CTX_CaseL_scoped n e1 e2 :
      expr_scoped (S n) e1 →
      expr_scoped (S n) e2 →
      ctx_item_scoped (CTX_CaseL e1 e2) n n
  | CTX_CaseM_scoped n e0 e2 :
      expr_scoped n e0 →
      expr_scoped (S n) e2 →
      ctx_item_scoped (CTX_CaseM e0 e2) (S n) n
  | CTX_CaseR_scoped n e0 e1 :
      expr_scoped n e0 →
      expr_scoped (S n) e1 →
      ctx_item_scoped (CTX_CaseR e0 e1) (S n) n
  | CTX_BinOpL_scoped n op e2 :
      expr_scoped n e2 →
      ctx_item_scoped (CTX_BinOpL op e2) n n
  | CTX_BinOpR_scoped n op e1 :
      expr_scoped n e1 →
      ctx_item_scoped (CTX_BinOpR op e1) n n
  | CTX_IfL_scoped n e1 e2 :
      expr_scoped n e1 →
      expr_scoped n e2 →
      ctx_item_scoped (CTX_IfL e1 e2) n n
  | CTX_IfM_scoped n e0 e2 :
      expr_scoped n e0 →
      expr_scoped n e2 →
      ctx_item_scoped (CTX_IfM e0 e2) n n
  | CTX_IfR_scoped n e0 e1 :
      expr_scoped n e0 →
      expr_scoped n e1 →
      ctx_item_scoped (CTX_IfR e0 e1) n n
  | CTX_Fold_scoped n :
      ctx_item_scoped CTX_Fold n n
  | CTX_Unfold_scoped n :
      ctx_item_scoped CTX_Unfold n n
  | CTX_VirtStep_scoped n :
      ctx_item_scoped CTX_VirtStep n n.

Notation "|s> n ⊢ₙₒ e" := (expr_scoped n e) (at level 74, n, e at next level).
Notation "|sCi> n ⊢ₙₒ Ci ☾ m ☽" := (ctx_item_scoped Ci m n) (at level 74, n, Ci, m at next level).

Lemma ctx_item_typed_scoped Γ τ Γ' τ' (Ci : ctx_item) : typed_ctx_item Ci Γ τ Γ' τ' → ctx_item_scoped Ci (length Γ) (length Γ').
Proof.
  intro dCi. destruct dCi; constructor; try by eapply expr_typed_scoped.
  change (S (length Γ)) with (length (τ :: Γ)); by eapply expr_typed_scoped.
  change (S (length Γ)) with (length (τ1 :: Γ)); by eapply expr_typed_scoped.
  change (S (length Γ)) with (length (τ2 :: Γ)); by eapply expr_typed_scoped.
  change (S (length Γ)) with (length (τ2 :: Γ)); by eapply expr_typed_scoped.
  change (S (length Γ)) with (length (τ1 :: Γ)); by eapply expr_typed_scoped.
Qed.

Lemma scoped_ctx_item_fill n m C e :
  |s> m ⊢ₙₒ e →
  |sCi> n ⊢ₙₒ C ☾ m ☽ →
  |s> n ⊢ₙₒ (fill_ctx_item C e).
Proof.
  induction C; simpl; intros;
    (match goal with
     | H : |sCi> _ ⊢ₙₒ _ ☾ _ ☽ |- _ => inversion H
     end); simplify_eq; try by econstructor.
Qed.

Inductive ctx_scoped : ctx → nat → nat → Prop :=
  | CTX_nil_scoped n :
    ctx_scoped [] n n
  | CTX_cons_scoped n1 n2 n3 k K :
    ctx_item_scoped k n2 n3 →
    ctx_scoped K n1 n2 →
    ctx_scoped (k :: K) n1 n3.

Notation "|sC> n ⊢ₙₒ C ☾ m ☽" := (ctx_scoped C m n) (at level 74, n, C, m at next level).

Lemma scoped_ctx_fill n m C e :
  |s> m ⊢ₙₒ e →
  |sC> n ⊢ₙₒ C ☾ m ☽ →
  |s> n ⊢ₙₒ (fill_ctx C e).
Proof.
  revert n. induction C.
  - intros. inversion H0. by subst.
  - intros. simpl. inversion H0. subst. eapply scoped_ctx_item_fill.
    eapply IHC; eauto. auto.
Qed.

Lemma ctx_typed_scoped Γ τ Γ' τ' (C : ctx) : typed_ctx C Γ τ Γ' τ' → ctx_scoped C (length Γ) (length Γ').
Proof.
  intro dC. induction dC; first constructor.
  simpl. econstructor. by eapply ctx_item_typed_scoped. auto.
Qed.


From Coq Require Import Program.Equality Lia.
From Paco Require Import paco.

From stbor.lang Require Import steps_wf steps_inversion.
From stbor.sim Require Import behavior global invariant sflib.

Set Default Proof Using "Type".

(* TODO: move *)
Lemma tc_inv_l
      A (R:relation A) x z
      (TC: tc R x z):
  exists y, rtc R x y /\ R y z.
Proof.
  induction TC.
  - esplits; eauto. reflexivity.
  - des. esplits; [|by eauto]. eapply rtc_l; eauto.
Qed.

(* TODO: move *)
Lemma strong_induction
      (P : nat -> Prop)
      (IH: forall (n:nat) (IH: forall (k:nat) (LT: (k < n)%nat), P k), P n):
  forall n : nat, P n.
Proof.
  i. cut (forall (m k:nat), (k < m -> P k)%nat); [by eauto|].
  induction m.
  - i. nia.
  - i. apply lt_le_S in H. inv H; eauto.
Qed.

(** A classically provable assumption: each program is either never-stuck or it can get stuck. *)
Definition stuck_decidable_1 prog: Prop :=
  ∀ e σ, never_stuck prog e σ \/
                    exists e' σ', (e, σ) ~{prog}~>* (e', σ') /\
                             ~ terminal e' /\
                             ~ reducible prog e' σ'.
Definition stuck_decidable: Prop := ∀ prog, stuck_decidable_1 prog.

Lemma classically_stuck_decidable :
  (∀ P, P ∨ ¬P) → stuck_decidable.
Proof.
  intros EM prog e σ.
  set RHS := exists _, _. destruct (EM RHS) as [POS|NEG]; first by right.
  left. intros ???. destruct (EM (terminal e' ∨ reducible prog e' σ')) as [POS2|NEG2]; first done.
  exfalso. apply NEG. eexists _, _. split; first eassumption.
  split; intros ?; apply NEG2; auto.
Qed.

Lemma adequacy_never_stuck
      prog_src
      prog_tgt idx conf_src conf_tgt
      (SIM: sim prog_src prog_tgt idx conf_src conf_tgt)
      (WFS: Wf conf_src.2) (WFT: Wf conf_tgt.2)
      (NEVERSTUCK: never_stuck prog_src conf_src.1 conf_src.2)
  : behave tstep term prog_tgt conf_tgt <1= behave tstep term prog_src conf_src.
Proof.
  revert idx conf_src conf_tgt SIM WFS WFT NEVERSTUCK. pcofix CIH. intros.
  punfold PR. inv PR.
  rename x2 into obs. rename s' into conf'_tgt. revert idx conf_src WFS NEVERSTUCK SIM MAT.
  dependent induction TAU; cycle 1.
  - rename x into conf_tgt.
    rename y into conf'_tgt.
    rename z into conf''_tgt.
    i. punfold SIM. exploit SIM; auto.
    clear SIM. intro SIM. inv SIM.
    have WFT': Wf conf'_tgt.2 by eapply tstep_wf; eauto.
    exploit sim_step; eauto. i. revert sim_stuck. des.
    + inv x0; ss.
      rename eσ2_src into conf'_src.
      have WFS' : Wf conf'_src.2 by eapply tstep_tc_wf; eauto.
      exploit (IHTAU WFT' idx2 _ WFS'); eauto.
      { eapply never_stuck_tstep_tc'; eauto. }
      intro BEH. punfold BEH. inv BEH.
      pfold. econs; [|by eauto]. etrans; eauto. apply tc_rtc. ss.
    + inv x0; ss.
      rename eσ2_src into conf'_src.
      exploit (IHTAU WFT' idx2 _ WFS); eauto.
  - intros idx. revert x WFT.
    induction idx using strong_induction. i.
    punfold SIM. exploit SIM; auto.
    clear SIM. intro SIM. inv SIM. inv MAT.
    + exfalso. destruct sim_stuck as [[v TE]|ST].
      * by apply (NT v).
      * unfold reducible in ST. des. eapply NS.
        destruct x. eauto.
    + clear sim_stuck. exploit sim_terminal; eauto. i. des.
      pfold. econs; eauto.
      unfold terminal in *. des.
      econs 2. unfold term. erewrite x2; eauto.
    + pclearbot. exploit sim_step; eauto. i. revert sim_stuck.
      rename s' into conf'_tgt.
      have WFT': Wf conf'_tgt.2 by eapply tstep_wf; eauto.
      des.
      * inv x1; ss.
        rename eσ2_src into conf'_src.
        exploit (CIH idx2 conf'_src conf'_tgt); eauto.
        { by eapply tstep_tc_wf; eauto. }
        { by eapply never_stuck_tstep_tc'; eauto. }
        intros ?.
        apply tc_inv_l in x0. des.
        pfold. econs; eauto.
      * inv x1; ss.
        rename eσ2_src into conf'_src.
        exploit (IH idx2 x0 conf'_tgt WFT' conf'_src); eauto.
        punfold INF. inv INF. inv TAU; eauto.
        econs 3; eauto.
Qed.

Lemma adequacy_classical
      prog_src
      prog_tgt idx conf_src conf_tgt
      `{NSD: stuck_decidable_1 prog_src}
      (SIM: sim prog_src prog_tgt idx conf_src conf_tgt)
      (WFS: Wf conf_src.2)
      (WFT: Wf conf_tgt.2)
  : behave tstep term prog_tgt conf_tgt <1= behave tstep term prog_src conf_src.
Proof.
  destruct (NSD conf_src.1 conf_src.2); cycle 1.
  { i. des. destruct conf_src as [e σ]. ss.
    pfold. econs; eauto. econs 1.
    - ii. eapply H0. unfold terminal, term in *. rewrite H2. eauto.
    - ii. apply H1. unfold reducible. destruct s'. eauto.
  }
  eapply adequacy_never_stuck; eauto.
Qed.


(* *********************************************************************************** *)
(** op1 bicategory.

    Bicategory obtained by formally reversing 1-arrows.

    Benedikt Ahrens, Marco Maggesi
    June 2018                                                                          *)
(* *********************************************************************************** *)

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.opp_precat.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.

Local Open Scope cat.

Definition op1_2cell_struct (C : prebicat_1_id_comp_cells)
  : prebicat_2cell_struct (opp_precat_data C)
  := λ (a b : C) (f g : C ⟦ b, a ⟧), f ==> g.

Definition op1_prebicat_1_id_comp_cells (C : prebicat_1_id_comp_cells)
  : prebicat_1_id_comp_cells
  := (opp_precat_data C),, op1_2cell_struct C.

Definition op1_prebicat_data (C : prebicat_data)
  : prebicat_data.
Proof.
  exists (op1_prebicat_1_id_comp_cells C).
  red. cbn. unfold op1_2cell_struct.
  repeat use make_dirprod; intros *.
  - apply id2.
  - apply runitor.
  - apply lunitor.
  - apply rinvunitor.
  - apply linvunitor.
  - apply lassociator.
  - apply rassociator.
  - intros α β. exact ( α • β ).
  - intros α. exact (α ▹ f).
  - intros α. exact (g ◃ α).
Defined.

Lemma op1_prebicat_laws (C : prebicat) : prebicat_laws (op1_prebicat_data C).
Proof.
  red. cbn. unfold op1_2cell_struct. cbn.
  repeat use tpair; cbn; intros *.
  - apply id2_left.
  - apply id2_right.
  - apply vassocr.
  - apply id2_rwhisker.
  - apply lwhisker_id2.
  - apply rwhisker_vcomp.
  - apply lwhisker_vcomp.
  - apply vcomp_runitor.
  - apply vcomp_lunitor.
  - apply rwhisker_rwhisker_alt.
  - apply pathsinv0, rwhisker_lwhisker_rassociator.
  - apply lwhisker_lwhisker_rassociator.
  - apply pathsinv0, vcomp_whisker.
  - apply runitor_rinvunitor.
  - apply rinvunitor_runitor.
  - apply lunitor_linvunitor.
  - apply linvunitor_lunitor.
  - apply rassociator_lassociator.
  - apply lassociator_rassociator.
  - apply lunitor_lwhisker.
  - apply rassociator_rassociator.
Qed.

Definition op1_prebicat (C : prebicat) : prebicat
  := op1_prebicat_data C,, op1_prebicat_laws C.

Definition op1_isaset_cells (C : bicat) : isaset_cells (op1_prebicat C)
  := λ (a b : C) (f g : C ⟦ b, a ⟧), cellset_property f g.

Definition op1_bicat (C : bicat) : bicat
  := op1_prebicat C,, op1_isaset_cells C.

Definition op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell
           {C : bicat}
           {X Y : op1_bicat C}
           {f g : X --> Y}
           (α : f ==> g)
  : is_invertible_2cell α → @is_invertible_2cell C Y X f g α.
Proof.
  intros Hα.
  use tpair.
  - apply Hα.
  - split ; apply Hα.
Defined.

Definition bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell
           {C : bicat}
           {X Y : op1_bicat C}
           {f g : X --> Y}
           (α : f ==> g)
  : @is_invertible_2cell C Y X f g α → is_invertible_2cell α.
Proof.
  intros Hα.
  use tpair.
  - apply Hα.
  - split ; apply Hα.
Defined.

Definition op1_bicat_is_invertible_2cell_is_bicat_is_invertible_2cell
           {C : bicat}
           {X Y : op1_bicat C}
           {f g : X --> Y}
           (α : f ==> g)
  : @is_invertible_2cell C Y X f g α ≃ is_invertible_2cell α.
Proof.
  use weqimplimpl.
  - exact (bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell α).
  - exact (op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell α).
  - apply isaprop_is_invertible_2cell.
  - apply isaprop_is_invertible_2cell.
Defined.

Definition bicat_invertible_2cell_is_op1_bicat_invertible_2cell
           {C : bicat}
           {X Y : op1_bicat C}
           (f g : X --> Y)
  : @invertible_2cell C Y X f g ≃ invertible_2cell f g.
Proof.
  use weqfibtototal.
  intro α.
  apply op1_bicat_is_invertible_2cell_is_bicat_is_invertible_2cell.
Defined.

Definition op1_bicat_left_adjoint_equivalence_to_bicat_left_adjoint_equivalence
           {C : bicat}
           {X Y : op1_bicat C}
           (f : X --> Y)
  : left_adjoint_equivalence f → @left_adjoint_equivalence C Y X f.
Proof.
  intros Hf.
  use tpair.
  - use tpair.
    + exact (left_adjoint_right_adjoint Hf).
    + split.
      * exact ((left_equivalence_counit_iso Hf)^-1).
      * exact ((left_equivalence_unit_iso Hf)^-1).
  - split ; split.
    + use inv_cell_eq ; cbn.
      * is_iso.
        ** apply op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell.
           is_iso.
        ** apply op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell.
           is_iso.
      * is_iso.
      * cbn.
        rewrite !vassocr.
        exact (internal_triangle1 Hf).
    + use inv_cell_eq ; cbn.
      * is_iso.
        ** apply op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell.
           is_iso.
        ** apply op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell.
           is_iso.
      * is_iso.
      * cbn.
        rewrite !vassocr.
        exact (internal_triangle2 Hf).
    + cbn.
      apply op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell.
      is_iso.
    + cbn.
      apply op1_bicat_is_invertible_2cell_to_bicat_is_invertible_2cell.
      is_iso.
Defined.

Definition bicat_left_adjoint_equivalence_to_op1_bicat_left_adjoint_equivalence
           {C : bicat}
           {X Y : op1_bicat C}
           (f : X --> Y)
  : @left_adjoint_equivalence C Y X f → left_adjoint_equivalence f.
Proof.
  intros Hf.
  use tpair.
  - use tpair.
    + exact (left_adjoint_right_adjoint Hf).
    + split.
      * exact ((left_equivalence_counit_iso Hf)^-1).
      * exact ((left_equivalence_unit_iso Hf)^-1).
  - split ; split.
    + use inv_cell_eq ; cbn.
      * apply bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell.
        is_iso.
      * apply bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell.
        is_iso.
      * cbn.
        rewrite !vassocr.
        exact (internal_triangle1 Hf).
    + use inv_cell_eq ; cbn.
      * apply bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell.
        is_iso.
      * apply bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell.
        is_iso.
      * cbn.
        rewrite !vassocr.
        exact (internal_triangle2 Hf).
    + cbn.
      apply bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell.
      is_iso.
    + cbn.
      apply bicat_is_invertible_2cell_to_op1_bicat_is_invertible_2cell.
      is_iso.
Defined.

Definition op1_bicat_left_adjoint_equivalence_is_bicat_left_adjoint_equivalence
           {C : bicat}
           {X Y : op1_bicat C}
           (f : X --> Y)
  : @left_adjoint_equivalence C Y X f ≃ left_adjoint_equivalence f.
Proof.
  use make_weq.
  - exact (bicat_left_adjoint_equivalence_to_op1_bicat_left_adjoint_equivalence f).
  - use isweq_iso.
    + exact (op1_bicat_left_adjoint_equivalence_to_bicat_left_adjoint_equivalence f).
    + intros x.
      use subtypePath.
      * intro.
        do 2 apply isapropdirprod ; try (apply C) ; apply isaprop_is_invertible_2cell.
      * apply idpath.
    + intros x.
      use subtypePath.
      * intro.
        do 2 apply isapropdirprod ; try (apply C) ; apply isaprop_is_invertible_2cell.
      * apply idpath.
Defined.

Definition bicat_adjoint_equivalence_is_op1_bicat_adjoint_equivalence
           {C : bicat}
           (X Y : op1_bicat C)
  : @adjoint_equivalence C Y X ≃ adjoint_equivalence X Y.
Proof.
  use weqfibtototal.
  intro α.
  apply op1_bicat_left_adjoint_equivalence_is_bicat_left_adjoint_equivalence.
Defined.


Require Import ssreflect.

Axiom v1 : nat -> bool.

Section Foo.

Variable v2 : nat -> bool.

Lemma test (v3 : nat -> bool) (v4 : bool -> bool) (v5 : bool -> bool) : nat -> nat -> nat -> nat -> True.
Proof.
move=> {}/v1 b1 {}/v2 b2 {}/v3 b3 {}/v2/v4/v5 b4.
Check b1 : bool.
Check b2 : bool.
Check b3 : bool.
Check b4 : bool.
Fail Check v3.
Fail Check v4.
Fail Check v5.
Check v2 : nat -> bool.
by [].
Qed.

End Foo.


From Undecidability.H10 Require Import H10 H10_undec H10p Reductions.H10_to_H10p.
From Undecidability.Synthetic Require Import Undecidability.
Require Import Fin.
Local Set Implicit Arguments.

(* Solvability of Diophantine equations without parameters is undecidable *)

Theorem H10p_undec :
  undecidable H10p.
Proof.
  apply (undecidability_from_reducibility H10_undec). exact Reductions.H10_to_H10p.reduction.
Qed.


Require Import FOL.
Require Import Deduction.
Require Import Tarski.
Require Import ProofMode.
Require Import ZF.
Require Import Equations.Equations Equations.Prop.DepElim.
Require Import String.
Require Import List.
Import ListNotations.

Open Scope string_scope.

Section ZF.

Variable p : peirce.

Instance eqdec_funcs : EqDec ZF_func_sig.
Proof. intros x y; decide equality. Qed.

Instance eqdec_preds : EqDec ZF_pred_sig.
Proof. intros x y; decide equality. Qed.

Ltac custom_fold ::= fold sub in *.
Ltac custom_unfold ::= unfold sub in *.

Definition ax_refl := ∀ $0 ≡ $0.
Definition ax_sym := ∀ ∀ $1 ≡ $0 --> $0 ≡ $1.
Definition ax_trans := ∀ ∀ ∀ $2 ≡ $1 --> $1 ≡ $0 --> $2 ≡ $0.
Definition ax_eq_elem := ∀ ∀ ∀ ∀ $3 ≡ $1 --> $2 ≡ $0 --> $3 ∈ $2 --> $1 ∈ $0.

Definition ZF := ax_ext::ax_eset::ax_pair::ax_union::ax_power::ax_om1::ax_om2::ax_refl::ax_sym::ax_trans::ax_eq_elem::nil.

Program Instance ZF_Leibniz : Leibniz ZF_func_sig ZF_pred_sig.
Next Obligation. exact equal. Defined.
Next Obligation. exact ZF. Defined.
Next Obligation. exact (fun phi => phi el ZF). Defined.
Next Obligation. Admitted.
Next Obligation. Admitted.
Next Obligation. Admitted.

Lemma ZF_sub_pair' x y x' y' :
  ZF ⊢ (x ≡ x' --> y ≡ y'--> sub ({x; y}) ({x'; y'})).
Proof.
  fstart. fintros "H1" "H2" "z". fintros "H3".
  fapply ax_pair. frewrite <- "H1". frewrite <- "H2".
  fapply ax_pair. ctx.
Qed.

Lemma ZF_eq_pair' x y x' y' :
  ZF ⊢ (x ≡ x' --> y ≡ y'--> {x; y} ≡ {x'; y'}).
Proof.
  fstart. fintros "H1" "H2". fapply ax_ext.
  - fapply ZF_sub_pair'; ctx.
  - fapply ZF_sub_pair'; fapply ax_sym; ctx.
Qed.

Lemma ZF_union_el' x y z :
  ZF ⊢ (y ∈ x ∧ z ∈ y --> z ∈ ⋃ x).
Proof.
  fstart. fintros "[H1 H2]". fapply ax_union. fexists y. fsplit; ctx.
Qed.

Lemma ZF_sub_union x y :
  ZF ⊢ (x ≡ y --> (⋃ x) ⊆ (⋃ y)).
Proof.
  fstart. fintros "H" "z". frewrite "H". fintros; ctx.
Qed.

Lemma ZF_eq_union x y :
  ZF ⊢ (x ≡ y --> ⋃ x ≡ ⋃ y).
Proof.
  fstart. fintros "H". frewrite "H". fapply ax_refl.
Qed.

Lemma ZF_bunion_el' x y z :
  ZF ⊢ ((z ∈ x ∨ z ∈ y) --> z ∈ x ∪ y).
Proof.
  fstart. fintros "[H|H]".
  - fapply ax_union. fexists x. fsplit. fapply ax_pair. fleft. fapply ax_refl. ctx.
  - fapply ax_union. fexists y. fsplit. fapply ax_pair. fright. fapply ax_refl. ctx.
Qed.

Lemma ZF_bunion_inv' x y z :
  ZF ⊢ (z ∈ x ∪ y --> z ∈ x ∨ z ∈ y).
Proof.
  fstart. fintros "H". fapply ax_union in "H" as "[a [H1 H2]]".
  feapply ax_pair in "H1" as "[H1|H1]".
  - fleft. frewrite <- "H1". ctx.
  - fright. frewrite <- "H1". ctx.
Qed.

Lemma ZF_eq_bunion x y x' y' :
  ZF ⊢ (x ≡ x' --> y ≡ y' --> x ∪ y ≡ x' ∪ y').
Proof.
  fstart. fintros "H1" "H2". frewrite "H1". frewrite "H2". fapply ax_refl.
Qed.

Lemma ZF_sig_el x :
   ZF ⊢ (x ∈ σ x).
Proof.
  fapply ZF_bunion_el'. fright. fapply ax_pair. fleft. fapply ax_refl.
Qed.

Lemma ZF_eq_sig x y :
  ZF ⊢ (x ≡ y --> σ x ≡ σ y).
Proof.
  fstart. fintros "H". frewrite "H". fapply ax_refl.
Qed.

Lemma ZF_bunion_el1 x y z :
  ZF ⊢ (z ∈ x --> z ∈ x ∪ y).
Proof.
  fstart. fintros. fapply ax_union. fexists x. fsplit.
  - fapply ax_pair. fleft. fapply ax_refl.
  - ctx.
Qed.

Lemma ZF_bunion_el2 x y z :
  ZF ⊢ (z ∈ y --> z ∈ x ∪ y).
Proof.
  fstart. fintro. fapply ax_union. fexists y. fsplit.
  fapply ax_pair. fright. fapply ax_refl. ctx.
Qed.

Lemma bunion_eset x :
   ZF ⊢ (∅ ∪ x ≡ x).
Proof.
  fstart. fapply ax_ext.
  - fintros "y" "H". fapply ZF_bunion_inv' in "H" as "[|]".
    + fexfalso. feapply ax_eset. ctx.
    + ctx.
  - fintros "y" "H". fapply ZF_bunion_el'. fright. ctx.
Qed.

Lemma bunion_swap x y z :
  ZF ⊢ ((x ∪ y) ∪ z ≡ (x ∪ z) ∪ y).
Proof.
  fstart. fapply ax_ext.
  - fintros "a" "H". fapply ZF_bunion_inv' in "H" as "[|]".
    + fapply ZF_bunion_inv' in "H" as "[H|H]".
      * fapply ZF_bunion_el'. fleft. fapply ZF_bunion_el'. fleft. ctx.
      * fapply ZF_bunion_el'. fright. ctx.
    + fapply ZF_bunion_el'. fleft. fapply ZF_bunion_el'. fright. ctx.
  - fintros "a" "H". fapply ZF_bunion_inv' in "H" as "[|]".
    + fapply ZF_bunion_inv' in "H" as "[H|H]".
      * fapply ZF_bunion_el'. fleft. fapply ZF_bunion_el'. fleft. ctx.
      * fapply ZF_bunion_el'. fright. ctx.
    + fapply ZF_bunion_el'. fleft. fapply ZF_bunion_el'. fright. ctx.
Qed.


Require Import Leapfrog.Benchmarks.ProofHeader.
Require Import Leapfrog.Benchmarks.Ethernet.

Declare ML Module "mirrorsolve".
SetSMTSolver "cvc4".
SetSMTLang "BV".

Lemma ethernet_equiv:
  lang_equiv_state
    (P4A.interp Reference.aut)
    (P4A.interp Combined.aut)
    Reference.SPref
    Combined.Parse.
Proof.
  solve_lang_equiv_state_axiom Reference.state_eqdec Combined.state_eqdec false.
Time Qed.


Require Import isla.isla.
Require Import isla.riscv64.riscv64.
Require Export isla.instructions.binary_search_riscv64.a90.

Lemma a90_spec `{!islaG Σ} `{!threadG} pc:
  instr pc (Some a90) -∗
  instr_body pc (ld_spec pc "x8" "x2" (48)).
Proof.
  iStartProof.
  repeat liAStep; liShow.
  Unshelve. all: prepare_sidecond.
  all: bv_solve.
Qed.

Definition a90_spec_inst `{!islaG Σ} `{!threadG} pc :=
  entails_to_simplify_hyp 0 (a90_spec pc).
Global Existing Instance a90_spec_inst.


(** * Syntax for Object Ligics (OL).

This file defines the general requirements imposed on the syntax of
OLs to prove cut-elimination.

 *)

Require Export MMLL.Misc.Hybrid.
Require Export MMLL.SL.FLLTactics.
Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

(** ** Object Logic Signature *)

(** This signature includes the types for the Object Level quantifiers
as well as the definitions for the binary and unary connectives and the
quantifiers. We assume that these types will be filled in by a Coq
inductive Set, e.g.,

[OLType := nat],
[Inductive connectives := cand | cor | cimp . ], and
[Inductive quantifiers := qex | qall .
 *)

Class OLSyntax :=
  {
    OLType:Set;
    constants : Set ; (* 0 ary connectives *)
    uconnectives : Set ; (* unary connectives *)
    connectives : Set ; (* binary connectives *)
    quantifiers : Set (* quantifiers *)
  }.

(** ** Definition of the OL Syntax  *)

(** This module defines the [con] type needed in [Hybrid]. Such type
includes constructors for the atoms of the Object Logic, the binary
and unary connectives and also the quantifiers (of the object logic).
Measures and constructors for those types are also provided *)

Section OLSyntax.
  Context `{OL: OLSyntax}.

  (** Syntax of the Object logic *)
  Inductive Econ: Set :=
  | oo_cons : constants -> Econ
  | oo_un : uconnectives -> Econ
  | oo_bin : connectives -> Econ (* binary connectives *)
  | oo_q : quantifiers -> Econ (* quantifiers *)
  | oo_atom : nat -> Econ (* names for atoms *)
  | oo_term : OLType -> Econ    (* Coercion --terms *)
  .

  (** Notation for Syntax *)
  Definition uexp : Set := expr Econ.
  Definition Var : var -> uexp := (VAR Econ).
  Definition Bnd : bnd -> uexp := (BND Econ).

  (** Terms *)
  Definition t_term (t:OLType)   :=  (CON (oo_term  t)) .
  (** Atoms  *)
  Definition t_atom (id:nat) (A:uexp)  := APP (CON (oo_atom  id)) A.  (* atoms *)

    (** constants *)
  Definition t_cons (lab :constants)  := CON (oo_cons lab) .

  (* Unary connectives *)
  Definition t_ucon (lab : uconnectives) : uexp -> uexp := fun M1:uexp => APP (CON ( (oo_un lab ))) M1 .

  (** Binnary connectives *)
  Definition t_bin (lab : connectives) : uexp -> uexp -> uexp  :=
    fun M1:uexp => fun M2:uexp => (APP (APP (CON (oo_bin lab )) M1) M2).
  (** Quantifiers *)
  Definition t_quant (lab : quantifiers) : (uexp -> uexp) -> uexp :=
    fun M:uexp->uexp => (APP (CON (oo_q lab)) (lambda M)).

  (** *** Well-formedness conditions *)
  Inductive isOLTerm : uexp -> Prop :=
  | isOLTermT  : forall t, isOLTerm (t_term  t).

  Inductive isOLAtom : uexp -> Prop :=
  | isOLAtomAt : forall t id , isOLTerm t -> isOLAtom (t_atom id t).

  Inductive isOLConstant : uexp -> Prop :=
  | isOLCons : forall id , isOLConstant (t_cons id)
  .

  Inductive isOLFormula : uexp -> Prop :=
  | isFAtom : forall t id , isOLTerm t -> isOLFormula (t_atom id t)
  | isFCons : forall id , isOLConstant id -> isOLFormula id
  | isFUn : forall (lab : uconnectives) F ,
      isOLFormula F ->  isOLFormula ( t_ucon lab F)
  | isFBin : forall (lab : connectives) F G,
      isOLFormula F -> isOLFormula G -> isOLFormula ( t_bin lab F G)
  | isFQ : forall lab (FX : uexp -> uexp),
      uniform FX -> (forall (t:uexp), proper t -> isOLFormula (FX t)) ->
      isOLFormula (t_quant lab FX) .

  (** Well formendness conditions for lists of formulas and list of judgments *)
  Definition isOLFormulaL  L : Prop := Forall isOLFormula L.
   Global Instance perm_IsOLFormulaL  :
      Proper (@Permutation uexp ==> Basics.impl)
             (isOLFormulaL ).
    Proof.
      unfold Proper; unfold respectful; unfold Basics.impl.
      intros.
      unfold isOLFormulaL.
      rewrite <- H;auto.
    Qed.

  Hint Constructors isOLTerm isOLAtom isOLConstant isOLFormula : core.
  Hint Unfold isOLFormulaL : core.

  (* *** Complexity of OL formulas *)

  (** We count the number of constructors (CON) in the
  expression. Note that the measure of a formula is independent of the
  terms in the atoms *)

  Inductive lengthUexp : uexp -> nat -> Prop :=
  | l_Var : forall (v:var), lengthUexp (Var v) 0
  | l_t_term : forall (t:OLType), lengthUexp (t_term t) 0
  | l_t_atomU : forall (id:nat) (A:uexp), lengthUexp (t_atom id A) 1
  | l_cons : forall id, lengthUexp (t_cons id) 1
  | l_ucon : forall (lab:uconnectives) (M1:uexp) (n1:nat),
      lengthUexp M1 n1 ->  lengthUexp (t_ucon lab M1) (S n1)
  | l_tbin : forall (lab:connectives) (M1 M2:uexp) (n1 n2:nat),
      lengthUexp M1 n1 -> lengthUexp M2 n2 ->
      lengthUexp (t_bin lab M1 M2) (S (n1 + n2))
  | l_tall : forall (lab:quantifiers) (M:uexp -> uexp) (n:nat),
      uniform M -> lengthUexp (M (Var 0%nat)) n -> lengthUexp (t_quant lab M) (S n).

  (** Some results regarding the length of formulas *)

  Lemma LengthTerm : forall F, isOLTerm F -> lengthUexp F 0.
    intros.
    inversion H;subst;clear H;constructor.
  Qed.

  Lemma LengthFormula : forall F n, isOLFormula F -> lengthUexp F n -> n > 0.
    intros.
    induction H;simpl.
    - inversion H0; lia.
    - inversion H;subst. inversion H0;lia.
    - inversion H0;subst;  lia.
    - inversion H0; lia.
    - inversion H0; lia.
  Qed.

  Lemma lengthAtom : forall id t, isOLFormula (t_atom id t)  -> lengthUexp (t_atom id t) 1.
    intros;inversion H;subst;simpl.
    inversion H1;subst;constructor.
    inversion H0;subst;constructor.
  Qed.

  Lemma lengthCons : forall id , isOLFormula (t_cons id )  -> lengthUexp (t_cons id) 1.
    intros;inversion H;subst;constructor.
  Qed.

    Lemma lengthUnary : forall lab F n , isOLFormula (t_ucon lab F) -> lengthUexp F n -> lengthUexp (t_ucon lab F) (S n).
    intros;subst;constructor;auto.
  Qed.

    Lemma lengthBin : forall lab F G n m, isOLFormula (t_bin lab F  G) -> lengthUexp F n -> lengthUexp G m -> lengthUexp (t_bin lab F G) (S (n+m)).
    intros;subst;constructor;auto.
  Qed.

  Lemma lengthAll : forall lab FX n, uniform FX -> isOLFormula (t_quant lab FX) -> lengthUexp (FX (Var 0%nat)) n -> lengthUexp  (t_quant lab  FX) (S n).
    intros;subst.
    inversion H0;simpl;subst;constructor;auto.
  Qed.

  (** [lengthUexp] is indeed a function *)
  Lemma lengthFunction : forall n F , isOLFormula F -> lengthUexp F n -> forall n', lengthUexp F n' -> n = n'.
  Proof with auto;subst;try lia.
    induction n using strongind;intros ...
    apply LengthFormula in H0...

    inversion H0...
    inversion H1...
    inversion H2...

    inversion H3...
    inversion H2...
    inversion H1...

    inversion H2...
    inversion H1...
    assert (n = n1). eapply H with (F:= F0)...
    lia.

    inversion H2...
    inversion H1...
    assert (n0 = n1).
    eapply H with (F:= F0)...

    assert (n3 = n2).
    eapply H with (F:= G)...
    lia.

    inversion H2...
    inversion H1...
    apply lbindEq in H8...
    apply lbindEq in H6...
    assert (ext_eq FX M0).
    apply ext_eq_S_Symmetric...
    assert (ext_eq M M0).
    eapply ext_eq_trans;eauto.
    assert (proper (Var 0%nat)) by constructor.

    assert (n = n0).
    eapply H with (F:= M0 (Var 0%nat))...

    assert(isOLFormula (FX (Var 0%nat))).
    apply H4 ...

    generalize (H8 (Var 0%nat) H13);intro...
    rewrite H15...

    generalize (H10 (Var 0%nat) H13);intro...
    rewrite H14 in H9...
    lia.
  Qed.

  Lemma lengthBinSizeL :
    forall F G C n n',
      isOLFormula F -> isOLFormula G ->
      lengthUexp (t_bin C F G) n -> lengthUexp F n' ->
      n' < n.
  Proof with auto;subst;try lia.
    intros.
    inversion H1...
    generalize (lengthFunction H H7);intros.
    apply H3 in H2...
  Qed.

  Lemma lengthBinSizeR :
    forall F G C n n', isOLFormula F -> isOLFormula G ->
                       lengthUexp (t_bin C F G) n ->
                       lengthUexp G n' ->
                       n' < n.
    Proof with auto;subst;try lia.
    intros.
    inversion H1...
    generalize (lengthFunction H0 H8);intros.
    apply H3 in H2...
    Qed.

    Lemma length1 : forall F ,
        isOLFormula F -> lengthUexp F 1 ->
        isOLAtom F \/ isOLConstant F.
  Proof with subst;auto.
    intros.
    inversion H ...
    - inversion H0...
      generalize (LengthFormula H1 H3);lia.
    - inversion H0...
      assert (n1 = 0%nat) by lia.
      generalize (LengthFormula H2 H8);intro. lia.
    -  inversion H0 ...
       generalize (lbindEq  H6  H1 H4);intro.
       assert (proper (Var 0%nat)). constructor.
       generalize (H3 _ H5);intro. rewrite H8 in H7.
       apply H2 in H5.
       generalize (LengthFormula H5 H7 );lia.

  Qed.

  (** Proper conditions *)

  Lemma isOLTermProper : forall t, isOLTerm t -> proper t.
    intros.
    inversion H.
    unfold t_term.
    auto with hybrid.
  Qed.

  Lemma isOLAtomProper : forall t, isOLAtom t -> proper t.
    intros.
    inversion H.
    unfold t_atom.
    inversion H0;subst.
    unfold t_term.
    auto with hybrid.
  Qed.

  Lemma isOLFormulaProper : forall F, isOLFormula F -> proper F.
  Proof with repeat constructor;auto.
    intros.
    induction H.
    - inversion H ...
    - inversion H...
    - constructor; eauto with hybrid.
    - constructor; eauto with hybrid.
    - constructor; eauto with hybrid.

  Qed.

  (** ** LL predicated needed in the encoding *)
  (** Predicates [up] (formulas on the right of the HyLL sequent) and
  [down] (formulas on the left of the HyLL sequent) *)
  Inductive atm' : Set :=
  | up' : uexp -> atm'    (* formulas on the right *)
  | down' : uexp -> atm'  (* formulas on the left *)
  .

  (** Uniform Predicate for atoms *)
  Inductive uniform_atm' : (uexp -> atm') -> Prop :=
  | uniform_up: forall FX, uniform FX -> uniform_atm' (fun x:uexp => up' (FX x))
  | uniform_down: forall FX, uniform FX -> uniform_atm' (fun x:uexp => down' (FX x))
  .
  Hint Constructors uniform_atm' : core.

  (** Well Formedness Conditions *)
  Lemma uniform_at : forall (FX:uexp->uexp),
      uniform FX -> uniform (fun x => FX x).
  Proof.
    intros.
    auto with hybrid.
  Qed.
  Hint Resolve uniform_at : core.

   Global Instance OLSyntaxIns : OLSig :=
    {|
      atm := atm';
      con := Econ ;
      uniform_atm := uniform_atm'
    |}.

   Definition up : uexp -> atm := up'.
   Definition down : uexp -> atm := down'.

End OLSyntax.

Global Hint Constructors isOLTerm isOLAtom isOLConstant isOLFormula : core.
Global Hint Unfold isOLFormulaL : core.

(** Notation for atoms of the form [up] and [down] *)
Notation "'u|' A '|'" := (atom (up A)) (at level 10) .
Notation "'d|' A '|'" := (atom (down A)) (at level 10) .
Notation "'u^|' A '|'" := (perp (up A)) (at level 10) .
Notation "'d^|' A '|'" := (perp (down A)) (at level 10) .


Module CoTree.
	CoInductive tree (t : Type) :=
		  Leaf
		| Node (node : tree t * t * tree t).

	Definition isLeaf {t: Type} (__input : tree t) : Prop :=
		match __input with
			  Leaf  => True
			| _ => False
		end.

	Definition isNode {t: Type} (__input : tree t) : Prop :=
		match __input with
			  Node _ => True
			| _ => False
		end.

	Definition getNodeNode {t: Type} (__input : tree t) : isNode __input -> tree t * t * tree t :=
		match __input with
			  Node node => fun __precondition => node
			| _ => fun __precondition => match __precondition with end
		end.
End CoTree.

Module Tree.
	Parameter Label : Type.

	CoInductive tree (t : Type) :=
		  Leaf
		| Node (node : tree t * t * tree t)
		| Labeled (__tag : Label) (__data : tree t)
		| Reference (__tag : Label).

	Definition isLeaf {t: Type} (__input : tree t) : Prop :=
		match __input with
			  Leaf  => True
			| _ => False
		end.

	Definition isNode {t: Type} (__input : tree t) : Prop :=
		match __input with
			  Node _ => True
			| _ => False
		end.

	Definition isLabeled {t: Type} (__input : tree t) : Prop :=
		match __input with
			  Labeled _ _ => True
			| _ => False
		end.

	Definition isReference {t: Type} (__input : tree t) : Prop :=
		match __input with
			  Reference _ => True
			| _ => False
		end.

	Definition getNodeNode {t: Type} (__input : tree t) : isNode __input -> tree t * t * tree t :=
		match __input with
			  Node node => fun __precondition => node
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getLabeled__tag {t: Type} (__input : tree t) : isLabeled __input -> Label :=
		match __input with
			  Labeled __tag _ => fun __precondition => __tag
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getLabeled__data {t: Type} (__input : tree t) : isLabeled __input -> tree t :=
		match __input with
			  Labeled _ __data => fun __precondition => __data
			| _ => fun __precondition => match __precondition with end
		end.

	Definition getReference__tag {t: Type} (__input : tree t) : isReference __input -> Label :=
		match __input with
			  Reference __tag => fun __precondition => __tag
			| _ => fun __precondition => match __precondition with end
		end.

	Inductive subterm {t: Type} (__root : tree t) : tree t -> Type :=
		  SubRoot : subterm __root __root
		| SubLabeled : forall __tag __data, subterm __root (Labeled t __tag __data) -> subterm __root __data.
End Tree.


Definition curry2 {A B C} (f : A -> B -> C) (x : A * B) : C
:= let '(a, b) := x in f a b.


Require Export Iron.Language.SystemF2Effect.Type.Exp.Base.
Require Export Iron.Language.SystemF2Effect.Type.Relation.WfT.

(********************************************************************)
(* Type Utils *)
(* Construct a type application from a constructor type
   and a list of argument types. *)
Fixpoint makeTApps (t1: ty) (tt: list ty) : ty :=
 match tt with
 | nil     => t1
 | t :: ts => makeTApps (TApp t1 t) ts
 end.

Fixpoint takeTCon (tt: ty) : ty :=
 match tt with
 | TApp t1 t2 => takeTCon t1
 | _          => tt
 end.

Fixpoint takeTArgs (tt: ty) : list ty :=
 match tt with
 | TApp t1 t2 => snoc t2 (takeTArgs t1)
 | _          => cons tt nil
 end.

(* Break apart a type application into the constructor type
   and a list of argument types. *)
Definition takeTApps (tt: ty) : (ty * list ty)
 := (takeTCon tt, takeTArgs tt).

(* Take the region identifier from an effect, if any. *)
Fixpoint handleOfEffect (e : ty) : option nat :=
 match e with
 | TCon1 tc (TRgn p)  => if isEffectTyCon_b tc then Some p else None
 | _                  => None
 end.

(********************************************************************)
Lemma makeTApps_snoc
 : forall t1 t2 t3 ts
 , makeTApps (TApp t1 t2) (snoc t3 ts)
 = TApp (makeTApps t1 (cons t2 ts)) t3.
Proof.
 intros. gen t1 t2.
 induction ts; burn.
Qed.

Lemma makeTApps_snoc'
 :  forall t1 t2 ts
 ,  makeTApps t1 (snoc t2 ts)
 =  TApp (makeTApps t1 ts) t2.
Proof.
 intros. gen t1 t2.
 induction ts; burn.
Qed.

Lemma takeTCon_makeTApps
 :  forall t1 ts
 ,  takeTCon (makeTApps t1 ts) = takeTCon t1.
Proof.
 intros. gen t1.
 induction ts; rip; burn.
 simpl. rewritess. burn.
Qed.
Hint Resolve takeTCon_makeTApps.

Lemma makeTApps_takeTCon
 :  forall t1 t2 ts
 ,  makeTApps t1 ts = t2
 -> takeTCon t1     = takeTCon t2.
Proof.
 intros. gen t1 t2.
 induction ts; intros.
 - simpl in H. subst. auto.
 - eapply IHts in H. simpl in H. auto.
Qed.
Hint Resolve makeTApps_takeTCon.

Lemma makeTApps_rewind
 :  forall t1 t2 ts
 ,  makeTApps (TApp t1 t2) ts
 =  makeTApps t1 (t2 :: ts).
Proof. burn. Qed.

(* A type application constructed from well formed components is
   itself well formed. *)
Lemma makeTApps_wfT
 :  forall n t1 ts
 ,  WfT n t1
 -> Forall (WfT n) ts
 -> WfT n (makeTApps t1 ts).
Proof.
 intros. gen t1.
 induction ts; intros.
 - simpl. auto.
 - simpl.
   inverts H0.
   have HS: (ts = nil \/ (exists t ts', ts = t <: ts'))
    by (apply snocable).
   inverts HS.
   + simpl. auto.
   + dest H0. dest H0. subst.
     eapply IHts; auto.
Qed.

Lemma handleOfEffect_form_some
 :  forall e p
 ,  handleOfEffect e = Some p
 -> exists tc
     ,  e    = TCon1 tc (TRgn p)
     /\ true = isEffectTyCon_b tc.
Proof.
 intros.
 destruct e; snorm.
 - destruct e; snorm.
   destruct t0; snorm.
   exists t. rip.
 - destruct e; snorm.
   destruct t0; snorm.
Qed.
Hint Resolve handleOfEffect_form_some.


(* utility.v

   Generally useful stuff that doesn't belong anywhere else for

   Abstracting Allocation : The New New Thing
   Nick Benton

   (c) 2006 Microsoft Research

   This also exports a bunch of pervasive stuff from the standard library
*)

Require Export Arith.
Require Export EqNat.
Require Export Bool.
Require Export BoolEq.
Require Export Setoid.
Require Export Omega.
Require Export Bool_nat.
Require Export List.
Require Export Max.
Require Export Min.

Lemma generalise_recursion : forall (P:nat->Prop), (forall k , P k) <-> (forall k k0, k0<=k -> P k0).
Proof.
  intuition; apply (H k k); trivial.
Qed.

Ltac dcase x := generalize (refl_equal x); pattern x at -1; case x.

Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Tactic Notation "hreplace" constr(h) "with" constr(t) := let id:=fresh in (assert (id := t); clear h; rename id into h).

Tactic Notation "omega_replace" constr(m) "with" constr(n) := replace m with n ; try omega.

(*Tactic Notation "deconstruct" hyp(h) := _deconstruct h.*)
Tactic Notation "deconstruct" hyp(h) "as" simple_intropattern(ip) := generalize h; clear h; intros ip.

Tactic Notation "witness" ident(p) "in" hyp(h) := elim h; clear h; intros p h.

Axiom Extensionality : forall (A B : Type) (f g : A->B), (forall a:A, f a = g a) <-> f =g.

Lemma strictPosSucc: forall n, n>0 -> exists m , S m =n.
Proof.
  intros.
  induction n.
  destruct H.
  exists n; trivial.
  exists m; trivial.
  exists n; trivial.
Qed.

Ltac unfold_plus:=
  try repeat rewrite <- plus_n_Sm;
  try rewrite plus_0_r;
  try rewrite plus_0_l.

Tactic Notation (at level 0) "unfold_plus" "in" constr(H) := try repeat rewrite <- plus_n_Sm in H;
  try rewrite plus_0_r in H;
  try rewrite plus_0_l in H.

Lemma beq_nat_neq :forall m n, m<>n ->  false = (beq_nat m n).
     double induction m n; simpl in |-*.
    intros.
    tauto.
    firstorder.
    firstorder.
    intros.
    set(Hn := (H0 n)).
    assert (n1 <> n).
    omega.
    apply (Hn H2).
Qed.

(* bleq_nat, ble_nat ... *)

Fixpoint bleq_nat (n m: nat) {struct n} : bool :=
  match n with
    | 0 => true
    | S n1 => match m with
		| 0 => false
		| S m1 => bleq_nat n1 m1
	      end
  end.

Fixpoint ble_nat (n m : nat) {struct n} : bool :=
  match n with
    | 0 => match m with
	     | 0 => false
	     | S _ => true
	    end
    | S n1 => match m with
		| 0 => false
		| S m1 => ble_nat n1 m1
	      end
  end.

Lemma ble_nat_false : forall m n, m >=n -> false = ble_nat m n.
  double induction m n.
  firstorder.
  firstorder.
  firstorder.
  firstorder.
Qed.

Lemma bleq_nat_false : forall m n, m > n -> false = bleq_nat m n.
double induction m n.
 simpl.
 intro; absurd (0>0).
 omega.
 assumption.

 intros.
 simpl.
 absurd (0> S n0).
 omega.
 assumption.

 intros.
 simpl.
 tauto.

 intros.
 simpl.
 apply H0.
 omega.
Qed.

Lemma bleq_nat_true : forall m n, m <= n -> true = bleq_nat m n.
double induction m n; intros; simpl.
tauto.
tauto.
absurd (S n <=0).
 omega.
 assumption.
apply H0.
omega.
Qed.

Lemma true_bleq_nat : forall m n, true = bleq_nat m n -> m <= n.
double induction m n.
simpl.
omega.
simpl; intros.
omega.
simpl; intros.
discriminate H0.
simpl; intros.
intuition.
Qed.

Lemma false_bleq_nat : forall m n, false = bleq_nat m n -> m > n.
intros.
assert (~ m <= n).
intro Habs; generalize (bleq_nat_true m n Habs); intro.
rewrite <- H0 in H; discriminate H.
omega.
Qed.

Lemma ble_nat_true : forall m n, m < n -> true = ble_nat m n.
double induction m n.
intro; absurd (0<0).
omega.
assumption.

intros.
simpl.
tauto.

intros.
simpl.
absurd (S n < 0).
omega.
assumption.

intros.
simpl.
apply H0.
omega.
Qed.

Lemma booleq : forall (a b : bool), ((true = a) <-> (true = b)) -> (a = b).
intros; dcase a.
intuition.
intuition.
dcase b.
rewrite H0 in H2.
intro; symmetry; apply H2; symmetry; assumption.
tauto.
Qed.

Definition compose (A B C : Type) (g : B -> C) (f : A -> B) a := g(f a).

Implicit Arguments compose [A B C].

Definition opt_map : forall (A B : Type), (A -> B) -> (option A -> option B) :=
  fun A B f o =>
    match o with
      | None => None
      | Some a => Some (f a)
    end.

Implicit Arguments opt_map [A B].

Definition opt_lift : forall (A B : Type), (A -> option B) -> option A -> option B :=
  fun A B f o =>
    match o with
    | Some a => f a
    | None => None
    end.

Implicit Arguments opt_lift [A B].

Section Lists_extras.

  Variable A : Type.

  Set Implicit Arguments.

  (* cons_nth *)

  Fixpoint cons_nth (a:A) (l:list A) (m:nat) {struct l} : list A :=
    match l with
      | nil => a :: nil
      | b :: bs =>
	match m with
	  | 0 => a :: l
	  | S m' => b :: cons_nth a bs m'
	end
    end.

  Lemma cons_nth_S : forall a b l m, cons_nth a (b::l) (S m) = b :: (cons_nth a l m).
  Proof.
    firstorder.
  Qed.

  Lemma nth_error_nil : forall n, nth_error (nil : list A) n = error.
  Proof.
    destruct n; trivial.
  Qed.

  Lemma nth_error_cons : forall (l:list A) n a b, (nth_error l n = Some a) = (nth_error (b::l) (S n) = Some a).
    simpl; auto.
  Qed.

  Lemma nth_error_cons_nth_lt : forall (l:list A) n a b m (h:n<m),
         (nth_error l n = Some a) -> (nth_error (cons_nth b l m) n = Some a).
  Proof.
    induction l.
    intros; rewrite (nth_error_nil n) in H; inversion H.
    intros until m;  case m.
    intro h;  absurd (n < 0); [apply  (lt_n_O n) | assumption].
    case n ;[ trivial | simpl; intros ; apply (IHl n0 a0 b n1) ; [omega |trivial]].
  Qed.

  Lemma nth_error_cons_nth_ltI : forall (l:list A) n a b m (h : n < m) (hn:n < length l),
          (nth_error (cons_nth b l m) n = Some a) -> (nth_error l n = Some a).
  Proof.
    induction l.
    intros. simpl in hn. destruct (lt_n_O n). auto.
    intros. destruct n. simpl in H. destruct m. destruct (lt_irrefl 0) ; auto.
    auto. simpl. simpl in H ; destruct m. destruct (lt_n_O (S n)). auto.
    assert (S n < S (length l)). auto.
    apply (IHl n a0 b m (lt_S_n _ _ h) (lt_S_n _ _ H0)). auto.
  Qed.

  Lemma nth_error_cons_nth_ge : forall (l:list A) n a b m (h:n>=m),
         (nth_error l n = Some a) -> (nth_error (cons_nth b l m) (S n) = Some a).
  Proof.
    induction l.
    intro n; rewrite (nth_error_nil n); intros; inversion H.
    intros until m;case m.
    trivial.
    case n.
    intros n0 h; absurd (0 >= S n0) ; [omega | trivial].
    intros n0 n1 h; simpl; simpl in IHl.
    apply IHl; omega.
  Qed.

  Lemma nth_error_cons_nth_geI : forall (l:list A) n a b m (h:n>=m),
          (nth_error (cons_nth b l m) (S n) = Some a) -> (nth_error l n = Some a).
  Proof.
    induction l.
    intro n. auto.
    intros. destruct m. simpl in H. auto.
    simpl in H. destruct n. destruct (le_not_gt _ _ h).
    apply neq_O_lt. auto.
    apply (IHl n a0 b _ (le_S_n _ _ h) H).
  Qed.

  Lemma nth_error_cons_nth_eq : forall a l n,
        n <= length l -> nth_error (cons_nth a l n) n = value a.
  Proof.
    intros.
    generalize dependent l.
    induction n. intros. destruct l ; simpl ; reflexivity.
    intros.
    destruct l. simpl in H.
    destruct (absurd False H (le_Sn_O n)).
    simpl.
    assert (length (a0 :: l) = S (length l)). auto.
    rewrite -> H0 in H.
    apply (IHn _ (le_S_n _ _ H)).
  Qed.

  Lemma nth_error_length : forall l n (a:A), nth_error l n = value a -> n < length l.
  Proof.
    intros. generalize dependent l.
    induction n. destruct l. simpl.
    intros. inversion H.
    simpl. intros. apply gt_Sn_O.
    intro l. destruct l. simpl. intro. inversion H.
    simpl. intro. apply gt_n_S. apply (IHn _ H).
  Qed.

  Lemma nth_error_lengthI : forall (l:list A) n, n < length l -> exists a, nth_error l n = value a.
  Proof.
    intros l. induction l. simpl. intros n incon. inversion incon.
    intros n ; case n ; clear n. simpl. intros _. exists a. auto.
    intros n. simpl. intros C ; apply IHl. omega.
  Qed.

  Lemma cons_nth_length_S: forall a l n, length (cons_nth a l n) = S (length l).
  Proof.
    intros. generalize dependent l. induction n.
    intros. destruct l ; auto.
    intros. destruct l. auto.
    simpl. apply eq_S. apply IHn.
  Qed.

  Lemma nth_error_0 : forall (l:list A) (a:A), nth_error l 0 = Some a <-> (exists l', l = a::l').
  Proof.
    intros; split.
    induction l.
    simpl;  intro.
    inversion H.
    simpl;  intro.
    inversion H.
    exists l;trivial.
    intro; destruct H.
    rewrite H.
    simpl;trivial.
  Qed.

  Lemma nth_error_Sn : forall (l:list A) (a:A) (n:nat),
    nth_error l (S n) = Some a <-> (exists l', exists a0,  l = a0::l' /\ nth_error l' n = Some a).
  Proof.
    intros; split.
    induction l.
    simpl;  intro.
    inversion H.
    simpl;  intro.
    exists l;exists a0;intuition.
    intro; destruct H as [l' [a0 (H0,H1)]].
    rewrite H0.
    simpl;trivial.
  Qed.

Lemma nth_error_map: forall B (f:A -> B) (l:list A) i,
  nth_error (map f l) i = (match nth_error l i with Some e => Some (f e) | error => error end).
Proof.
intros B f l.
induction l.
simpl. intros i. destruct i ; simpl ; auto.
intros i. destruct i. simpl. auto.
simpl. apply IHl.
Qed.

  Lemma split_list : forall (a:A) l , a :: l = (a :: nil) ++ l.
  Proof.
    trivial.
  Qed.

  Fixpoint takedrop n (l1 l2 : list A) {struct n} := match n with
    | 0 => (l1,l2)
    | S n => match l2 with
       | nil => (l1,l2)
       | h::t => takedrop n (l1++(h::nil)) t
       end
    end.

  Definition fuse (couple:list A * list A) := match couple with (l1,l2) => l1++l2 end.

  Lemma fuse_unfold : forall l1 l2, fuse (l1,l2) = l1++l2.
  Proof.
    unfold fuse; intuition.
  Qed.

  Opaque fuse.

  Unset Implicit Arguments.

End Lists_extras.


From Hammer Require Import Hammer.

From compcert Require Import Raux.
From compcert Require Import Defs.

Section RND_prop.

Open Scope R_scope.

Definition Rnd_DN (F : R -> Prop) (rnd : R -> R) :=
forall x : R, Rnd_DN_pt F x (rnd x).

Definition Rnd_UP (F : R -> Prop) (rnd : R -> R) :=
forall x : R, Rnd_UP_pt F x (rnd x).

Definition Rnd_ZR (F : R -> Prop) (rnd : R -> R) :=
forall x : R, Rnd_ZR_pt F x (rnd x).

Definition Rnd_N (F : R -> Prop) (rnd : R -> R) :=
forall x : R, Rnd_N_pt F x (rnd x).

Definition Rnd_NG (F : R -> Prop) (P : R -> R -> Prop) (rnd : R -> R) :=
forall x : R, Rnd_NG_pt F P x (rnd x).

Definition Rnd_NA (F : R -> Prop) (rnd : R -> R) :=
forall x : R, Rnd_NA_pt F x (rnd x).

Theorem round_val_of_pred :
forall rnd : R -> R -> Prop,
round_pred rnd ->
forall x, { f : R | rnd x f }.
Proof. hammer_hook "Round_pred" "Round_pred.round_val_of_pred".
intros rnd (H1,H2) x.
specialize (H1 x).

assert (H3 : bound (rnd x)).
destruct H1 as (f, H1).
exists f.
intros g Hg.
now apply H2 with (3 := Rle_refl x).

exists (proj1_sig (completeness _ H3 H1)).
destruct completeness as (f1, (H4, H5)).
simpl.
destruct H1 as (f2, H1).
assert (f1 = f2).
apply Rle_antisym.
apply H5.
intros f3 H.
now apply H2 with (3 := Rle_refl x).
now apply H4.
now rewrite H.
Qed.

Theorem round_fun_of_pred :
forall rnd : R -> R -> Prop,
round_pred rnd ->
{ f : R -> R | forall x, rnd x (f x) }.
Proof. hammer_hook "Round_pred" "Round_pred.round_fun_of_pred".
intros rnd H.
exists (fun x => proj1_sig (round_val_of_pred rnd H x)).
intros x.
now destruct round_val_of_pred as (f, H1).
Qed.

Theorem round_unique :
forall rnd : R -> R -> Prop,
round_pred_monotone rnd ->
forall x f1 f2,
rnd x f1 ->
rnd x f2 ->
f1 = f2.
Proof. hammer_hook "Round_pred" "Round_pred.round_unique".
intros rnd Hr x f1 f2 H1 H2.
apply Rle_antisym.
now apply Hr with (3 := Rle_refl x).
now apply Hr with (3 := Rle_refl x).
Qed.

Theorem Rnd_DN_pt_monotone :
forall F : R -> Prop,
round_pred_monotone (Rnd_DN_pt F).
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_DN_pt_monotone".
intros F x y f g (Hx1,(Hx2,_)) (Hy1,(_,Hy2)) Hxy.
apply Hy2.
apply Hx1.
now apply Rle_trans with (2 := Hxy).
Qed.

Theorem Rnd_DN_pt_unique :
forall F : R -> Prop,
forall x f1 f2 : R,
Rnd_DN_pt F x f1 -> Rnd_DN_pt F x f2 ->
f1 = f2.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_DN_pt_unique".
intros F.
apply round_unique.
apply Rnd_DN_pt_monotone.
Qed.

Theorem Rnd_DN_unique :
forall F : R -> Prop,
forall rnd1 rnd2 : R -> R,
Rnd_DN F rnd1 -> Rnd_DN F rnd2 ->
forall x, rnd1 x = rnd2 x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_DN_unique".
intros F rnd1 rnd2 H1 H2 x.
now eapply Rnd_DN_pt_unique.
Qed.

Theorem Rnd_UP_pt_monotone :
forall F : R -> Prop,
round_pred_monotone (Rnd_UP_pt F).
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_UP_pt_monotone".
intros F x y f g (Hx1,(_,Hx2)) (Hy1,(Hy2,_)) Hxy.
apply Hx2.
apply Hy1.
now apply Rle_trans with (1 := Hxy).
Qed.

Theorem Rnd_UP_pt_unique :
forall F : R -> Prop,
forall x f1 f2 : R,
Rnd_UP_pt F x f1 -> Rnd_UP_pt F x f2 ->
f1 = f2.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_UP_pt_unique".
intros F.
apply round_unique.
apply Rnd_UP_pt_monotone.
Qed.

Theorem Rnd_UP_unique :
forall F : R -> Prop,
forall rnd1 rnd2 : R -> R,
Rnd_UP F rnd1 -> Rnd_UP F rnd2 ->
forall x, rnd1 x = rnd2 x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_UP_unique".
intros F rnd1 rnd2 H1 H2 x.
now eapply Rnd_UP_pt_unique.
Qed.

Theorem Rnd_UP_pt_opp :
forall F : R -> Prop,
( forall x, F x -> F (- x) ) ->
forall x f : R,
Rnd_DN_pt F x f -> Rnd_UP_pt F (-x) (-f).
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_UP_pt_opp".
intros F HF x f H.
repeat split.
apply HF.
apply H.
apply Ropp_le_contravar.
apply H.
intros g Hg.
rewrite <- (Ropp_involutive g).
intros Hxg.
apply Ropp_le_contravar.
apply H.
now apply HF.
now apply Ropp_le_cancel.
Qed.

Theorem Rnd_DN_pt_opp :
forall F : R -> Prop,
( forall x, F x -> F (- x) ) ->
forall x f : R,
Rnd_UP_pt F x f -> Rnd_DN_pt F (-x) (-f).
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_DN_pt_opp".
intros F HF x f H.
repeat split.
apply HF.
apply H.
apply Ropp_le_contravar.
apply H.
intros g Hg.
rewrite <- (Ropp_involutive g).
intros Hxg.
apply Ropp_le_contravar.
apply H.
now apply HF.
now apply Ropp_le_cancel.
Qed.

Theorem Rnd_DN_opp :
forall F : R -> Prop,
( forall x, F x -> F (- x) ) ->
forall rnd1 rnd2 : R -> R,
Rnd_DN F rnd1 -> Rnd_UP F rnd2 ->
forall x, rnd1 (- x) = - rnd2 x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_DN_opp".
intros F HF rnd1 rnd2 H1 H2 x.
rewrite <- (Ropp_involutive (rnd1 (-x))).
apply f_equal.
apply (Rnd_UP_unique F (fun x => - rnd1 (-x))) ; trivial.
intros y.
pattern y at 1 ; rewrite <- Ropp_involutive.
apply Rnd_UP_pt_opp.
apply HF.
apply H1.
Qed.

Theorem Rnd_DN_UP_pt_split :
forall F : R -> Prop,
forall x d u,
Rnd_DN_pt F x d ->
Rnd_UP_pt F x u ->
forall f, F f ->
(f <= d) \/ (u <= f).
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_DN_UP_pt_split".
intros F x d u Hd Hu f Hf.
destruct (Rle_or_lt f x).
left.
now apply Hd.
right.
assert (H' := Rlt_le _ _ H).
now apply Hu.
Qed.

Theorem Rnd_DN_pt_refl :
forall F : R -> Prop,
forall x : R, F x ->
Rnd_DN_pt F x x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_DN_pt_refl".
intros F x Hx.
repeat split.
exact Hx.
apply Rle_refl.
now intros.
Qed.

Theorem Rnd_DN_pt_idempotent :
forall F : R -> Prop,
forall x f : R,
Rnd_DN_pt F x f -> F x ->
f = x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_DN_pt_idempotent".
intros F x f (_,(Hx1,Hx2)) Hx.
apply Rle_antisym.
exact Hx1.
apply Hx2.
exact Hx.
apply Rle_refl.
Qed.

Theorem Rnd_UP_pt_refl :
forall F : R -> Prop,
forall x : R, F x ->
Rnd_UP_pt F x x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_UP_pt_refl".
intros F x Hx.
repeat split.
exact Hx.
apply Rle_refl.
now intros.
Qed.

Theorem Rnd_UP_pt_idempotent :
forall F : R -> Prop,
forall x f : R,
Rnd_UP_pt F x f -> F x ->
f = x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_UP_pt_idempotent".
intros F x f (_,(Hx1,Hx2)) Hx.
apply Rle_antisym.
apply Hx2.
exact Hx.
apply Rle_refl.
exact Hx1.
Qed.

Theorem Only_DN_or_UP :
forall F : R -> Prop,
forall x fd fu f : R,
Rnd_DN_pt F x fd -> Rnd_UP_pt F x fu ->
F f -> (fd <= f <= fu)%R ->
f = fd \/ f = fu.
Proof. hammer_hook "Round_pred" "Round_pred.Only_DN_or_UP".
intros F x fd fu f Hd Hu Hf [Hdf Hfu].
destruct (Rle_or_lt x f) ; [right|left].
apply Rle_antisym with (1 := Hfu).
now apply Hu.
apply Rlt_le in H.
apply Rle_antisym with (2 := Hdf).
now apply Hd.
Qed.

Theorem Rnd_ZR_abs :
forall (F : R -> Prop) (rnd: R-> R),
Rnd_ZR F rnd ->
forall x : R,  (Rabs (rnd x) <= Rabs x)%R.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_ZR_abs".
intros F rnd H x.
assert (F 0%R).
replace 0%R with (rnd 0%R).
eapply H.
apply Rle_refl.
destruct (H 0%R) as (H1, H2).
apply Rle_antisym.
apply H1.
apply Rle_refl.
apply H2.
apply Rle_refl.

destruct (Rle_or_lt 0 x).

rewrite Rabs_pos_eq with (1 := H1).
rewrite Rabs_pos_eq.
now apply (proj1 (H x)).
now apply (proj1 (H x)).

apply Rlt_le in H1.
rewrite Rabs_left1 with (1 := H1).
rewrite Rabs_left1.
apply Ropp_le_contravar.
now apply (proj2 (H x)).
now apply (proj2 (H x)).
Qed.

Theorem Rnd_ZR_pt_monotone :
forall F : R -> Prop, F 0 ->
round_pred_monotone (Rnd_ZR_pt F).
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_ZR_pt_monotone".
intros F F0 x y f g (Hx1, Hx2) (Hy1, Hy2) Hxy.
destruct (Rle_or_lt 0 x) as [Hx|Hx].

apply Hy1.
now apply Rle_trans with x.
now apply Hx1.
apply Rle_trans with (2 := Hxy).
now apply Hx1.

apply Rlt_le in Hx.
destruct (Rle_or_lt 0 y) as [Hy|Hy].
apply Rle_trans with 0.
now apply Hx2.
now apply Hy1.
apply Rlt_le in Hy.
apply Hx2.
exact Hx.
now apply Hy2.
apply Rle_trans with (1 := Hxy).
now apply Hy2.
Qed.

Theorem Rnd_N_pt_DN_or_UP :
forall F : R -> Prop,
forall x f : R,
Rnd_N_pt F x f ->
Rnd_DN_pt F x f \/ Rnd_UP_pt F x f.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_DN_or_UP".
intros F x f (Hf1,Hf2).
destruct (Rle_or_lt x f) as [Hxf|Hxf].

right.
repeat split ; try assumption.
intros g Hg Hxg.
specialize (Hf2 g Hg).
rewrite 2!Rabs_pos_eq in Hf2.
now apply Rplus_le_reg_r with (-x)%R.
now apply Rle_0_minus.
now apply Rle_0_minus.

left.
repeat split ; try assumption.
now apply Rlt_le.
intros g Hg Hxg.
specialize (Hf2 g Hg).
rewrite 2!Rabs_left1 in Hf2.
generalize (Ropp_le_cancel _ _ Hf2).
intros H.
now apply Rplus_le_reg_r with (-x)%R.
now apply Rle_minus.
apply Rlt_le.
now apply Rlt_minus.
Qed.

Theorem Rnd_N_pt_DN_or_UP_eq :
forall F : R -> Prop,
forall x fd fu f : R,
Rnd_DN_pt F x fd -> Rnd_UP_pt F x fu ->
Rnd_N_pt F x f ->
f = fd \/ f = fu.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_DN_or_UP_eq".
intros F x fd fu f Hd Hu Hf.
destruct (Rnd_N_pt_DN_or_UP F x f Hf) as [H|H].
left.
apply Rnd_DN_pt_unique with (1 := H) (2 := Hd).
right.
apply Rnd_UP_pt_unique with (1 := H) (2 := Hu).
Qed.

Theorem Rnd_N_pt_opp_inv :
forall F : R -> Prop,
( forall x, F x -> F (- x) ) ->
forall x f : R,
Rnd_N_pt F (-x) (-f) -> Rnd_N_pt F x f.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_opp_inv".
intros F HF x f (H1,H2).
rewrite <- (Ropp_involutive f).
repeat split.
apply HF.
apply H1.
intros g H3.
rewrite Ropp_involutive.
replace (f - x)%R with (-(-f - -x))%R by ring.
replace (g - x)%R with (-(-g - -x))%R by ring.
rewrite 2!Rabs_Ropp.
apply H2.
now apply HF.
Qed.

Theorem Rnd_N_pt_monotone :
forall F : R -> Prop,
forall x y f g : R,
Rnd_N_pt F x f -> Rnd_N_pt F y g ->
x < y -> f <= g.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_monotone".
intros F x y f g (Hf,Hx) (Hg,Hy) Hxy.
apply Rnot_lt_le.
intros Hgf.
assert (Hfgx := Hx g Hg).
assert (Hgfy := Hy f Hf).
clear F Hf Hg Hx Hy.
destruct (Rle_or_lt x g) as [Hxg|Hgx].

apply Rle_not_lt with (1 := Hfgx).
rewrite 2!Rabs_pos_eq.
now apply Rplus_lt_compat_r.
apply Rle_0_minus.
apply Rlt_le.
now apply Rle_lt_trans with (1 := Hxg).
now apply Rle_0_minus.
assert (Hgy := Rlt_trans _ _ _ Hgx Hxy).
destruct (Rle_or_lt f y) as [Hfy|Hyf].

apply Rle_not_lt with (1 := Hgfy).
rewrite (Rabs_left (g - y)).
2: now apply Rlt_minus.
rewrite Rabs_left1.
apply Ropp_lt_contravar.
now apply Rplus_lt_compat_r.
now apply Rle_minus.

rewrite Rabs_left, Rabs_pos_eq, Ropp_minus_distr in Hgfy.
rewrite Rabs_pos_eq, Rabs_left, Ropp_minus_distr in Hfgx.
apply Rle_not_lt with (1 := Rplus_le_compat _ _ _ _ Hfgx Hgfy).
apply Rminus_lt.
ring_simplify.
apply Rlt_minus.
apply Rmult_lt_compat_l.
now apply IZR_lt.
exact Hxy.
now apply Rlt_minus.
apply Rle_0_minus.
apply Rlt_le.
now apply Rlt_trans with (1 := Hxy).
apply Rle_0_minus.
now apply Rlt_le.
now apply Rlt_minus.
Qed.

Theorem Rnd_N_pt_unique :
forall F : R -> Prop,
forall x d u f1 f2 : R,
Rnd_DN_pt F x d ->
Rnd_UP_pt F x u ->
x - d <> u - x ->
Rnd_N_pt F x f1 ->
Rnd_N_pt F x f2 ->
f1 = f2.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_unique".
intros F x d u f1 f2 Hd Hu Hdu.
assert (forall f1 f2, Rnd_N_pt F x f1 -> Rnd_N_pt F x f2 -> f1 < f2 -> False).
clear f1 f2. intros f1 f2 Hf1 Hf2 H12.
destruct (Rnd_N_pt_DN_or_UP F x f1 Hf1) as [Hd1|Hu1] ;
destruct (Rnd_N_pt_DN_or_UP F x f2 Hf2) as [Hd2|Hu2].
apply Rlt_not_eq with (1 := H12).
now apply Rnd_DN_pt_unique with (1 := Hd1).
apply Hdu.
rewrite Rnd_DN_pt_unique with (1 := Hd) (2 := Hd1).
rewrite Rnd_UP_pt_unique with (1 := Hu) (2 := Hu2).
rewrite <- (Rabs_pos_eq (x - f1)).
rewrite <- (Rabs_pos_eq (f2 - x)).
rewrite Rabs_minus_sym.
apply Rle_antisym.
apply Hf1. apply Hf2.
apply Hf2. apply Hf1.
apply Rle_0_minus.
apply Hu2.
apply Rle_0_minus.
apply Hd1.
apply Rlt_not_le with (1 := H12).
apply Rle_trans with x.
apply Hd2.
apply Hu1.
apply Rgt_not_eq with (1 := H12).
now apply Rnd_UP_pt_unique with (1 := Hu2).
intros Hf1 Hf2.
now apply Rle_antisym ; apply Rnot_lt_le ; refine (H _ _ _ _).
Qed.

Theorem Rnd_N_pt_refl :
forall F : R -> Prop,
forall x : R, F x ->
Rnd_N_pt F x x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_refl".
intros F x Hx.
repeat split.
exact Hx.
intros g _.
unfold Rminus at 1.
rewrite Rplus_opp_r, Rabs_R0.
apply Rabs_pos.
Qed.

Theorem Rnd_N_pt_idempotent :
forall F : R -> Prop,
forall x f : R,
Rnd_N_pt F x f -> F x ->
f = x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_idempotent".
intros F x f (_,Hf) Hx.
apply Rminus_diag_uniq.
destruct (Req_dec (f - x) 0) as [H|H].
exact H.
elim Rabs_no_R0 with (1 := H).
apply Rle_antisym.
replace 0 with (Rabs (x - x)).
now apply Hf.
unfold Rminus.
rewrite Rplus_opp_r.
apply Rabs_R0.
apply Rabs_pos.
Qed.

Theorem Rnd_N_pt_0 :
forall F : R -> Prop,
F 0 ->
Rnd_N_pt F 0 0.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_0".
intros F HF.
split.
exact HF.
intros g _.
rewrite 2!Rminus_0_r, Rabs_R0.
apply Rabs_pos.
Qed.

Theorem Rnd_N_pt_ge_0 :
forall F : R -> Prop, F 0 ->
forall x f, 0 <= x ->
Rnd_N_pt F x f ->
0 <= f.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_ge_0".
intros F HF x f [Hx|Hx] Hxf.
eapply Rnd_N_pt_monotone ; try eassumption.
now apply Rnd_N_pt_0.
right.
apply sym_eq.
apply Rnd_N_pt_idempotent with F.
now rewrite Hx.
exact HF.
Qed.

Theorem Rnd_N_pt_le_0 :
forall F : R -> Prop, F 0 ->
forall x f, x <= 0 ->
Rnd_N_pt F x f ->
f <= 0.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_le_0".
intros F HF x f [Hx|Hx] Hxf.
eapply Rnd_N_pt_monotone ; try eassumption.
now apply Rnd_N_pt_0.
right.
apply Rnd_N_pt_idempotent with F.
now rewrite <- Hx.
exact HF.
Qed.

Theorem Rnd_N_pt_abs :
forall F : R -> Prop,
F 0 ->
( forall x, F x -> F (- x) ) ->
forall x f : R,
Rnd_N_pt F x f -> Rnd_N_pt F (Rabs x) (Rabs f).
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_abs".
intros F HF0 HF x f Hxf.
unfold Rabs at 1.
destruct (Rcase_abs x) as [Hx|Hx].
rewrite Rabs_left1.
apply Rnd_N_pt_opp_inv.
exact HF.
now rewrite 2!Ropp_involutive.
apply Rnd_N_pt_le_0 with (3 := Hxf).
exact HF0.
now apply Rlt_le.
rewrite Rabs_pos_eq.
exact Hxf.
apply Rnd_N_pt_ge_0 with (3 := Hxf).
exact HF0.
now apply Rge_le.
Qed.

Theorem Rnd_N_pt_DN_UP :
forall F : R -> Prop,
forall x d u f : R,
F f ->
Rnd_DN_pt F x d ->
Rnd_UP_pt F x u ->
(Rabs (f - x) <= x - d)%R ->
(Rabs (f - x) <= u - x)%R ->
Rnd_N_pt F x f.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_DN_UP".
intros F x d u f Hf Hxd Hxu Hd Hu.
split.
exact Hf.
intros g Hg.
destruct (Rnd_DN_UP_pt_split F x d u Hxd Hxu g Hg) as [Hgd|Hgu].

apply Rle_trans with (1 := Hd).
rewrite Rabs_left1.
rewrite Ropp_minus_distr.
apply Rplus_le_compat_l.
now apply Ropp_le_contravar.
apply Rle_minus.
apply Rle_trans with (1 := Hgd).
apply Hxd.

apply Rle_trans with (1 := Hu).
rewrite Rabs_pos_eq.
now apply Rplus_le_compat_r.
apply Rle_0_minus.
apply Rle_trans with (2 := Hgu).
apply Hxu.
Qed.

Theorem Rnd_N_pt_DN :
forall F : R -> Prop,
forall x d u : R,
Rnd_DN_pt F x d ->
Rnd_UP_pt F x u ->
(x - d <= u - x)%R ->
Rnd_N_pt F x d.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_DN".
intros F x d u Hd Hu Hx.
assert (Hdx: (Rabs (d - x) = x - d)%R).
rewrite Rabs_minus_sym.
apply Rabs_pos_eq.
apply Rle_0_minus.
apply Hd.
apply Rnd_N_pt_DN_UP with (2 := Hd) (3 := Hu).
apply Hd.
rewrite Hdx.
apply Rle_refl.
now rewrite Hdx.
Qed.

Theorem Rnd_N_pt_UP :
forall F : R -> Prop,
forall x d u : R,
Rnd_DN_pt F x d ->
Rnd_UP_pt F x u ->
(u - x <= x - d)%R ->
Rnd_N_pt F x u.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_N_pt_UP".
intros F x d u Hd Hu Hx.
assert (Hux: (Rabs (u - x) = u - x)%R).
apply Rabs_pos_eq.
apply Rle_0_minus.
apply Hu.
apply Rnd_N_pt_DN_UP with (2 := Hd) (3 := Hu).
apply Hu.
now rewrite Hux.
rewrite Hux.
apply Rle_refl.
Qed.

Definition Rnd_NG_pt_unique_prop F P :=
forall x d u,
Rnd_DN_pt F x d -> Rnd_N_pt F x d ->
Rnd_UP_pt F x u -> Rnd_N_pt F x u ->
P x d -> P x u -> d = u.

Theorem Rnd_NG_pt_unique :
forall (F : R -> Prop) (P : R -> R -> Prop),
Rnd_NG_pt_unique_prop F P ->
forall x f1 f2 : R,
Rnd_NG_pt F P x f1 -> Rnd_NG_pt F P x f2 ->
f1 = f2.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NG_pt_unique".
intros F P HP x f1 f2 (H1a,H1b) (H2a,H2b).
destruct H1b as [H1b|H1b].
destruct H2b as [H2b|H2b].
destruct (Rnd_N_pt_DN_or_UP _ _ _ H1a) as [H1c|H1c] ;
destruct (Rnd_N_pt_DN_or_UP _ _ _ H2a) as [H2c|H2c].
eapply Rnd_DN_pt_unique ; eassumption.
now apply (HP x f1 f2).
apply sym_eq.
now apply (HP x f2 f1 H2c H2a H1c H1a).
eapply Rnd_UP_pt_unique ; eassumption.
now apply H2b.
apply sym_eq.
now apply H1b.
Qed.

Theorem Rnd_NG_pt_monotone :
forall (F : R -> Prop) (P : R -> R -> Prop),
Rnd_NG_pt_unique_prop F P ->
round_pred_monotone (Rnd_NG_pt F P).
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NG_pt_monotone".
intros F P HP x y f g (Hf,Hx) (Hg,Hy) [Hxy|Hxy].
now apply Rnd_N_pt_monotone with F x y.
apply Req_le.
rewrite <- Hxy in Hg, Hy.
eapply Rnd_NG_pt_unique ; try split ; eassumption.
Qed.

Theorem Rnd_NG_pt_refl :
forall (F : R -> Prop) (P : R -> R -> Prop),
forall x, F x -> Rnd_NG_pt F P x x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NG_pt_refl".
intros F P x Hx.
split.
now apply Rnd_N_pt_refl.
right.
intros f2 Hf2.
now apply Rnd_N_pt_idempotent with F.
Qed.

Theorem Rnd_NG_pt_opp_inv :
forall (F : R -> Prop) (P : R -> R -> Prop),
( forall x, F x -> F (-x) ) ->
( forall x f, P x f -> P (-x) (-f) ) ->
forall x f : R,
Rnd_NG_pt F P (-x) (-f) -> Rnd_NG_pt F P x f.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NG_pt_opp_inv".
intros F P HF HP x f (H1,H2).
split.
now apply Rnd_N_pt_opp_inv.
destruct H2 as [H2|H2].
left.
rewrite <- (Ropp_involutive x), <- (Ropp_involutive f).
now apply HP.
right.
intros f2 Hxf2.
rewrite <- (Ropp_involutive f).
rewrite <- H2 with (-f2).
apply sym_eq.
apply Ropp_involutive.
apply Rnd_N_pt_opp_inv.
exact HF.
now rewrite 2!Ropp_involutive.
Qed.

Theorem Rnd_NG_unique :
forall (F : R -> Prop) (P : R -> R -> Prop),
Rnd_NG_pt_unique_prop F P ->
forall rnd1 rnd2 : R -> R,
Rnd_NG F P rnd1 -> Rnd_NG F P rnd2 ->
forall x, rnd1 x = rnd2 x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NG_unique".
intros F P HP rnd1 rnd2 H1 H2 x.
now apply Rnd_NG_pt_unique with F P x.
Qed.

Theorem Rnd_NA_NG_pt :
forall F : R -> Prop,
F 0 ->
forall x f,
Rnd_NA_pt F x f <-> Rnd_NG_pt F (fun x f => Rabs x <= Rabs f) x f.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NA_NG_pt".
intros F HF x f.
destruct (Rle_or_lt 0 x) as [Hx|Hx].

split ; intros (H1, H2).

assert (Hf := Rnd_N_pt_ge_0 F HF x f Hx H1).
split.
exact H1.
destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3].

right.
intros f2 Hxf2.
specialize (H2 _ Hxf2).
destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4].
eapply Rnd_DN_pt_unique ; eassumption.
apply Rle_antisym.
rewrite Rabs_pos_eq with (1 := Hf) in H2.
rewrite Rabs_pos_eq in H2.
exact H2.
now apply Rnd_N_pt_ge_0 with F x.
apply Rle_trans with x.
apply H3.
apply H4.

left.
rewrite Rabs_pos_eq with (1 := Hf).
rewrite Rabs_pos_eq with (1 := Hx).
apply H3.

split.
exact H1.
intros f2 Hxf2.
destruct H2 as [H2|H2].
assert (Hf := Rnd_N_pt_ge_0 F HF x f Hx H1).
assert (Hf2 := Rnd_N_pt_ge_0 F HF x f2 Hx Hxf2).
rewrite 2!Rabs_pos_eq ; trivial.
rewrite 2!Rabs_pos_eq in H2 ; trivial.
destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H3|H3].
apply Rle_trans with (2 := H2).
apply H3.
apply H3.
apply H1.
apply H2.
rewrite (H2 _ Hxf2).
apply Rle_refl.

assert (Hx' := Rlt_le _ _ Hx).
clear Hx. rename Hx' into Hx.
split ; intros (H1, H2).

assert (Hf := Rnd_N_pt_le_0 F HF x f Hx H1).
split.
exact H1.
destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3].

left.
rewrite Rabs_left1 with (1 := Hf).
rewrite Rabs_left1 with (1 := Hx).
apply Ropp_le_contravar.
apply H3.

right.
intros f2 Hxf2.
specialize (H2 _ Hxf2).
destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4].
apply Rle_antisym.
apply Rle_trans with x.
apply H4.
apply H3.
rewrite Rabs_left1 with (1 := Hf) in H2.
rewrite Rabs_left1 in H2.
now apply Ropp_le_cancel.
now apply Rnd_N_pt_le_0 with F x.
eapply Rnd_UP_pt_unique ; eassumption.

split.
exact H1.
intros f2 Hxf2.
destruct H2 as [H2|H2].
assert (Hf := Rnd_N_pt_le_0 F HF x f Hx H1).
assert (Hf2 := Rnd_N_pt_le_0 F HF x f2 Hx Hxf2).
rewrite 2!Rabs_left1 ; trivial.
rewrite 2!Rabs_left1 in H2 ; trivial.
apply Ropp_le_contravar.
apply Ropp_le_cancel in H2.
destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H3|H3].
apply H3.
apply H1.
apply H2.
apply Rle_trans with (1 := H2).
apply H3.
rewrite (H2 _ Hxf2).
apply Rle_refl.
Qed.

Lemma Rnd_NA_pt_unique_prop :
forall F : R -> Prop,
F 0 ->
Rnd_NG_pt_unique_prop F (fun a b => (Rabs a <= Rabs b)%R).
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NA_pt_unique_prop".
intros F HF x d u Hxd1 Hxd2 Hxu1 Hxu2 Hd Hu.
apply Rle_antisym.
apply Rle_trans with x.
apply Hxd1.
apply Hxu1.
destruct (Rle_or_lt 0 x) as [Hx|Hx].
apply Hxu1.
apply Hxd1.
rewrite Rabs_pos_eq with (1 := Hx) in Hd.
rewrite Rabs_pos_eq in Hd.
exact Hd.
now apply Hxd1.
apply Hxd1.
apply Hxu1.
rewrite Rabs_left with (1 := Hx) in Hu.
rewrite Rabs_left1 in Hu.
now apply Ropp_le_cancel.
apply Hxu1.
apply HF.
now apply Rlt_le.
Qed.

Theorem Rnd_NA_pt_unique :
forall F : R -> Prop,
F 0 ->
forall x f1 f2 : R,
Rnd_NA_pt F x f1 -> Rnd_NA_pt F x f2 ->
f1 = f2.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NA_pt_unique".
intros F HF x f1 f2 H1 H2.
apply (Rnd_NG_pt_unique F _ (Rnd_NA_pt_unique_prop F HF) x).
now apply -> Rnd_NA_NG_pt.
now apply -> Rnd_NA_NG_pt.
Qed.

Theorem Rnd_NA_pt_N :
forall F : R -> Prop,
F 0 ->
forall x f : R,
Rnd_N_pt F x f ->
(Rabs x <= Rabs f)%R ->
Rnd_NA_pt F x f.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NA_pt_N".
intros F HF x f Rxf Hxf.
split.
apply Rxf.
intros g Rxg.
destruct (Rabs_eq_Rabs (f - x) (g - x)) as [H|H].
apply Rle_antisym.
apply Rxf.
apply Rxg.
apply Rxg.
apply Rxf.

replace g with f.
apply Rle_refl.
apply Rplus_eq_reg_r with (1 := H).

assert (g = 2 * x - f)%R.
replace (2 * x - f)%R with (x - (f - x))%R by ring.
rewrite H.
ring.
destruct (Rle_lt_dec 0 x) as [Hx|Hx].

revert Hxf.
rewrite Rabs_pos_eq with (1 := Hx).
rewrite 2!Rabs_pos_eq ; try ( apply (Rnd_N_pt_ge_0 F HF x) ; assumption ).
intros Hxf.
rewrite H0.
apply Rplus_le_reg_r with f.
ring_simplify.
apply Rmult_le_compat_l with (2 := Hxf).
now apply IZR_le.

revert Hxf.
apply Rlt_le in Hx.
rewrite Rabs_left1 with (1 := Hx).
rewrite 2!Rabs_left1 ; try ( apply (Rnd_N_pt_le_0 F HF x) ; assumption ).
intros Hxf.
rewrite H0.
apply Ropp_le_contravar.
apply Rplus_le_reg_r with f.
ring_simplify.
apply Rmult_le_compat_l.
now apply IZR_le.
now apply Ropp_le_cancel.
Qed.

Theorem Rnd_NA_unique :
forall (F : R -> Prop),
F 0 ->
forall rnd1 rnd2 : R -> R,
Rnd_NA F rnd1 -> Rnd_NA F rnd2 ->
forall x, rnd1 x = rnd2 x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NA_unique".
intros F HF rnd1 rnd2 H1 H2 x.
now apply Rnd_NA_pt_unique with F x.
Qed.

Theorem Rnd_NA_pt_monotone :
forall F : R -> Prop,
F 0 ->
round_pred_monotone (Rnd_NA_pt F).
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NA_pt_monotone".
intros F HF x y f g Hxf Hyg Hxy.
apply (Rnd_NG_pt_monotone F _ (Rnd_NA_pt_unique_prop F HF) x y).
now apply -> Rnd_NA_NG_pt.
now apply -> Rnd_NA_NG_pt.
exact Hxy.
Qed.

Theorem Rnd_NA_pt_refl :
forall F : R -> Prop,
forall x : R, F x ->
Rnd_NA_pt F x x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NA_pt_refl".
intros F x Hx.
split.
now apply Rnd_N_pt_refl.
intros f Hxf.
apply Req_le.
apply f_equal.
now apply Rnd_N_pt_idempotent with (1 := Hxf).
Qed.

Theorem Rnd_NA_pt_idempotent :
forall F : R -> Prop,
forall x f : R,
Rnd_NA_pt F x f -> F x ->
f = x.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_NA_pt_idempotent".
intros F x f (Hf,_) Hx.
now apply Rnd_N_pt_idempotent with F.
Qed.

Theorem round_pred_ge_0 :
forall P : R -> R -> Prop,
round_pred_monotone P ->
P 0 0 ->
forall x f, P x f -> 0 <= x -> 0 <= f.
Proof. hammer_hook "Round_pred" "Round_pred.round_pred_ge_0".
intros P HP HP0 x f Hxf Hx.
now apply (HP 0 x).
Qed.

Theorem round_pred_gt_0 :
forall P : R -> R -> Prop,
round_pred_monotone P ->
P 0 0 ->
forall x f, P x f -> 0 < f -> 0 < x.
Proof. hammer_hook "Round_pred" "Round_pred.round_pred_gt_0".
intros P HP HP0 x f Hxf Hf.
apply Rnot_le_lt.
intros Hx.
apply Rlt_not_le with (1 := Hf).
now apply (HP x 0).
Qed.

Theorem round_pred_le_0 :
forall P : R -> R -> Prop,
round_pred_monotone P ->
P 0 0 ->
forall x f, P x f -> x <= 0 -> f <= 0.
Proof. hammer_hook "Round_pred" "Round_pred.round_pred_le_0".
intros P HP HP0 x f Hxf Hx.
now apply (HP x 0).
Qed.

Theorem round_pred_lt_0 :
forall P : R -> R -> Prop,
round_pred_monotone P ->
P 0 0 ->
forall x f, P x f -> f < 0 -> x < 0.
Proof. hammer_hook "Round_pred" "Round_pred.round_pred_lt_0".
intros P HP HP0 x f Hxf Hf.
apply Rnot_le_lt.
intros Hx.
apply Rlt_not_le with (1 := Hf).
now apply (HP 0 x).
Qed.

Theorem Rnd_DN_pt_equiv_format :
forall F1 F2 : R -> Prop,
forall a b : R,
F1 a ->
( forall x, a <= x <= b -> (F1 x <-> F2 x) ) ->
forall x f, a <= x <= b -> Rnd_DN_pt F1 x f -> Rnd_DN_pt F2 x f.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_DN_pt_equiv_format".
intros F1 F2 a b Ha HF x f Hx (H1, (H2, H3)).
split.
apply -> HF.
exact H1.
split.
now apply H3.
now apply Rle_trans with (1 := H2).
split.
exact H2.
intros k Hk Hl.
destruct (Rlt_or_le k a) as [H|H].
apply Rlt_le.
apply Rlt_le_trans with (1 := H).
now apply H3.
apply H3.
apply <- HF.
exact Hk.
split.
exact H.
now apply Rle_trans with (1 := Hl).
exact Hl.
Qed.

Theorem Rnd_UP_pt_equiv_format :
forall F1 F2 : R -> Prop,
forall a b : R,
F1 b ->
( forall x, a <= x <= b -> (F1 x <-> F2 x) ) ->
forall x f, a <= x <= b -> Rnd_UP_pt F1 x f -> Rnd_UP_pt F2 x f.
Proof. hammer_hook "Round_pred" "Round_pred.Rnd_UP_pt_equiv_format".
intros F1 F2 a b Hb HF x f Hx (H1, (H2, H3)).
split.
apply -> HF.
exact H1.
split.
now apply Rle_trans with (2 := H2).
now apply H3.
split.
exact H2.
intros k Hk Hl.
destruct (Rle_or_lt k b) as [H|H].
apply H3.
apply <- HF.
exact Hk.
split.
now apply Rle_trans with (2 := Hl).
exact H.
exact Hl.
apply Rlt_le.
apply Rle_lt_trans with (2 := H).
now apply H3.
Qed.

Inductive satisfies_any (F : R -> Prop) :=
Satisfies_any :
F 0 -> ( forall x : R, F x -> F (-x) ) ->
round_pred_total (Rnd_DN_pt F) -> satisfies_any F.

Theorem satisfies_any_eq :
forall F1 F2 : R -> Prop,
( forall x, F1 x <-> F2 x ) ->
satisfies_any F1 ->
satisfies_any F2.
Proof. hammer_hook "Round_pred" "Round_pred.satisfies_any_eq".
intros F1 F2 Heq (Hzero, Hsym, Hrnd).
split.
now apply -> Heq.
intros x Hx.
apply -> Heq.
apply Hsym.
now apply <- Heq.
intros x.
destruct (Hrnd x) as (f, (H1, (H2, H3))).
exists f.
split.
now apply -> Heq.
split.
exact H2.
intros g Hg Hgx.
apply H3.
now apply <- Heq.
exact Hgx.
Qed.

Theorem satisfies_any_imp_DN :
forall F : R -> Prop,
satisfies_any F ->
round_pred (Rnd_DN_pt F).
Proof. hammer_hook "Round_pred" "Round_pred.satisfies_any_imp_DN".
intros F (_,_,Hrnd).
split.
apply Hrnd.
apply Rnd_DN_pt_monotone.
Qed.

Theorem satisfies_any_imp_UP :
forall F : R -> Prop,
satisfies_any F ->
round_pred (Rnd_UP_pt F).
Proof. hammer_hook "Round_pred" "Round_pred.satisfies_any_imp_UP".
intros F Hany.
split.
intros x.
destruct (proj1 (satisfies_any_imp_DN F Hany) (-x)) as (f, Hf).
exists (-f).
rewrite <- (Ropp_involutive x).
apply Rnd_UP_pt_opp.
apply Hany.
exact Hf.
apply Rnd_UP_pt_monotone.
Qed.

Theorem satisfies_any_imp_ZR :
forall F : R -> Prop,
satisfies_any F ->
round_pred (Rnd_ZR_pt F).
Proof. hammer_hook "Round_pred" "Round_pred.satisfies_any_imp_ZR".
intros F Hany.
split.
intros x.
destruct (Rle_or_lt 0 x) as [Hx|Hx].

destruct (proj1 (satisfies_any_imp_DN F Hany) x) as (f, Hf).
exists f.
split.
now intros _.
intros Hx'.

assert (x = 0).
now apply Rle_antisym.
rewrite H in Hf |- *.
clear H Hx Hx'.
rewrite Rnd_DN_pt_idempotent with (1 := Hf).
apply Rnd_UP_pt_refl.
apply Hany.
apply Hany.

destruct (proj1 (satisfies_any_imp_UP F Hany) x) as (f, Hf).
exists f.
split.
intros Hx'.
elim (Rlt_irrefl 0).
now apply Rle_lt_trans with x.
now intros _.

apply Rnd_ZR_pt_monotone.
apply Hany.
Qed.

Definition NG_existence_prop (F : R -> Prop) (P : R -> R -> Prop) :=
forall x d u, ~F x -> Rnd_DN_pt F x d -> Rnd_UP_pt F x u -> P x u \/ P x d.

Theorem satisfies_any_imp_NG :
forall (F : R -> Prop) (P : R -> R -> Prop),
satisfies_any F ->
NG_existence_prop F P ->
round_pred_total (Rnd_NG_pt F P).
Proof. hammer_hook "Round_pred" "Round_pred.satisfies_any_imp_NG".
intros F P Hany HP x.
destruct (proj1 (satisfies_any_imp_DN F Hany) x) as (d, Hd).
destruct (proj1 (satisfies_any_imp_UP F Hany) x) as (u, Hu).
destruct (total_order_T (Rabs (u - x)) (Rabs (d - x))) as [[H|H]|H].

exists u.
split.

split.
apply Hu.
intros g Hg.
destruct (Rle_or_lt x g) as [Hxg|Hxg].
rewrite 2!Rabs_pos_eq.
apply Rplus_le_compat_r.
now apply Hu.
now apply Rle_0_minus.
apply Rle_0_minus.
apply Hu.
apply Rlt_le in Hxg.
apply Rlt_le.
apply Rlt_le_trans with (1 := H).
do 2 rewrite <- (Rabs_minus_sym x).
rewrite 2!Rabs_pos_eq.
apply Rplus_le_compat_l.
apply Ropp_le_contravar.
now apply Hd.
now apply Rle_0_minus.
apply Rle_0_minus.
apply Hd.

right.
intros f Hf.
destruct (Rnd_N_pt_DN_or_UP_eq F x _ _ _ Hd Hu Hf) as [K|K] ; rewrite K.
elim Rlt_not_le with (1 := H).
rewrite <- K.
apply Hf.
apply Hu.
apply refl_equal.

destruct (Req_dec x d) as [He|Hne].

exists x.
split.
apply Rnd_N_pt_refl.
rewrite He.
apply Hd.
right.
intros.
apply Rnd_N_pt_idempotent with (1 := H0).
rewrite He.
apply Hd.
assert (Hf : ~F x).
intros Hf.
apply Hne.
apply sym_eq.
now apply Rnd_DN_pt_idempotent with (1 := Hd).
destruct (HP x _ _ Hf Hd Hu) as [H'|H'].

exists u.
split.
split.
apply Hu.
intros g Hg.
destruct (Rle_or_lt x g) as [Hxg|Hxg].
rewrite 2!Rabs_pos_eq.
apply Rplus_le_compat_r.
now apply Hu.
now apply Rle_0_minus.
apply Rle_0_minus.
apply Hu.
apply Rlt_le in Hxg.
rewrite H.
rewrite 2!Rabs_left1.
apply Ropp_le_contravar.
apply Rplus_le_compat_r.
now apply Hd.
now apply Rle_minus.
apply Rle_minus.
apply Hd.
now left.

exists d.
split.
split.
apply Hd.
intros g Hg.
destruct (Rle_or_lt x g) as [Hxg|Hxg].
rewrite <- H.
rewrite 2!Rabs_pos_eq.
apply Rplus_le_compat_r.
now apply Hu.
now apply Rle_0_minus.
apply Rle_0_minus.
apply Hu.
apply Rlt_le in Hxg.
rewrite 2!Rabs_left1.
apply Ropp_le_contravar.
apply Rplus_le_compat_r.
now apply Hd.
now apply Rle_minus.
apply Rle_minus.
apply Hd.
now left.

exists d.
split.
split.
apply Hd.
intros g Hg.
destruct (Rle_or_lt x g) as [Hxg|Hxg].
apply Rlt_le.
apply Rlt_le_trans with (1 := H).
rewrite 2!Rabs_pos_eq.
apply Rplus_le_compat_r.
now apply Hu.
now apply Rle_0_minus.
apply Rle_0_minus.
apply Hu.
apply Rlt_le in Hxg.
rewrite 2!Rabs_left1.
apply Ropp_le_contravar.
apply Rplus_le_compat_r.
now apply Hd.
now apply Rle_minus.
apply Rle_minus.
apply Hd.
right.
intros f Hf.
destruct (Rnd_N_pt_DN_or_UP_eq F x _ _ _ Hd Hu Hf) as [K|K] ; rewrite K.
apply refl_equal.
elim Rlt_not_le with (1 := H).
rewrite <- K.
apply Hf.
apply Hd.
Qed.

Theorem satisfies_any_imp_NA :
forall F : R -> Prop,
satisfies_any F ->
round_pred (Rnd_NA_pt F).
Proof. hammer_hook "Round_pred" "Round_pred.satisfies_any_imp_NA".
intros F Hany.
split.
assert (H : round_pred_total (Rnd_NG_pt F (fun a b => (Rabs a <= Rabs b)%R))).
apply satisfies_any_imp_NG.
apply Hany.
intros x d u Hf Hd Hu.
destruct (Rle_lt_dec 0 x) as [Hx|Hx].
left.
rewrite Rabs_pos_eq with (1 := Hx).
rewrite Rabs_pos_eq.
apply Hu.
apply Rle_trans with (1 := Hx).
apply Hu.
right.
rewrite Rabs_left with (1 := Hx).
rewrite Rabs_left1.
apply Ropp_le_contravar.
apply Hd.
apply Rlt_le in Hx.
apply Rle_trans with (2 := Hx).
apply Hd.
intros x.
destruct (H x) as (f, Hf).
exists f.
apply <- Rnd_NA_NG_pt.
apply Hf.
apply Hany.
apply Rnd_NA_pt_monotone.
apply Hany.
Qed.

End RND_prop.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Option data-structure
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibReflect.
Generalizable Variables A.

(* --TODO: find a more explicit name? *)

(* ********************************************************************** *)
(* ################################################################# *)
(** * Option type *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definition *)

(** From the Prelude:

  Inductive option A : Type :=
    | Some : A -> option A
    | None : option A.

*)

Arguments Some {A}.
Arguments None {A}.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inhabited *)

Instance Inhab_option : forall A, Inhab (option A).
Proof using. intros. apply (Inhab_of_val None). Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Operations *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [is_some] *)

(** [is_some o] holds when [o] is of the form [Some x] *)

Definition is_some A (o:option A) :=
  match o with
  | None => false
  | Some _ => true
  end.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [unsome_default] *)

(** [unsome_default d o] returns the content of the option, and returns [d]
    in case the option in [None]. *)

Definition unsome_default A d (o:option A) :=
  match o with
  | None => d
  | Some x => x
  end.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [unsome] *)

(** [unsome o] returns the content of the option, and returns an arbitrary
    value in case the option in [None]. *)

Definition unsome `{Inhab A} :=
  unsome_default arbitrary.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [map] *)

(** [map f o] takes an option and returns an option, and maps the function
    [f] to the content of the option if it has one. *)

Definition map A B (f : A -> B) (o : option A) : option B :=
  match o with
  | None => None
  | Some x => Some (f x)
  end.

Lemma map_eq_none_inv : forall A B (f : A->B) o,
  map f o = None ->
  o = None.
Proof using. introv H. destruct o; simpl; inverts* H. Qed.

Lemma map_eq_some_inv : forall A B (f : A->B) o x,
  map f o = Some x ->
  exists z, o = Some z /\ x = f z.
Proof using. introv H. destruct o; simpl; inverts* H. Qed.

Arguments map_eq_none_inv [A] [B] [f] [o].
Arguments map_eq_some_inv [A] [B] [f] [o] [x].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [map_on] *)

(* --TODO: is this really useful? *)
(** [map_on o f] is the same as [map f o], only the arguments are swapped. *)

Definition map_on A B (o : option A) (f : A -> B) : option B :=
  map f o.

Lemma map_on_eq_none_inv : forall A B (f : A -> B) o,
  map f o = None ->
  o = None.
Proof using. introv H. destruct~ o; tryfalse. Qed.

Lemma map_on_eq_some_inv : forall A B (f : A -> B) o x,
  map_on o f = Some x ->
  exists z, o = Some z /\ x = f z.
Proof using. introv H. destruct o; simpl; inverts* H. Qed.

Arguments map_eq_none_inv [A] [B] [f] [o].
Arguments map_on_eq_some_inv [A] [B] [f] [o] [x].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [apply] *)

(** [apply f o] optionnaly applies a function of type [A -> option B] *)

Definition apply A B (f : A->option B) (o : option A) : option B :=
  match o with
  | None => None
  | Some x => f x
  end.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [apply_on] *)

(* --TODO: is this really useful? *)
(** [apply_on o f] is the same as [apply f o] *)

Definition apply_on A B (o : option A) (f : A->option B) : option B:=
  apply f o.

Lemma apply_on_eq_none_inv : forall A B (f : A->option B) o,
  apply_on o f = None ->
     (o = None)
  \/ (exists x, o = Some x /\ f x = None).
Proof using. introv H. destruct o; simpl; inverts* H. Qed.

Lemma apply_on_eq_some_inv : forall A B (f : A->option B) o x,
  apply_on o f = Some x ->
  exists z, o = Some z /\ f z = Some x.
Proof using. introv H. destruct o; simpl; inverts* H. Qed.

Arguments apply_on_eq_none_inv [A] [B] [f] [o].
Arguments apply_on_eq_some_inv [A] [B] [f] [o] [x].


(* Check the behaviour of Discriminate *)

(* Check that Discriminate tries Intro until *)

Lemma l1 : 0 = 1 -> False.
 discriminate 1.
Qed.

Lemma l2 : forall H : 0 = 1, H = H.
 discriminate H.
Qed.

(* Check the variants of discriminate *)

Goal O = S O -> True.
discriminate 1.
Undo.
intros.
discriminate H.
Undo.
Ltac g x := discriminate x.
g H.
Abort.

Goal (forall x y : nat, x = y -> x = S y) -> True.
intros.
try discriminate (H O) || exact I.
Qed.

Goal (forall x y : nat, x = y -> x = S y) -> True.
intros.
ediscriminate (H O).
instantiate (1:=O).
Abort.


(** * Definition and classification of the [Σ] Type, with primitive projections *)
(** In this file, we classify the basic structure of Σ types ([sigT]
    in Coq).  In particular, we classify equalities of dependent pairs
    (inhabitants of Σ types), so that when we have an equality between
    two such pairs, or when we want such an equality, we have a
    systematic way of reducing such equalities to equalities at
    simpler types. *)
Require Import Coq.Classes.Morphisms.
Require Import Crypto.Util.IffT.
Require Import Crypto.Util.Equality.
Require Import Crypto.Util.GlobalSettings.
Require Import Crypto.Util.Notations.

Local Set Primitive Projections.

Declare Scope primproj_type_scope.
Declare Scope primproj_scope.
Delimit Scope primproj_type_scope with primproj_type.
Delimit Scope primproj_scope with primproj.

Import EqNotations.
Module Import Primitive.
  Record sigT {A} P := existT { projT1 : A ; projT2 : P projT1 }.
  Global Arguments existT {_} _ _ _.
  Global Arguments projT1 {_ _} _.
  Global Arguments projT2 {_ _} _.

  Module Export Notations.
    Notation "{ x  &  P }" := (sigT (fun x => P)) : type_scope.
    Notation "{ x : A  & P }" := (sigT (A:=A) (fun x => P)) : type_scope.
    Add Printing Let sigT.
  End Notations.

  Add Printing Let sigT.

  Local Set Implicit Arguments.

  Definition sigT_beq A P (eq_A : A -> A -> bool) (eq_P : forall a a', P a -> P a' -> bool) (X Y : @sigT A P) : bool
    := let (a, b) := X in let (a', b') := Y in (eq_A a a' && eq_P _ _ b b')%bool.
  Global Arguments sigT_beq / .
  Lemma sigT_dec_bl A P eq_A eq_P
        (A_bl : forall x y : A, eq_A x y = true -> x = y)
        (P_bl : forall a a' x y (pf : eq_A a a' = true), eq_P a a' x y = true -> rew [P] (A_bl _ _ pf) in x = y)
        (x y : @sigT A P)
    : sigT_beq eq_A eq_P x y = true -> x = y.
  Proof.
    destruct x as [a b], y as [a' b'].
    specialize (P_bl a a' b b'); cbn.
    generalize dependent (A_bl a a'); clear A_bl; intros A_bl P_bl H.
    edestruct eq_A; cbn in *;
      destruct (eq_A a a');
      first [ specialize (P_bl eq_refl); generalize dependent (A_bl eq_refl)
            | specialize (P_bl H); generalize dependent (A_bl H) ];
      clear A_bl; intros A_bl P_bl; try specialize (P_bl H); subst;
        cbn [eq_rect] in *;
        try reflexivity.
    all: edestruct eq_P; first [ specialize (P_bl eq_refl) | specialize (P_bl H) ]; subst;
      reflexivity.
  Defined.
  Lemma sigT_dec_bl_nd A P eq_A eq_P
        (A_bl : forall x y : A, eq_A x y = true -> x = y)
        (P_bl : forall a a' x y (pf : a = a'), rew [P] pf in x = y)
        (x y : @sigT A P)
    : sigT_beq eq_A eq_P x y = true -> x = y.
  Proof.
    apply (@sigT_dec_bl A P eq_A eq_P A_bl); intros; apply P_bl.
  Defined.

  Lemma sigT_dec_lb A P eq_A (eq_P : forall a a', P a -> P a' -> bool)
        (A_lb : forall x y : A, x = y -> eq_A x y = true)
        (P_lb : forall a (x y : P a), x = y -> eq_P a a x y = true)
        (x y : @sigT A P)
    : x = y -> sigT_beq eq_A eq_P x y = true.
  Proof.
    intro; subst y; specialize (A_lb _ _ (eq_refl (projT1 x))); specialize (P_lb _ _ _ (eq_refl (projT2 x))); cbn in *.
    edestruct eq_A, eq_P; (reflexivity + assumption).
  Defined.
  Definition sigT_eq_dec A P eq_A eq_P
             (A_bl : forall x y : A, eq_A x y = true -> x = y)
             (P_bl : forall a a' x y (pf : eq_A a a' = true), eq_P a a' x y = true -> rew [P] (A_bl _ _ pf) in x = y)
             (A_lb : forall x y : A, x = y -> eq_A x y = true)
             (P_lb : forall a (x y : P a), x = y -> eq_P a a x y = true)
             (x y : @sigT A P)
    : {x = y} + {x <> y}.
  Proof.
    refine (let H := let b := @sigT_beq A P eq_A eq_P x y in if b as b0 return ({b0 = true} + {b0 = false}) then left eq_refl else right eq_refl in
            match H with
            | left e => left (@sigT_dec_bl A P eq_A eq_P A_bl P_bl x y e)
            | right H' => right (fun e => _ (@sigT_dec_lb A P eq_A eq_P A_lb P_lb x y e))
            end).
    congruence.
  Defined.
End Primitive.
Notation "{ x  &  P }" := (sigT (fun x => P%primproj_type)) : primproj_type_scope.
Notation "{ x : A  & P }" := (sigT (A:=A%primproj_type) (fun x => P%primproj_type)) : primproj_type_scope.
Add Printing Let sigT.

Local Arguments f_equal {_ _} _ {_ _} _.

Definition projT1_existT {A B} (a:A) (b:B a) : projT1 (existT B a b) = a := eq_refl.
Definition projT2_existT {A B} (a:A) (b:B a) : projT2 (existT B a b) = b := eq_refl.
Create HintDb cancel_primsig discriminated. #[global] Hint Rewrite @projT1_existT @projT2_existT : cancel_primsig.

(** ** Equality for [sigT] *)
Section sigT.

  (** *** Projecting an equality of a pair to equality of the first components *)
  Definition pr1_path {A} {P : A -> Type} {u v : sigT P} (p : u = v)
  : projT1 u = projT1 v
    := f_equal (@projT1 _ _) p.

  (** *** Projecting an equality of a pair to equality of the second components *)
  Definition pr2_path {A} {P : A -> Type} {u v : sigT P} (p : u = v)
    : eq_rect _ _ (projT2 u) _ (pr1_path p) = projT2 v.
  Proof.
    destruct p; reflexivity.
  Defined.

  (** *** Equality of [sigT] is itself a [sigT] *)
  Definition path_sigT_uncurried {A : Type} {P : A -> Type} (u v : sigT P)
             (pq : sigT (fun p : projT1 u = projT1 v => eq_rect _ _ (projT2 u) _ p = projT2 v))
    : u = v.
  Proof.
    destruct u as [u1 u2], v as [v1 v2]; simpl in *.
    destruct pq as [p q].
    destruct q; simpl in *.
    destruct p; reflexivity.
  Defined.

  (** *** Curried version of proving equality of sigma types *)
  Definition path_sigT {A : Type} {P : A -> Type} (u v : sigT P)
             (p : projT1 u = projT1 v) (q : eq_rect _ _ (projT2 u) _ p = projT2 v)
  : u = v
    := path_sigT_uncurried u v (existT _ p q).

  (** *** Equality of [sigT] when the property is an hProp *)
  Definition path_sigT_hprop {A P} (P_hprop : forall (x : A) (p q : P x), p = q)
             (u v : @sigT A P)
             (p : projT1 u = projT1 v)
    : u = v
    := path_sigT u v p (P_hprop _ _ _).

  (** *** Equivalence of equality of [sigT] with a [sigT] of equality *)
  (** We could actually use [IsIso] here, but for simplicity, we
      don't.  If we wanted to deal with proofs of equality of Σ types
      in dependent positions, we'd need it. *)
  Definition path_sigT_uncurried_iff {A P}
             (u v : @sigT A P)
    : u = v <-> (sigT (fun p : projT1 u = projT1 v => eq_rect _ _ (projT2 u) _ p = projT2 v)).
  Proof.
    split; [ intro; subst; exists eq_refl; reflexivity | apply path_sigT_uncurried ].
  Defined.

  (** *** Induction principle for [@eq (sigT _)] *)
  Definition path_sigT_rect {A P} {u v : @sigT A P} (Q : u = v -> Type)
             (f : forall p q, Q (path_sigT u v p q))
    : forall p, Q p.
  Proof. intro p; specialize (f (pr1_path p) (pr2_path p)); destruct p; exact f. Defined.
  Definition path_sigT_rec {A P u v} (Q : u = v :> @sigT A P -> Set) := path_sigT_rect Q.
  Definition path_sigT_ind {A P u v} (Q : u = v :> @sigT A P -> Prop) := path_sigT_rec Q.

  (** *** Equivalence of equality of [sigT] involving hProps with equality of the first components *)
  Definition path_sigT_hprop_iff {A P} (P_hprop : forall (x : A) (p q : P x), p = q)
             (u v : @sigT A P)
    : u = v <-> (projT1 u = projT1 v)
    := conj (f_equal projT1) (path_sigT_hprop P_hprop u v).

  (** *** Non-dependent classification of equality of [sigT] *)
  Definition path_sigT_nondep {A B : Type} (u v : @sigT A (fun _ => B))
             (p : projT1 u = projT1 v) (q : projT2 u = projT2 v)
  : u = v
    := @path_sigT _ _ u v p (eq_trans (transport_const _ _) q).

  (** *** Classification of transporting across an equality of [sigT]s *)
  Lemma eq_rect_sigT {A x} {P : A -> Type} (Q : forall a, P a -> Prop) (u : sigT (Q x)) {y} (H : x = y)
  : eq_rect x (fun a => sigT (Q a)) u y H
    = existT
        (Q y)
        (eq_rect x P (projT1 u) y H)
        match H in (_ = y) return Q y (eq_rect x P (projT1 u) y H) with
          | eq_refl => projT2 u
        end.
  Proof.
    destruct H; reflexivity.
  Defined.

  (** *** η Principle for [sigT] *)
  Definition sigT_eta {A P} (p : { a : A & P a })
    : p = existT _ (projT1 p) (projT2 p)
    := eq_refl.
End sigT.

(** ** Useful Tactics *)
(** *** [inversion_sigma] *)
(** The built-in [inversion] will frequently leave equalities of
    dependent pairs.  When the first type in the pair is an hProp or
    otherwise simplifies, [inversion_sigma] is useful; it will replace
    the equality of pairs with a pair of equalities, one involving a
    term casted along the other.  This might also prove useful for
    writing a version of [inversion] / [dependent destruction] which
    does not lose information, i.e., does not turn a goal which is
    provable into one which requires axiom K / UIP.  *)
Ltac simpl_proj_exist_in H :=
  repeat match type of H with
         | context G[projT1 (existT _ ?x ?p)]
           => let G' := context G[x] in change G' in H
         | context G[projT2 (existT _ ?x ?p)]
           => let G' := context G[p] in change G' in H
         end.
Ltac induction_sigma_in_as_using H H0 H1 rect :=
  induction H as [H0 H1] using (rect _ _ _ _);
  simpl_proj_exist_in H0;
  simpl_proj_exist_in H1.
Ltac induction_sigma_in_using H rect :=
  let H0 := fresh H in
  let H1 := fresh H in
  induction_sigma_in_as_using H H0 H1 rect.
Ltac inversion_sigma_step :=
  match goal with
  | [ H : _ = existT _ _ _ |- _ ]
    => induction_sigma_in_using H @path_sigT_rect
  | [ H : existT _ _ _ = _ |- _ ]
    => induction_sigma_in_using H @path_sigT_rect
  end.
Ltac inversion_sigma := repeat inversion_sigma_step.