(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

Inductive color : Set :=
  | blue : color
  | red : color
  | yellow : color.

Inductive tree1 : Set :=
  | Leaf : nat -> tree1
  | Nd1 : color -> tree1 -> tree1.

Fixpoint def_cop (T : tree1) : tree1 :=
  match T with
  | Leaf n => Leaf n
  | Nd1 blue t => Nd1 red (def_cop t)
  | Nd1 red t => Nd1 red (def_cop t)
  | Nd1 yellow t => Nd1 yellow (def_cop t)
  end.

Require Import Mx_defs.
Require Extraction.

(* (Mx P A) computes an inhabitant of A but may raise an exception if P *)
Theorem core_cop :
 forall t : tree1,
 Mx (t = def_cop t) {t' : tree1 | t' = def_cop t &  t <> t'}.

fix 1.
intro t; case t; clear t.
  simpl in |- *; intros n. apply Mx_raise. trivial.

  intros c t1; case c; simpl in |- *; clear c.
    (* c = blue *)
    apply Mx_unit.                   (* cheating *)
    apply Mx_try with (1 := core_cop t1).
      intros (t', eg, di); exists (Nd1 red t');
       [ elim eg; trivial | simplify_eq ].
      intro eg; exists (Nd1 red t1); [ elim eg; trivial | simplify_eq ].

     (* c = red *)
    apply Mx_bind with (1 := core_cop t1).
      intros (t', eg, di); apply Mx_unit. exists (Nd1 red t'); [ elim eg; trivial | simplify_eq; assumption ].
      intro eg; simpl in |- *; elim eg; trivial.

    (* c = yellow *)
    apply Mx_bind with (1 := core_cop t1).
      intros (t', eg, di); apply Mx_unit. exists (Nd1 yellow t'); [ elim eg; trivial | simplify_eq; assumption ].
      intro eg; simpl in |- *; elim eg; trivial.
Defined.

Theorem eff_cop : forall t : tree1, {t' : tree1 | t' = def_cop t}.
intro t; apply Mx_try with (1 := core_cop t).
    intros (x, e, n); exists x; auto.
    intro eg; exists t; trivial.
Defined.

(* Extracting terms typed in system F but not in ML *)
(* In the extracted ML program, you have to
    - put an Obj.magic in front of each call to mx_try
      (at least for each recursive (then polymorphic) use of mx_try)
*)

Extraction
 "copy_cheat_extr.ml" Mx_unit Mx_raise Mx_try Mx_bind core_cop eff_cop.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj34synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus (mult lv0 lv1) lv1) (plus (Succ lv0) Zero)) (plus (mult lv0 lv2) lv2)).
Admitted.
QuickChick conj34synthconj2.


Require Export SpecSyntax.

Reserved Notation "⟨ x : τ ∈ Γ ⟩"
  ( at level 0,
    x at level 98,
    τ at level 98,
    Γ at level 98).

Inductive GetTmVar : Env → Ix → Exp → Prop :=
  | tm_here {Γ τ} :
      ⟨   O : τ[wkm] ∈ Γ ▻ τ ⟩
  | tm_there_evar {Γ x τ τ'} :
      ⟨   x : τ      ∈ Γ      ⟩ →
      ⟨ S x : τ[wkm] ∈ Γ ▻ τ' ⟩
  | tm_there_τvar {Γ x τ k'} :
      ⟨   x : τ      ∈ Γ      ⟩ →
      ⟨ S x : τ[wkm] ∈ Γ ► k' ⟩
  | tm_there_γvar {Γ x τ τ1' τ2' k'} :
      ⟨   x : τ      ∈ Γ      ⟩ →
      ⟨ S x : τ[wkm] ∈ Γ ◅ τ1' ~ τ2' ∷ k' ⟩
where "⟨ x : τ ∈ Γ ⟩" := (GetTmVar Γ x τ).

Reserved Notation "⟨ α ∷ k ∈ Γ ⟩"
  ( at level 0,
    α at level 98,
    k at level 98,
    Γ at level 98).

Inductive GetTyVar : Env → Ix → Kind → Prop :=
  | ty_here {Γ k} :
      ⟨   O ∷ k ∈ Γ ► k ⟩
  | ty_there_evar {Γ α k τ'} :
      ⟨   α ∷ k ∈ Γ      ⟩ →
      ⟨ S α ∷ k ∈ Γ ▻ τ' ⟩
  | ty_there_τvar {Γ α k k'} :
      ⟨   α ∷ k ∈ Γ      ⟩ →
      ⟨ S α ∷ k ∈ Γ ► k' ⟩
  | ty_there_γvar {Γ α k τ1' τ2' k'} :
      ⟨   α ∷ k ∈ Γ      ⟩ →
      ⟨ S α ∷ k ∈ Γ ◅ τ1' ~ τ2' ∷ k' ⟩
where "⟨ α ∷ k ∈ Γ ⟩" := (GetTyVar Γ α k).

Reserved Notation "⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩"
  ( at level 0,
    c at level 98,
    τ1 at level 98,
    τ2 at level 98,
    k at level 98,
    Γ at level 98).

Inductive GetCoVar : Env → Ix → Exp → Exp → Kind → Prop :=
  | co_here {Γ τ1 τ2 k} :
      ⟨   O : τ1[wkm] ~ τ2[wkm] ∷ k ∈ Γ ◅ τ1 ~ τ2 ∷ k ⟩
  | co_there_evar {Γ c τ1 τ2 k τ'} :
      ⟨   c : τ1      ~ τ2      ∷ k ∈ Γ      ⟩ →
      ⟨ S c : τ1[wkm] ~ τ2[wkm] ∷ k ∈ Γ ▻ τ' ⟩
  | co_there_τvar {Γ c τ1 τ2 k k'} :
      ⟨   c : τ1      ~ τ2      ∷ k ∈ Γ      ⟩ →
      ⟨ S c : τ1[wkm] ~ τ2[wkm] ∷ k ∈ Γ ► k' ⟩
  | co_there_γvar {Γ c τ1 τ2 k τ1' τ2' k'} :
      ⟨   c : τ1      ~ τ2      ∷ k ∈ Γ      ⟩ →
      ⟨ S c : τ1[wkm] ~ τ2[wkm] ∷ k ∈ Γ ◅ τ1' ~ τ2' ∷ k' ⟩
where "⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩" := (GetCoVar Γ c τ1 τ2 k).

Reserved Notation "⟨ Γ ⊢ τ ∷ k ⟩"
  ( at level 0,
    Γ at level 98,
    τ at level 98,
    k at level 98).

Inductive Ty (Γ: Env) : Exp → Kind → Prop :=
  | TyVar {α k} :
      ⟨ α ∷ k ∈ Γ ⟩ →
      ⟨ Γ ⊢ var α ∷ k ⟩
  | TAbs {τ k1 k2} :
      ⟨ Γ ► k1 ⊢ τ ∷ k2 ⟩ →
      ⟨ Γ ⊢ τabs k1 τ ∷ karr k1 k2 ⟩
  | TApp {τ1 τ2 k1 k2}:
      ⟨ Γ ⊢ τ1 ∷ karr k1 k2 ⟩ →
      ⟨ Γ ⊢ τ2 ∷ k1 ⟩ →
      ⟨ Γ ⊢ τapp τ1 τ2 ∷ k2 ⟩
  | Arr {τ1 τ2} :
      ⟨ Γ ⊢ τ1 ∷ kstar ⟩ →
      ⟨ Γ ⊢ τ2 ∷ kstar ⟩ →
      ⟨ Γ ⊢ arr τ1 τ2 ∷ kstar ⟩
  | Arrτ {τ k} :
      ⟨ Γ ► k ⊢ τ ∷ kstar ⟩ →
      ⟨ Γ ⊢ arrτ k τ ∷ kstar ⟩
  | Arrγ {τ1 τ2 τ3 k} :
      ⟨ Γ ⊢ τ1 ∷ k ⟩ →
      ⟨ Γ ⊢ τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ τ3 ∷ kstar ⟩ →
      ⟨ Γ ⊢ arrγ τ1 τ2 k τ3 ∷ kstar ⟩
where "⟨ Γ ⊢ τ ∷ k ⟩" := (Ty Γ τ k).

Reserved Notation "⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ k ⟩"
  ( at level 0,
    Γ at level 98,
    γ at level 98,
    τ1 at level 98,
    τ2 at level 98,
    k at level 98).

Inductive Co (Γ: Env) : Exp → Exp → Exp → Kind → Prop :=
  | CoVar {c τ1 τ2 k} :
      ⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩ →
      ⟨ Γ ⊢ var c : τ1 ~ τ2 ∷ k ⟩
  | CoTAbs {γ τ1 τ2 k1 k2} :
      ⟨ Γ ► k1 ⊢ γ : τ1 ~ τ2 ∷ k2 ⟩ →
      ⟨ Γ ⊢ coτabs k1 γ : τabs k1 τ1 ~ τabs k1 τ2 ∷ karr k1 k2 ⟩
  | CoTApp {γ1 γ2 τ11 τ12 τ21 τ22 k1 k2 }:
      ⟨ Γ ⊢ γ1 : τ11 ~ τ21 ∷ karr k1 k2 ⟩ →
      ⟨ Γ ⊢ γ2 : τ12 ~ τ22 ∷ k1 ⟩ →
      ⟨ Γ ⊢ coτapp γ1 γ2 : τapp τ11 τ12 ~ τapp τ21 τ22 ∷ k2 ⟩
  | CoArr {γ1 γ2 τ11 τ12 τ21 τ22}:
      ⟨ Γ ⊢ γ1 : τ11 ~ τ21 ∷ kstar ⟩ →
      ⟨ Γ ⊢ γ2 : τ12 ~ τ22 ∷ kstar ⟩ →
      ⟨ Γ ⊢ coarr γ1 γ2 : arr τ11 τ12 ~ arr τ21 τ22 ∷ kstar ⟩
  | CoArrτ {γ τ1 τ2 k} :
      ⟨ Γ ► k ⊢ γ : τ1 ~ τ2 ∷ kstar ⟩ →
      ⟨ Γ ⊢ coarrτ k γ : arrτ k τ1 ~ arrτ k τ2 ∷ kstar ⟩
  | CoArrγ {γ1 γ2 γ3 τ1 τ1' τ2 τ2' τ3 τ3' k} :
      ⟨ Γ ⊢ γ1 : τ1 ~ τ1' ∷ k ⟩ →
      ⟨ Γ ⊢ γ2 : τ2 ~ τ2' ∷ k ⟩ →
      ⟨ Γ ⊢ γ3 : τ3 ~ τ3' ∷ kstar ⟩ →
      ⟨ Γ ⊢ coarrγ γ1 γ2 k γ3 : arrγ τ1 τ2 k τ3 ~ arrγ τ1' τ2' k τ3' ∷ kstar ⟩
  | CoInvArr₁ {γ τ1 τ2 τ3 τ4}:
      ⟨ Γ ⊢ γ : arr τ1 τ2 ~ arr τ3 τ4 ∷ kstar ⟩ →
      ⟨ Γ ⊢ coinvarr₁ γ : τ1 ~ τ3 ∷ kstar ⟩
  | CoInvArr₂ {γ τ1 τ2 τ3 τ4}:
      ⟨ Γ ⊢ γ : arr τ1 τ2 ~ arr τ3 τ4 ∷ kstar ⟩ →
      ⟨ Γ ⊢ coinvarr₂ γ : τ2 ~ τ4 ∷ kstar ⟩
  | CoInvArrτ {γ1 γ2 τ1 τ2 τ3 τ4 k} :
      ⟨ Γ ⊢ γ1 : arrτ k τ1 ~ arrτ k τ2 ∷ kstar ⟩ →
      ⟨ Γ ⊢ γ2 : τ3 ~ τ4 ∷ k ⟩ →
      ⟨ Γ ⊢ coinvarrτ γ1 γ2 : τ1[beta1 τ3] ~ τ2[beta1 τ4] ∷ kstar ⟩
  | CoInvArrγ₁ {γ τ1 τ1' τ2 τ2' τ3 τ3' k} :
      ⟨ Γ ⊢ γ : arrγ τ1 τ2 k τ3 ~ arrγ τ1' τ2' k τ3' ∷ kstar ⟩ →
      ⟨ Γ ⊢ coinvarrγ₁ γ : τ1 ~ τ1' ∷ k ⟩
  | CoInvArrγ₂ {γ τ1 τ1' τ2 τ2' τ3 τ3' k} :
      ⟨ Γ ⊢ γ : arrγ τ1 τ2 k τ3 ~ arrγ τ1' τ2' k τ3' ∷ kstar ⟩ →
      ⟨ Γ ⊢ coinvarrγ₂ γ : τ2 ~ τ2' ∷ k ⟩
  | CoInvArrγ₃ {γ τ1 τ1' τ2 τ2' τ3 τ3' k} :
      ⟨ Γ ⊢ γ : arrγ τ1 τ2 k τ3 ~ arrγ τ1' τ2' k τ3' ∷ kstar ⟩ →
      ⟨ Γ ⊢ coinvarrγ₃ γ : τ3 ~ τ3' ∷ kstar ⟩
  | CoBeta {γ1 γ2 τ1 τ2 τ1' τ2' k1 k2} :
      ⟨ Γ ► k1 ⊢ γ1 : τ1 ~ τ1' ∷ k2 ⟩ →
      ⟨ Γ ⊢ γ2 : τ2 ~ τ2' ∷ k1 ⟩ →
      ⟨ Γ ⊢ cobeta k1 γ1 γ2 : τapp (τabs k1 τ1) τ2 ~ τ1'[beta1 τ2'] ∷ k2 ⟩
  | CoRefl {τ k} :
      ⟨ Γ ⊢ τ ∷ k ⟩ →
      ⟨ Γ ⊢ corefl τ : τ ~ τ ∷ k ⟩
  | CoSym {γ τ1 τ2 k} :
      ⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ cosym γ : τ2 ~ τ1 ∷ k ⟩
  | CoTrans {γ1 γ2 τ1 τ2 τ3 k} :
      ⟨ Γ ⊢ γ1 : τ1 ~ τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ γ2 : τ2 ~ τ3 ∷ k ⟩ →
      ⟨ Γ ⊢ cotrans γ1 γ2 : τ1 ~ τ3 ∷ k ⟩
where "⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ k ⟩" := (Co Γ γ τ1 τ2 k).

Reserved Notation "⟨ Γ ⊢ γ : τ1 ↝ τ2 ∷ k ⟩"
  ( at level 0,
    Γ at level 98,
    γ at level 98,
    τ1 at level 98,
    τ2 at level 98,
    k at level 98).

Inductive Red (Γ: Env) : Exp → Exp → Exp → Kind → Prop :=
  | RedVar {c τ1 τ2 k} :
      ⟨ c : τ1 ~ τ2 ∷ k ∈ Γ ⟩ →
      ⟨ Γ ⊢ var c : τ1 ↝ τ2 ∷ k ⟩
  | RedTAbs {γ τ1 τ2 k1 k2} :
      ⟨ Γ ► k1 ⊢ γ : τ1 ↝ τ2 ∷ k2 ⟩ →
      ⟨ Γ ⊢ coτabs k1 γ : τabs k1 τ1 ↝ τabs k1 τ2 ∷ karr k1 k2 ⟩
  | RedTApp {γ1 γ2 τ11 τ12 τ21 τ22 k1 k2 }:
      ⟨ Γ ⊢ γ1 : τ11 ↝ τ21 ∷ karr k1 k2 ⟩ →
      ⟨ Γ ⊢ γ2 : τ12 ↝ τ22 ∷ k1 ⟩ →
      ⟨ Γ ⊢ coτapp γ1 γ2 : τapp τ11 τ12 ↝ τapp τ21 τ22 ∷ k2 ⟩
  | RedArr {γ1 γ2 τ11 τ12 τ21 τ22}:
      ⟨ Γ ⊢ γ1 : τ11 ↝ τ21 ∷ kstar ⟩ →
      ⟨ Γ ⊢ γ2 : τ12 ↝ τ22 ∷ kstar ⟩ →
      ⟨ Γ ⊢ coarr γ1 γ2 : arr τ11 τ12 ↝ arr τ21 τ22 ∷ kstar ⟩
  | RedArrτ {γ τ1 τ2 k} :
      ⟨ Γ ► k ⊢ γ : τ1 ↝ τ2 ∷ kstar ⟩ →
      ⟨ Γ ⊢ coarrτ k γ : arrτ k τ1 ↝ arrτ k τ2 ∷ kstar ⟩
  | RedArrγ {γ1 γ2 γ3 τ1 τ1' τ2 τ2' τ3 τ3' k} :
      ⟨ Γ ⊢ γ1 : τ1 ↝ τ1' ∷ k ⟩ →
      ⟨ Γ ⊢ γ2 : τ2 ↝ τ2' ∷ k ⟩ →
      ⟨ Γ ⊢ γ3 : τ3 ↝ τ3' ∷ kstar ⟩ →
      ⟨ Γ ⊢ coarrγ γ1 γ2 k γ3 : arrγ τ1 τ2 k τ3 ↝ arrγ τ1' τ2' k τ3' ∷ kstar ⟩
  | RedBeta {γ1 γ2 τ1 τ2 τ1' τ2' k1 k2} :
      ⟨ Γ ► k1 ⊢ γ1 : τ1 ↝ τ1' ∷ k2 ⟩ →
      ⟨ Γ ⊢ γ2 : τ2 ↝ τ2' ∷ k1 ⟩ →
      ⟨ Γ ⊢ cobeta k1 γ1 γ2 : τapp (τabs k1 τ1) τ2 ↝ τ1'[beta1 τ2'] ∷ k2 ⟩
  | RedReflVar {α k} :
      ⟨ α ∷ k ∈ Γ ⟩ →
      ⟨ Γ ⊢ corefl (var α) : var α ↝ var α ∷ k ⟩
where "⟨ Γ ⊢ γ : τ1 ↝ τ2 ∷ k ⟩" := (Red Γ γ τ1 τ2 k).

Reserved Notation "⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ k ⟩"
  ( at level 0,
    Γ at level 98,
    γs at level 98,
    τ1 at level 98,
    τ2 at level 98,
    k at level 98).

Inductive RedStar (Γ: Env) : list Exp → Exp → Exp → Kind → Prop :=
  | RedStarNil {τ k}:
      ⟨ Γ ⊢ τ ∷ k ⟩ →
      ⟨ Γ ⊢ nil : τ ↝* τ ∷ k ⟩
  | RedStarCons {τ1 τ2 τ3 γs γ k} :
      ⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ γ : τ2 ↝ τ3 ∷ k ⟩ →
      ⟨ Γ ⊢ cons γ γs : τ1 ↝* τ3 ∷ k ⟩
where "⟨ Γ ⊢ γs : τ1 ↝* τ2 ∷ k ⟩" := (RedStar Γ γs τ1 τ2 k).

Reserved Notation "⟨ Γ ⊢ s : τ ⟩"
  ( at level 0,
    Γ at level 98,
    s at level 98,
    τ at level 98).

Inductive Tm (Γ: Env) : Exp → Exp → Prop :=
  | Var {x τ} :
      ⟨ x : τ ∈ Γ ⟩ →
      ⟨ Γ ⊢ var x : τ ⟩
  | Abs {s τ1 τ2} :
      ⟨ Γ ⊢ τ1 ∷ kstar ⟩ →
      ⟨ Γ ▻ τ1 ⊢ s : τ2[wkm] ⟩ →
      ⟨ Γ ⊢ τ2 ∷ kstar ⟩ → (* Remove after adding strengthening lemmas *)
      ⟨ Γ ⊢ abs τ1 s : arr τ1 τ2 ⟩
  | Absτ {s τ k} :
      ⟨ Γ ► k ⊢ s : τ ⟩ →
      ⟨ Γ ⊢ absτ k s : arrτ k τ ⟩
  | Absγ {s τ1 τ2 τ3 k} :
      ⟨ Γ ◅ τ1 ~ τ2 ∷ k ⊢ s : τ3[wkm] ⟩ →
      ⟨ Γ ⊢ τ1 ∷ k ⟩ →
      ⟨ Γ ⊢ τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ τ3 ∷ kstar ⟩ → (* Remove after adding strengthening lemmas *)
      ⟨ Γ ⊢ absγ τ1 τ2 k s : arrγ τ1 τ2 k τ3 ⟩
  | App {s1 s2 τ1 τ2} :
      ⟨ Γ ⊢ s1 : arr τ1 τ2 ⟩ →
      ⟨ Γ ⊢ s2 : τ1 ⟩ →
      ⟨ Γ ⊢ app s1 s2 : τ2 ⟩
  | Appτ {s τ1 τ2 k} :
      ⟨ Γ ⊢ s : arrτ k τ1 ⟩ →
      ⟨ Γ ⊢ τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ appτ s τ2 : τ1[beta1 τ2] ⟩
  | Appγ {s γ τ1 τ2 τ3 k} :
      ⟨ Γ ⊢ s : arrγ τ1 τ2 k τ3 ⟩ →
      ⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ k ⟩ →
      ⟨ Γ ⊢ appγ s γ : τ3 ⟩
  | Cast {s γ τ1 τ2} :
      ⟨ Γ ⊢ s : τ1 ⟩ →
      ⟨ Γ ⊢ γ : τ1 ~ τ2 ∷ kstar ⟩ →
      ⟨ Γ ⊢ cast s γ : τ2 ⟩
where "⟨ Γ ⊢ s : τ ⟩" := (Tm Γ s τ).


(** Wasm AST to binary.
Breaks non-determinism ties; see binary_format_spec.v for the spec. *)
Require Import datatypes_properties numerics.
From compcert Require Integers.
Require Import Byte.
Require leb128.
Require Import Coq.Arith.Le.
From mathcomp Require Import ssreflect ssrfun ssrnat ssrbool eqtype seq.

Definition binary_of_value_type (t : value_type) : byte :=
  match t with
  | T_i32 => x7f
  | T_i64 => x7e
  | T_f32 => x7d
  | T_f64 => x7c
  end.

Definition binary_of_block_type_aux (bt : list value_type) : list byte :=
  match bt with
  | nil => x40 :: nil
  | cons t nil => binary_of_value_type t :: nil
  | _ => (* TODO: this should never occur *) nil
  end.

Definition binary_of_block_type (ft : function_type) : list byte :=
  match ft with
  | Tf nil rt => binary_of_block_type_aux rt
  | _ => (* TODO: should never happen *) nil
  end.

Definition binary_of_u32_nat (n : nat) : list byte :=
  leb128.encode_unsigned (BinNatDef.N.of_nat n).

Definition binary_of_idx n := binary_of_u32_nat n.

Definition binary_of_vec {A} (f : A -> list byte) (es : list A) : list byte :=
  (binary_of_u32_nat (List.length es)) ++ (List.concat (List.map f es)).

Definition binary_of_memarg a o : list byte :=
  binary_of_u32_nat a ++ binary_of_u32_nat o.

Definition binary_of_i32 (x : i32) : list byte :=
  leb128.encode_signed (Wasm_int.Int32.signed x).

Definition binary_of_i64 (x : i64) : list byte :=
  leb128.encode_signed (Wasm_int.Int64.signed x).

Definition binary_of_f32 (x : f32) : list byte :=
  List.map byte_of_compcert_byte (serialise_f32 x).

Definition binary_of_f64 (x : f64) : list byte :=
  List.map byte_of_compcert_byte (serialise_f64 x).

(** An opaque definition for cases that can’t happen because of the well-formed properties. **)
Definition dummy : list byte.
Proof. exact (x00 :: x00 :: x00 :: nil). Qed.

Fixpoint binary_of_be (be : basic_instruction) : list byte :=
  let binary_of_instrs bes := List.concat (List.map binary_of_be bes) in
  match be with
  | BI_unreachable => x00 :: nil
  | BI_nop => x01 :: nil
  | BI_block rt ins =>
    x02 :: binary_of_block_type rt ++ binary_of_instrs ins ++ x0b :: nil
  | BI_loop rt ins =>
    x03 :: binary_of_block_type rt ++ binary_of_instrs ins ++ x0b :: nil
  | BI_if rt ins nil =>
    x04 :: binary_of_block_type rt ++ binary_of_instrs ins ++ x0b :: nil
  | BI_if rt ins1 ins2 =>
    x04 :: binary_of_block_type rt ++ binary_of_instrs ins1 ++ x05 :: nil ++ binary_of_instrs ins2 ++ x0b :: nil
  | BI_br l => x0c :: binary_of_idx l
  | BI_br_if l => x0d :: binary_of_idx l
  | BI_br_table ls l_N =>
    x0e :: binary_of_vec binary_of_idx ls ++ binary_of_idx l_N
  | BI_return => x0f :: nil
  | BI_call x => x10 :: binary_of_idx x
  | BI_call_indirect x => x11 :: binary_of_idx x ++ x00 :: nil
  | BI_drop => x1a :: nil
  | BI_select => x1b :: nil
  | BI_get_local x => x20 :: binary_of_idx x
  | BI_set_local x => x21 :: binary_of_idx x
  | BI_tee_local x => x22 :: binary_of_idx x
  | BI_get_global x => x23 :: binary_of_idx x
  | BI_set_global x => x24 :: binary_of_idx x
  | BI_load T_i32 None a o => x28 :: binary_of_memarg a o
  | BI_load T_i64 None a o => x29 :: binary_of_memarg a o
  | BI_load T_f32 None a o => x2a :: binary_of_memarg a o
  | BI_load T_f32 (Some _) _ _ => dummy
  | BI_load T_f64 None a o => x2b :: binary_of_memarg a o
  | BI_load T_f64 (Some _) _ _ => dummy
  | BI_load T_i32 (Some (Tp_i8, SX_S)) a o => x2c :: binary_of_memarg a o
  | BI_load T_i32 (Some (Tp_i8, SX_U)) a o => x2d :: binary_of_memarg a o
  | BI_load T_i32 (Some (Tp_i16, SX_S)) a o => x2e :: binary_of_memarg a o
  | BI_load T_i32 (Some (Tp_i16, SX_U)) a o => x2f :: binary_of_memarg a o
  | BI_load T_i32 (Some (Tp_i32, _)) _ _ => dummy
  | BI_load T_i64 (Some (Tp_i8, SX_S)) a o => x30 :: binary_of_memarg a o
  | BI_load T_i64 (Some (Tp_i8, SX_U)) a o => x31 :: binary_of_memarg a o
  | BI_load T_i64 (Some (Tp_i16, SX_S)) a o => x32 :: binary_of_memarg a o
  | BI_load T_i64 (Some (Tp_i16, SX_U)) a o => x33 :: binary_of_memarg a o
  | BI_load T_i64 (Some (Tp_i32, SX_S)) a o => x34 :: binary_of_memarg a o
  | BI_load T_i64 (Some (Tp_i32, SX_U)) a o => x35 :: binary_of_memarg a o
  | BI_store T_i32 None a o => x36 :: binary_of_memarg a o
  | BI_store T_i64 None a o => x37 :: binary_of_memarg a o
  | BI_store T_f32 None a o => x38 :: binary_of_memarg a o
  | BI_store T_f32 (Some _) _ _  => dummy
  | BI_store T_f64 None a o => x39 :: binary_of_memarg a o
  | BI_store T_f64 (Some _) _ _ => dummy
  | BI_store T_i32 (Some Tp_i8) a o => x3a :: binary_of_memarg a o
  | BI_store T_i32 (Some Tp_i16) a o => x3b :: binary_of_memarg a o
  | BI_store T_i32 (Some Tp_i32) _ _ => dummy
  | BI_store T_i64 (Some Tp_i8) a o => x3c :: binary_of_memarg a o
  | BI_store T_i64 (Some Tp_i16) a o => x3d :: binary_of_memarg a o
  | BI_store T_i64 (Some Tp_i32) a o => x3e :: binary_of_memarg a o
  | BI_current_memory => x3f :: x00 :: nil
  | BI_grow_memory => x40 :: x00 :: nil
  | BI_const (VAL_int32 x) => x41 :: binary_of_i32 x
  | BI_const (VAL_int64 x) => x42 :: binary_of_i64 x
  | BI_const (VAL_float32 x) => x43 :: binary_of_f32 x
  | BI_const (VAL_float64 x) => x44 :: binary_of_f64 x
  | BI_testop T_i32 Eqz => x45 :: nil
  | BI_testop T_i64 Eqz => x50 :: nil
  | BI_testop T_f32 _ => dummy
  | BI_testop T_f64 _ => dummy
  | BI_relop T_i32 (Relop_i ROI_eq) => x46 :: nil
  | BI_relop T_i32 (Relop_i ROI_ne) => x47 :: nil
  | BI_relop T_i32 (Relop_i (ROI_lt SX_S)) => x48 :: nil
  | BI_relop T_i32 (Relop_i (ROI_lt SX_U)) => x49 :: nil
  | BI_relop T_i32 (Relop_i (ROI_gt SX_S)) => x4a :: nil
  | BI_relop T_i32 (Relop_i (ROI_gt SX_U)) => x4b :: nil
  | BI_relop T_i32 (Relop_i (ROI_le SX_S)) => x4c :: nil
  | BI_relop T_i32 (Relop_i (ROI_le SX_U)) => x4d :: nil
  | BI_relop T_i32 (Relop_i (ROI_ge SX_S)) => x4e :: nil
  | BI_relop T_i32 (Relop_i (ROI_ge SX_U)) => x4f :: nil
  | BI_relop T_i64 (Relop_i ROI_eq) => x51 :: nil
  | BI_relop T_i64 (Relop_i ROI_ne) => x52 :: nil
  | BI_relop T_i64 (Relop_i (ROI_lt SX_S)) => x53 :: nil
  | BI_relop T_i64 (Relop_i (ROI_lt SX_U)) => x54 :: nil
  | BI_relop T_i64 (Relop_i (ROI_gt SX_S)) => x55 :: nil
  | BI_relop T_i64 (Relop_i (ROI_gt SX_U)) => x56 :: nil
  | BI_relop T_i64 (Relop_i (ROI_le SX_S)) => x57 :: nil
  | BI_relop T_i64 (Relop_i (ROI_le SX_U)) => x58 :: nil
  | BI_relop T_i64 (Relop_i (ROI_ge SX_S)) => x59 :: nil
  | BI_relop T_i64 (Relop_i (ROI_ge SX_U)) => x5a :: nil
  | BI_relop T_f32 (Relop_i _) => dummy
  | BI_relop T_f64 (Relop_i _) => dummy
  | BI_relop T_f32 (Relop_f ROF_eq) => x5b :: nil
  | BI_relop T_f32 (Relop_f ROF_ne) => x5c :: nil
  | BI_relop T_f32 (Relop_f ROF_lt) => x5d :: nil
  | BI_relop T_f32 (Relop_f ROF_gt) => x5e :: nil
  | BI_relop T_f32 (Relop_f ROF_le) => x5f :: nil
  | BI_relop T_f32 (Relop_f ROF_ge) => x60 :: nil
  | BI_relop T_f64 (Relop_f ROF_eq) => x61 :: nil
  | BI_relop T_f64 (Relop_f ROF_ne) => x62 :: nil
  | BI_relop T_f64 (Relop_f ROF_lt) => x63 :: nil
  | BI_relop T_f64 (Relop_f ROF_gt) => x64 :: nil
  | BI_relop T_f64 (Relop_f ROF_le) => x65 :: nil
  | BI_relop T_f64 (Relop_f ROF_ge) => x66 :: nil
  | BI_relop T_i32 (Relop_f _) => dummy
  | BI_relop T_i64 (Relop_f _) => dummy
  | BI_unop T_i32 (Unop_i UOI_clz) => x67 :: nil
  | BI_unop T_i32 (Unop_i UOI_ctz) => x68 :: nil
  | BI_unop T_i32 (Unop_i UOI_popcnt) => x69 :: nil
  | BI_binop T_i32 (Binop_i BOI_add) => x6a :: nil
  | BI_binop T_i32 (Binop_i BOI_sub) => x6b :: nil
  | BI_binop T_i32 (Binop_i BOI_mul) => x6c :: nil
  | BI_binop T_i32 (Binop_i (BOI_div SX_S)) => x6d :: nil
  | BI_binop T_i32 (Binop_i (BOI_div SX_U)) => x6e :: nil
  | BI_binop T_i32 (Binop_i (BOI_rem SX_S)) => x6f :: nil
  | BI_binop T_i32 (Binop_i (BOI_rem SX_U)) => x70 :: nil
  | BI_binop T_i32 (Binop_i BOI_and) => x71 :: nil
  | BI_binop T_i32 (Binop_i BOI_or) => x72 :: nil
  | BI_binop T_i32 (Binop_i BOI_xor) => x73 :: nil
  | BI_binop T_i32 (Binop_i BOI_shl) => x74 :: nil
  | BI_binop T_i32 (Binop_i (BOI_shr SX_S)) => x75 :: nil
  | BI_binop T_i32 (Binop_i (BOI_shr SX_U)) => x76 :: nil
  | BI_binop T_i32 (Binop_i BOI_rotl) => x77 :: nil
  | BI_binop T_i32 (Binop_i BOI_rotr) => x78 :: nil
  | BI_binop T_f32 (Binop_i _) => dummy
  | BI_binop T_f64 (Binop_i _) => dummy
  | BI_unop T_i64 (Unop_i UOI_clz) => x79 :: nil
  | BI_unop T_i64 (Unop_i UOI_ctz) => x7a :: nil
  | BI_unop T_i64 (Unop_i UOI_popcnt) => x7b :: nil
  | BI_unop T_f32 (Unop_i _) => dummy
  | BI_unop T_f64 (Unop_i _) => dummy
  | BI_binop T_i64 (Binop_i BOI_add) => x7c :: nil
  | BI_binop T_i64 (Binop_i BOI_sub) => x7d :: nil
  | BI_binop T_i64 (Binop_i BOI_mul) => x7e :: nil
  | BI_binop T_i64 (Binop_i (BOI_div SX_S)) => x7f :: nil
  | BI_binop T_i64 (Binop_i (BOI_div SX_U)) => x80 :: nil
  | BI_binop T_i64 (Binop_i (BOI_rem SX_S)) => x81 :: nil
  | BI_binop T_i64 (Binop_i (BOI_rem SX_U)) => x82 :: nil
  | BI_binop T_i64 (Binop_i BOI_and) => x83 :: nil
  | BI_binop T_i64 (Binop_i BOI_or) => x84 :: nil
  | BI_binop T_i64 (Binop_i BOI_xor) => x85 :: nil
  | BI_binop T_i64 (Binop_i BOI_shl) => x86 :: nil
  | BI_binop T_i64 (Binop_i (BOI_shr SX_S)) => x87 :: nil
  | BI_binop T_i64 (Binop_i (BOI_shr SX_U)) => x88 :: nil
  | BI_binop T_i64 (Binop_i BOI_rotl) => x89 :: nil
  | BI_binop T_i64 (Binop_i BOI_rotr) => x8a :: nil
  | BI_unop T_f32 (Unop_f UOF_abs) => x8b :: nil
  | BI_unop T_f32 (Unop_f UOF_neg) => x8c :: nil
  | BI_unop T_f32 (Unop_f UOF_ceil) => x8d :: nil
  | BI_unop T_f32 (Unop_f UOF_floor) => x8e :: nil
  | BI_unop T_f32 (Unop_f UOF_trunc) => x8f :: nil
  | BI_unop T_f32 (Unop_f UOF_nearest) => x90 :: nil
  | BI_unop T_f32 (Unop_f UOF_sqrt) => x91 :: nil
  | BI_unop T_i32 (Unop_f _) => dummy
  | BI_unop T_i64 (Unop_f _) => dummy
  | BI_binop T_f32 (Binop_f BOF_add) => x92 :: nil
  | BI_binop T_f32 (Binop_f BOF_sub) => x93 :: nil
  | BI_binop T_f32 (Binop_f BOF_mul) => x94 :: nil
  | BI_binop T_f32 (Binop_f BOF_div) => x95 :: nil
  | BI_binop T_f32 (Binop_f BOF_min) => x96 :: nil
  | BI_binop T_f32 (Binop_f BOF_max) => x97 :: nil
  | BI_binop T_f32 (Binop_f BOF_copysign) => x98 :: nil
  | BI_unop T_f64 (Unop_f UOF_abs) => x99 :: nil
  | BI_unop T_f64 (Unop_f UOF_neg) => x9a :: nil
  | BI_unop T_f64 (Unop_f UOF_ceil) => x9b :: nil
  | BI_unop T_f64 (Unop_f UOF_floor) => x9c :: nil
  | BI_unop T_f64 (Unop_f UOF_trunc) => x9d :: nil
  | BI_unop T_f64 (Unop_f UOF_nearest) => x9e :: nil
  | BI_unop T_f64 (Unop_f UOF_sqrt) => x9f :: nil
  | BI_binop T_f64 (Binop_f BOF_add) => xa0 :: nil
  | BI_binop T_f64 (Binop_f BOF_sub) => xa1 :: nil
  | BI_binop T_f64 (Binop_f BOF_mul) => xa2 :: nil
  | BI_binop T_f64 (Binop_f BOF_div) => xa3 :: nil
  | BI_binop T_f64 (Binop_f BOF_min) => xa4 :: nil
  | BI_binop T_f64 (Binop_f BOF_max) => xa5 :: nil
  | BI_binop T_f64 (Binop_f BOF_copysign) => xa6 :: nil
  | BI_binop T_i32 (Binop_f _) => dummy
  | BI_binop T_i64 (Binop_f _) => dummy
  (* TODO: I am really not sure whether the cases below are right :-s *)
  | BI_cvtop T_i32 CVO_convert T_i64 (Some SX_U) (* TODO: is this correct? *) => xa7 :: nil
  | BI_cvtop T_i32 CVO_convert T_i64 _ => dummy
  | BI_cvtop T_i32 CVO_convert T_f32 (Some SX_S) => xa8 :: nil
  | BI_cvtop T_i32 CVO_convert T_f32 (Some SX_U) => xa9 :: nil
  | BI_cvtop T_i32 CVO_convert T_f32 None => dummy
  | BI_cvtop T_i32 CVO_convert T_f64 (Some SX_S) => xaa :: nil
  | BI_cvtop T_i32 CVO_convert T_f64 (Some SX_U) => xab :: nil
  | BI_cvtop T_i32 CVO_convert T_f64 None => dummy
  | BI_cvtop T_i32 CVO_convert T_i32 _ => dummy
  | BI_cvtop T_i64 CVO_convert T_i32 (Some SX_S) => xac :: nil
  | BI_cvtop T_i64 CVO_convert T_i32 (Some SX_U) => xad :: nil
  | BI_cvtop T_i64 CVO_convert T_i32 None => dummy
  | BI_cvtop T_i64 CVO_convert T_f32 (Some SX_S) => xae :: nil
  | BI_cvtop T_i64 CVO_convert T_f32 (Some SX_U) => xaf :: nil
  | BI_cvtop T_i64 CVO_convert T_f32 None => dummy
  | BI_cvtop T_i64 CVO_convert T_f64 (Some SX_S) => xb0 :: nil
  | BI_cvtop T_i64 CVO_convert T_f64 (Some SX_U) => xb1 :: nil
  | BI_cvtop T_i64 CVO_convert T_f64 _ => dummy
  | BI_cvtop T_i64 CVO_convert T_i64 _ => dummy
  | BI_cvtop T_f32 CVO_convert T_i32 (Some SX_S) => xb2 :: nil
  | BI_cvtop T_f32 CVO_convert T_i32 (Some SX_U) => xb3 :: nil
  | BI_cvtop T_f32 CVO_convert T_i32 None => dummy
  | BI_cvtop T_f32 CVO_convert T_i64 (Some SX_S) => xb4 :: nil
  | BI_cvtop T_f32 CVO_convert T_i64 (Some SX_U) => xb5 :: nil
  | BI_cvtop T_f32 CVO_convert T_i64 None => dummy
  | BI_cvtop T_f32 CVO_convert T_f64 None => xb6 :: nil
  | BI_cvtop T_f32 CVO_convert T_f64 (Some _) => dummy
  | BI_cvtop T_f32 CVO_convert T_f32 _ => dummy
  | BI_cvtop T_f64 CVO_convert T_i32 (Some SX_S) => xb7 :: nil
  | BI_cvtop T_f64 CVO_convert T_i32 (Some SX_U) => xb8 :: nil
  | BI_cvtop T_f64 CVO_convert T_i32 None => dummy
  | BI_cvtop T_f64 CVO_convert T_i64 (Some SX_S) => xb9 :: nil
  | BI_cvtop T_f64 CVO_convert T_i64 (Some SX_U) => xba :: nil
  | BI_cvtop T_f64 CVO_convert T_i64 None => dummy
  | BI_cvtop T_f64 CVO_convert T_f32 None => xbb :: nil
  | BI_cvtop T_f64 CVO_convert T_f32 (Some _) => dummy
  | BI_cvtop T_f64 CVO_convert T_f64 _ => dummy
  | BI_cvtop T_i32 CVO_reinterpret T_f32 None => xbc :: nil
  | BI_cvtop T_i64 CVO_reinterpret T_f64 None => xbc :: nil
  | BI_cvtop T_f32 CVO_reinterpret T_i32 None => xbc :: nil
  | BI_cvtop T_f64 CVO_reinterpret T_i64 None => xbc :: nil
  | BI_cvtop T_i32 CVO_reinterpret T_i32 _ => dummy
  | BI_cvtop T_i32 CVO_reinterpret T_i64 _ => dummy
  | BI_cvtop T_i32 CVO_reinterpret T_f64 _ => dummy
  | BI_cvtop T_i64 CVO_reinterpret T_i32 _ => dummy
  | BI_cvtop T_i64 CVO_reinterpret T_i64 _ => dummy
  | BI_cvtop T_i64 CVO_reinterpret T_f32 _ => dummy
  | BI_cvtop T_f32 CVO_reinterpret T_i64 _ => dummy
  | BI_cvtop T_f32 CVO_reinterpret T_f32 _ => dummy
  | BI_cvtop T_f32 CVO_reinterpret T_f64 _ => dummy
  | BI_cvtop T_f64 CVO_reinterpret T_i32 _ => dummy
  | BI_cvtop T_f64 CVO_reinterpret T_f32 _ => dummy
  | BI_cvtop T_f64 CVO_reinterpret T_f64 _ => dummy
  | BI_cvtop _ CVO_reinterpret _ (Some _) => dummy
  end.

(** Expressions are encoded by their instruction sequence terminated with an
explicit `0x0B` opcode for `end`. *)
Definition binary_of_expr (bes : list basic_instruction) : list byte  :=
  List.concat (List.map binary_of_be bes) ++ x0b :: nil.

Definition magic : list byte :=
  x00 :: x61 :: x73 :: x6d:: nil.

Definition version : list byte :=
  x01 :: x00 :: x00 :: x00 :: nil.

Definition with_length (bs : list byte) : list byte :=
  leb128.encode_unsigned (bin_of_nat (List.length bs)) ++ bs.

Definition binary_of_result_type rt : list byte :=
  binary_of_vec(fun v => binary_of_value_type v :: nil) rt.

Definition binary_of_functype (ft : function_type) : list byte :=
  let 'Tf rt1 rt2 := ft in
  x60 :: binary_of_result_type rt1 ++ binary_of_result_type rt2.

Definition binary_of_typesec (ts : list function_type) : list byte :=
  x01 :: with_length (binary_of_vec binary_of_functype ts).

Definition binary_of_typeidx (t : typeidx) : list byte :=
  let 'Mk_typeidx i := t in
  leb128.encode_unsigned (bin_of_nat i).

Definition binary_of_funcidx (t : funcidx) : list byte :=
  let 'Mk_funcidx i := t in
  leb128.encode_unsigned (bin_of_nat i).

Definition binary_of_tableidx (t : tableidx) : list byte :=
  let 'Mk_tableidx i := t in
  leb128.encode_unsigned (bin_of_nat i).

Definition binary_of_memidx (t : memidx) : list byte :=
  let 'Mk_memidx i := t in
  leb128.encode_unsigned (bin_of_nat i).

Definition binary_of_globalidx (t : globalidx) : list byte :=
  let 'Mk_globalidx i := t in
  leb128.encode_unsigned (bin_of_nat i).

Definition binary_of_name (n : name) : list byte :=
  binary_of_vec (fun n => cons n nil) n.

Definition binary_of_elem_type (et : elem_type) : list byte :=
  match et with
  | ET_funcref => cons x70 nil
  end.

Definition binary_of_limits (l : limits) : list byte :=
  match l.(lim_max) with
  | None => x00 :: leb128.encode_unsigned (bin_of_nat l.(lim_min))
  | Some max =>
    x01 ::
    leb128.encode_unsigned (bin_of_nat l.(lim_min)) ++
    leb128.encode_unsigned (bin_of_nat max)
  end.

Definition binary_of_table_type (t_ty : table_type) : list byte :=
  binary_of_elem_type t_ty.(tt_elem_type) ++
  binary_of_limits t_ty.(tt_limits).

Definition binary_of_mutability (m : mutability) : list byte :=
  match m with
  | MUT_immut => cons x00 nil
  | MUT_mut => cons x01 nil
  end.

Definition binary_of_global_type (g_ty : global_type) : list byte :=
  cons (binary_of_value_type g_ty.(tg_t)) nil ++
  binary_of_mutability g_ty.(tg_mut).

Definition binary_of_memory_type (m : memory_type) : list byte :=
  binary_of_limits m.

Definition binary_of_import_desc (imp_desc : import_desc) : list byte :=
  match imp_desc with
  | ID_func tidx => x00 :: binary_of_typeidx (Mk_typeidx tidx)
  | ID_table t_ty => x01 :: binary_of_table_type t_ty
  | ID_mem m_ty => x02 :: binary_of_memory_type m_ty
  | ID_global g_ty => x03 :: binary_of_global_type g_ty
  end.

Definition binary_of_module_import (imp : module_import) : list byte :=
  binary_of_name imp.(imp_module) ++
  binary_of_name imp.(imp_name) ++
  binary_of_import_desc imp.(imp_desc).

Definition binary_of_importsec (imps : list module_import) : list byte :=
  x02 :: with_length (binary_of_vec binary_of_module_import imps).

Definition binary_of_funcsec (fs : list module_func) : list byte :=
  x03 :: with_length (binary_of_vec binary_of_typeidx (List.map (fun f => f.(modfunc_type)) fs)).

Definition binary_of_module_table (t : module_table) : list byte :=
  binary_of_table_type t.(modtab_type).

Definition binary_of_tablesec (ts : list module_table) : list byte :=
  x04 :: with_length (binary_of_vec binary_of_module_table ts).

Definition binary_of_memsec (ms : list memory_type) : list byte :=
  x05 :: with_length (binary_of_vec binary_of_memory_type ms).

Definition binary_of_module_glob (g : module_glob) : list byte :=
  binary_of_global_type g.(modglob_type) ++
  binary_of_expr g.(modglob_init).

Definition binary_of_globalsec (gs : list module_glob) : list byte :=
  x06 :: with_length (binary_of_vec binary_of_module_glob gs).

Definition binary_of_export_desc (ed : module_export_desc) : list byte :=
  match ed with
  | MED_func n => x00 :: binary_of_funcidx n
  | MED_table n => x01 :: binary_of_tableidx n
  | MED_mem n => x02 :: binary_of_memidx n
  | MED_global n => x03 :: binary_of_globalidx n
  end.

Definition binary_of_module_export (e : module_export) : list byte :=
  binary_of_name e.(modexp_name) ++
  binary_of_export_desc e.(modexp_desc).

Definition binary_of_exportssec (es : list module_export) : list byte :=
  x07 :: with_length (binary_of_vec binary_of_module_export es).

Definition binary_of_module_start (s : module_start) : list byte :=
  binary_of_funcidx s.(modstart_func).

Definition binary_of_startsec (s : module_start) : list byte :=
  x08 :: with_length (binary_of_module_start s).

Definition binary_of_module_elem (e : module_element) : list byte :=
  binary_of_tableidx e.(modelem_table) ++
  binary_of_expr e.(modelem_offset) ++
  binary_of_vec binary_of_funcidx e.(modelem_init).

Definition binary_of_elemsec (es : list module_element) : list byte :=
  x09 :: with_length (binary_of_vec binary_of_module_elem es).

Definition binary_of_local (n_t : nat * value_type) : list byte :=
  let '(n, t) := n_t in
  leb128.encode_unsigned (bin_of_nat n) ++
  cons (binary_of_value_type t) nil.

Fixpoint bunch_locals_aux (cur_ty : value_type) (cur_count : nat) (acc : list (nat * value_type)) (tys : list value_type) : list (nat * value_type) :=
  match tys with
  | nil => List.rev ((cur_count, cur_ty) :: acc)
  | cons ty tys' =>
    if cur_ty == ty then bunch_locals_aux cur_ty (cur_count + 1) acc tys'
    else bunch_locals_aux ty 1 ((cur_count, cur_ty) :: acc) tys'
  end.

Definition bunch_locals (tys : list value_type) : list (nat * value_type) :=
  match tys with
  | nil => nil
  | cons ty tys' => bunch_locals_aux ty 1 nil tys'
  end.

Definition binary_of_code_func (cf : code_func) : list byte :=
  binary_of_vec binary_of_local (bunch_locals cf.(fc_locals)) ++
  binary_of_expr cf.(fc_expr).

Definition binary_of_code (mf : module_func) : list byte :=
  let func := {| fc_locals := mf.(modfunc_locals); fc_expr := mf.(modfunc_body) |} in
  let func_bin := binary_of_code_func func in
  let func_len := List.length func_bin in
  leb128.encode_unsigned (bin_of_nat func_len) ++
  func_bin.

Definition binary_of_codesec (fs : list module_func) : list byte :=
  x0a :: with_length (binary_of_vec binary_of_code fs).

Definition binary_of_data (d : module_data) : list byte :=
  binary_of_memidx d.(moddata_data) ++
  binary_of_expr d.(moddata_offset) ++
  binary_of_vec (fun x => cons x nil) d.(moddata_init).

Definition binary_of_datasec (ds : list module_data) : list byte :=
  x0b :: with_length (binary_of_vec binary_of_data ds).

Definition only_if_non_nil {A} (f : list A -> list byte) (xs : list A) : list byte :=
  match xs with
  | nil => nil
  | _ :: _ => f xs
  end.

Definition only_if_non_none {A} (f : A -> list byte) (xo : option A) : list byte :=
  match xo with
  | None => nil
  | Some x => f x
  end.

Definition binary_of_module (m : module) : list byte :=
  magic ++ version ++
  only_if_non_nil binary_of_typesec m.(mod_types) ++
  only_if_non_nil binary_of_importsec m.(mod_imports) ++
  only_if_non_nil binary_of_funcsec m.(mod_funcs) ++
  only_if_non_nil binary_of_tablesec m.(mod_tables) ++
  only_if_non_nil binary_of_memsec m.(mod_mems) ++
  only_if_non_nil binary_of_globalsec m.(mod_globals) ++
  only_if_non_nil binary_of_exportssec m.(mod_exports) ++
  only_if_non_none binary_of_startsec m.(mod_start) ++
  only_if_non_nil binary_of_elemsec m.(mod_elem) ++
  only_if_non_nil binary_of_codesec m.(mod_funcs) ++
  only_if_non_nil binary_of_datasec m.(mod_data).


Require Import Coq.PArith.BinPos.
Require Import Coq.Lists.List. Import ListNotations.

Set Universe Polymorphism.

Inductive option{A : Type}: Type :=
| Some(a: A)
| None.

Arguments option: clear implicits.

Section NATMAP.
  Context {V: Type}.

  (* TODO if there are trailing None's map extensionality doesn't hold, can we fix that? *)
  Definition natmap := list (option V).

  Definition head(m: natmap): option V :=
    match m with
    | nil => None
    | o :: _ => o
    end.

  Fixpoint skip(n: nat)(m: natmap): natmap :=
    match n with
    | O => m
    | S n' => tail (skip n' m)
    end.

  Definition get(m: natmap)(n: nat): option V := head (skip n m).

  (* m2 overrides m1. Simplifies best if m2 is concrete *)
  Fixpoint merge(m1 m2: natmap): natmap :=
    match m2 with
    | nil => m1
    | cons h t => cons (match h with
                        | Some v => Some v
                        | None => head m1
                        end)
                       (merge (tail m1) t)
    end.

  Fixpoint singleton(k: nat)(v: V): natmap :=
    match k with
    | O => Some v :: nil
    | S n => None :: singleton n v
    end.

  Definition put(m: natmap)(k: nat)(v: V): natmap := merge m (singleton k v).

  Definition putmany: natmap -> list (nat * V) -> natmap :=
    List.fold_right (fun '(k, v) res => put res k v).

End NATMAP.

Arguments natmap: clear implicits.

Section NATMAP_TESTS.
  Context (unknown: natmap nat).

  Goal get (Some 10 :: Some 11 :: None :: Some 13 :: unknown) 3 =
  Some 13.
  Proof. reflexivity. Qed.

  Goal merge (Some 10 :: Some 11 :: None :: Some 13 :: unknown)
       (Some 100 :: None :: Some 120 :: nil) =
  (Some 100 :: Some 11 :: Some 120 :: Some 13 :: unknown).
  Proof. reflexivity. Qed.

  Goal merge (Some 10 :: Some 11 :: unknown)
       (Some 100 :: None :: Some 120 :: None :: Some 140 :: nil) =
  (Some 100 :: Some 11 :: Some 120 :: get unknown 1 :: Some 140 :: skip 3 unknown).
  Proof. reflexivity. Qed.

  Goal put (put unknown 2 20) 5 50 = put (put unknown 5 50) 2 20.
  Proof. reflexivity. Qed.

  Goal putmany unknown [(3, 33); (1, 11); (4, 44)] = putmany unknown [(1, 11); (3, 33); (4, 44)].
  Proof. reflexivity. Qed.

End NATMAP_TESTS.

Definition forcetype(o: option Type): Type :=
  match o with
  | Some T => T
  | None => unit
  end.

Inductive hnatmap: natmap Type -> Type :=
| HNil: hnatmap nil
| HCons{OV: option Type}{T: natmap Type}(v: forcetype OV)(t: hnatmap T): hnatmap (cons OV T).

Definition hhead{T: natmap Type}(m: hnatmap T): forcetype (head T) :=
  match m with
  | HNil => tt
  | HCons v _ => v
  end.

Definition htail{T: natmap Type}(m: hnatmap T): hnatmap (tail T) :=
  match m with
  | HNil => HNil
  | HCons _ t => t
  end.

Fixpoint hskip(n: nat){T: natmap Type}(m: hnatmap T): hnatmap (skip n T) :=
  match n with
  | 0 => m
  | S n' => htail (hskip n' m)
  end.

Definition hget{T: natmap Type}(m: hnatmap T)(n: nat): forcetype (get T n) := hhead (hskip n m).

(* m2 overrides m1 *)
Fixpoint hmerge{T1 T2: natmap Type}(m1: hnatmap T1)(m2: hnatmap T2): hnatmap (merge T1 T2).
  refine (match m2 with
          | HNil => m1
          | @HCons OV T2Tail v t => @HCons (match OV with
                                            | Some V => Some V
                                            | None => head T1
                                            end)
                                           (merge (tail T1) T2Tail)
                                           _
                                           (hmerge _ _ (htail m1) t)
          end).
  destruct OV as [V|].
  - exact v.
  - exact (hhead m1).
Defined.

Fixpoint hsingleton{V: Type}(k: nat)(v: V){struct k}: hnatmap (singleton k V) :=
  match k with
  | 0 => @HCons (Some V) [] v HNil
  | S n => @HCons None (singleton n V) tt (hsingleton n v)
  end.

Definition hset(k: nat){V: Type}(v: V){T: natmap Type}(m: hnatmap T): hnatmap (put T k V) :=
  hmerge m (hsingleton k v).

Section HNATMAP_TESTS.
  Context (UnknownFields: natmap Type).
  Context (unknown: hnatmap UnknownFields).

  Goal hget (hset 2 true (hset 4 44 (hset 3 false (hset 4 (@nil nat) unknown)))) 4 = 44.
  Proof. reflexivity. Qed.

  Goal (hset 2 true (hset 4 44 unknown)) = (hset 4 44 (hset 2 true unknown)).
  Proof. reflexivity. Qed.

  Goal (hset 2 true (hset 4 44 (hset 3 false (hset 4 (@nil nat) unknown)))) =
       (hset 4 44 (hset 3 false (hset 2 true unknown))).
  Proof. reflexivity. Qed.
End HNATMAP_TESTS.

Definition commonVal := 4.

Module File1. Section __.
  Definition flag1 := 3.
  Context (UnknownFields: natmap Type).
  Definition Fields: natmap Type := putmany UnknownFields [(flag1, bool: Type); (commonVal, nat: Type)].
  Definition State: Type := hnatmap Fields.

  Definition op(s: State): State := hset commonVal (hget s commonVal + 2) (hset flag1 false s).
End __. End File1.

Module File2. Section __.
  Definition flag2 := 0.
  Context (UnknownFields: natmap Type).
  Definition Fields: natmap Type := putmany UnknownFields [(flag2, bool: Type); (commonVal, nat: Type)].
  Definition State: Type := hnatmap Fields.

  Definition op(s: State): State := hset flag2 true (hset commonVal (hget s commonVal + 3) (hset flag2 false s)).
End __. End File2.

Module File3. Section __.
  Context (UnknownFields: natmap Type).
  Definition Fields: natmap Type :=
    putmany UnknownFields [
              (File1.flag1, bool: Type);
              (File2.flag2, bool: Type);
              (commonVal, nat: Type)
            ].
  Definition State: Type := hnatmap Fields.

  Goal File1.State (putmany UnknownFields [(File2.flag2, bool: Type)]) = State.
  Proof. reflexivity. Qed.

  Definition op1: State -> State :=
    File1.op (putmany UnknownFields [(File2.flag2, bool: Type)]).

  Definition op2: State -> State :=
    File2.op (putmany UnknownFields [(File1.flag1, bool: Type)]).

  Goal forall s: State,
      hget (op1 (op2 s)) commonVal = hget s commonVal + 5.
  Proof.
    intros.
    unfold op1, op2, File1.op, File2.op, hget, hset.
    simpl.
    rewrite <- PeanoNat.Nat.add_assoc.
    reflexivity.
  Qed.
End __. End File3.


(*
Copyright © 2006 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.totalorder.QMinMax.
Require Import CoRN.reals.fast.CRAlternatingSum.
Require Import CoRN.reals.fast.CRAlternatingSum_alg.
Require Import CoRN.reals.fast.CRstreams.
Require Import CoRN.reals.fast.CRexp.
Require Import CoRN.reals.fast.CRpi.
Require Export CoRN.reals.fast.CRArith.
Require Import CoRN.reals.fast.CRIR.
Require Import Coq.QArith.Qpower Coq.QArith.Qabs.
Require Import CoRN.model.ordfields.Qordfield.
Require Import Coq.QArith.Qround.
Require Import CoRN.transc.Pi.
Require Import CoRN.reals.fast.ModulusDerivative.
Require Import CoRN.reals.fast.ContinuousCorrect.
Require Import CoRN.model.metric2.Qmetric.
Require Import CoRN.transc.PowerSeries.
Require Import CoRN.transc.SinCos.
Require Import Coq.NArith.Ndigits.
Require Import CoRN.reals.fast.Compress.
Require Import CoRN.reals.fast.PowerBound.
Require Import CoRN.tactics.CornTac.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import CoRN.util.Qdlog.
From Coq Require Import Lia.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

Set Implicit Arguments.

Local Open Scope Q_scope.
Local Open Scope uc_scope.

Opaque inj_Q CR Qmin Qmax.

Lemma Qmult_pos_neg : forall (a b : Q),
    0 <= a -> b <= 0 -> a*b <= 0.
Proof.
  intros. rewrite Qmult_comm.
  rewrite <- (Qmult_0_l a).
  apply Qmult_le_compat_r; assumption.
Qed.

Lemma Qmult_opp_1 : forall q : Q,
    eq (-q) (-1 * q).
Proof.
  reflexivity.
Qed.

Lemma fact_inc : forall n:nat, (fact n <= fact (S n))%nat.
Proof.
  intro n.
  rewrite <- (Nat.mul_1_l (fact n)).
  change (fact (S n)) with ((1+n)*fact n)%nat.
  apply Nat.mul_le_mono_nonneg_r.
  apply (Nat.le_trans _ 1).
  auto. exact (lt_O_fact n).
  apply le_n_S, le_0_n.
Qed.

Lemma fact_inc_recurse : forall p n:nat, (n <= p)%nat -> (fact n <= fact p)%nat.
Proof.
  induction p.
  - intros. inversion H. apply le_refl.
  - intros. apply Nat.le_succ_r in H. destruct H.
    apply (Nat.le_trans (fact n) (fact p)).
    apply IHp, H. apply fact_inc.
    subst n. apply le_refl.
Qed.

(**
** Sine
Sine is defined in terms of its alternating Taylor's series.
*)
Section SinSeries.
Variable a:Q.

(* (1,a) -> (3, -a^3/3!) -> ... *)
Definition sinStream (px : positive*Q) : positive*Q
  := let d := Pos.succ (fst px) in
     (Pos.add 2 (fst px), - snd px * a * a * (1#(d*Pos.succ d))).

Lemma sinStream_fst : forall p,
    fst (iterate _ sinStream p (1%positive, a)) ≡ Pos.succ (2*p).
Proof.
  apply Pos.peano_ind.
  - reflexivity.
  - intros p H. rewrite iterate_succ.
    destruct (iterate (positive and Q) sinStream p (1%positive, a)).
    simpl in H. subst p0.
    transitivity (Pos.add 2 (p~1)). reflexivity.
    clear q a. rewrite Pos.mul_succ_r.
    rewrite <- Pos.add_1_l, (Pos.add_comm 1).
    rewrite <- Pos.add_assoc. apply f_equal. reflexivity.
Qed.

(* The closed formula for the sine stream. *)
Lemma Str_pth_sinStream : forall (p:positive),
    Str_pth _ sinStream p (xH,a)
    == (1#Pos.of_nat (fact (1+2*Pos.to_nat p))) * ((-1)^p*a^(1+2*p))%Q.
Proof.
  apply Pos.peano_ind.
  - unfold sinStream, Str_pth; simpl.
    rewrite Qmult_comm. apply Qmult_comp. reflexivity.
    rewrite Qmult_assoc, Qmult_assoc.
    reflexivity.
  - intros p pInd. unfold Str_pth.
    rewrite iterate_succ. unfold Str_pth in pInd.
    pose proof (sinStream_fst p) as H0.
    destruct (iterate (positive and Q) sinStream p (1%positive, a)) as [p0 q].
    simpl in H0. subst p0. unfold snd in pInd.
    unfold sinStream, snd, fst.
    rewrite pInd. clear pInd q.
    (* Get rid of (-1)^p *)
    rewrite <- (Qmult_comm ((-1) ^ Pos.succ p * a ^ (1 + 2 * Pos.succ p))).
    rewrite <- (Pos.add_1_l p).
    rewrite Pos2Z.inj_add, (Qpower_plus (-1)%Q).
    simpl ((-1)^1).
    rewrite Qmult_opp_1.
    do 5 rewrite <- (Qmult_assoc (-1)).
    apply (Qmult_comp (-1)). reflexivity.
    rewrite (Qmult_comm (1 # Pos.of_nat (fact (1 + 2 * Pos.to_nat p)))).
    do 5 rewrite <- (Qmult_assoc ((-1)^p)).
    apply Qmult_comp. reflexivity.
    (* Get rid of a *)
    setoid_replace (a ^ (1 + 2 * (1 + p))) with (a ^ (1 + 2 * p) * (a * a)).
    do 4 rewrite <- (Qmult_assoc (a ^ (1 + 2 * p))).
    apply Qmult_comp. reflexivity.
    rewrite <- (Qmult_assoc _ a a).
    rewrite (Qmult_comm (1 # Pos.of_nat (fact (1 + 2 * Pos.to_nat p)))).
    rewrite <- (Qmult_assoc (a*a)).
    apply Qmult_comp. reflexivity.
    (* Get rid of fact *)
    unfold Qeq, Qmult, Qnum, Qden.
    rewrite Z.mul_1_l, Z.mul_1_l.
    rewrite <- (Pos2Nat.id (Pos.succ p~1 * Pos.succ (Pos.succ p~1))).
    rewrite <- Nat2Pos.inj_mul.
    2: apply fact_neq_0.
    replace (fact (1 + 2 * Pos.to_nat (1 + p)))%nat
      with (fact (1 + 2 * Pos.to_nat p) *
            Pos.to_nat (Pos.succ p~1 * Pos.succ (Pos.succ p~1)))%nat.
    reflexivity.
    rewrite Nat.mul_comm.
    replace (1 + 2 * Pos.to_nat (1 + p))%nat with (3 + 2 * Pos.to_nat p)%nat.
    change (fact (3 + 2 * Pos.to_nat p))%nat
      with ((3 + 2 * Pos.to_nat p)
            * ((2 + 2 * Pos.to_nat p) * fact (1 + 2 * Pos.to_nat p)))%nat.
    replace (Pos.to_nat (Pos.succ p~1 * Pos.succ (Pos.succ p~1)))%nat
      with ((3 + 2 * Pos.to_nat p) * ((2 + 2 * Pos.to_nat p)))%nat.
    rewrite Nat.mul_assoc.
    reflexivity.
    (* Finish equalities *)
    rewrite Pos2Nat.inj_mul.
    rewrite Nat.mul_comm. apply f_equal2.
    rewrite Pos2Nat.inj_succ.
    apply (f_equal S).
    rewrite Pos2Nat.inj_xI. reflexivity.
    rewrite Pos2Nat.inj_succ. apply (f_equal S).
    rewrite Pos2Nat.inj_succ. apply (f_equal S).
    rewrite Pos2Nat.inj_xI. reflexivity.
    rewrite Pos2Nat.inj_add. simpl.
    rewrite Nat.add_0_r, Nat.add_succ_r. reflexivity.
    intro abs.
    pose proof (Pos2Nat.is_pos (Pos.succ p~1 * Pos.succ (Pos.succ p~1))).
    rewrite abs in H. inversion H.
    rewrite <- (Qpower_plus_positive a 1 1).
    rewrite <- (Qpower_plus_positive a (1+2*p)).
    apply Qpower_positive_comp. reflexivity.
    rewrite <- Pos.add_assoc.
    apply f_equal. rewrite (Pos.add_comm 1 p).
    reflexivity.
    intro abs. discriminate.
Qed.

(** Sine is first defined on [[-1,1]] by an alternating series. *)
Lemma sinStream_alt : -1 <= a <= 1 -> Str_alt_decr _ sinStream (1%positive,a).
Proof.
  intro Ha. split.
  - (* Replace a by Qabs a *)
    rewrite Str_pth_sinStream, Str_pth_sinStream.
    rewrite Qabs_Qmult, Qabs_Qmult, Qabs_Qmult, Qabs_Qmult.
    rewrite Qabs_Qpower, Qabs_Qpower.
    change (Qabs (-1)) with 1.
    rewrite Qpower_1, Qpower_1, Qmult_1_l, Qmult_1_l.
    rewrite (Qabs_Qpower a (1+2*Pos.succ p)), (Qabs_Qpower a (1+2*p)).
    (* Finish inequality *)
    setoid_replace (Qabs a ^ (1 + 2 * Pos.succ p)%positive)
      with (Qabs a * Qabs a * Qabs a ^ (1 + 2 * p)%positive).
    rewrite Qmult_assoc.
    apply Qmult_le_compat_r.
    2: rewrite <- Qabs_Qpower; apply Qabs_nonneg.
    + rewrite Qmult_comm.
      apply (Qabs_Qle_condition a 1) in Ha.
      apply (Qle_trans _ (1* (1 # Pos.of_nat (fact (1 + 2 * Pos.to_nat (Pos.succ p)))))).
      apply Qmult_le_compat_r. 2: discriminate.
      apply (Qle_trans _ (1*Qabs a)).
      apply Qmult_le_compat_r. exact Ha.
      apply Qabs_nonneg. rewrite Qmult_1_l. exact Ha.
      rewrite Qmult_1_l. unfold Qabs, Z.abs.
      unfold Qle, Qnum, Qden.
      rewrite Z.mul_1_l, Z.mul_1_l.
      apply Pos2Nat.inj_le.
      rewrite Nat2Pos.id, Nat2Pos.id.
      2: apply fact_neq_0. 2: apply fact_neq_0.
      replace (1 + 2 * Pos.to_nat (Pos.succ p))%nat
        with (2 + (1 + 2 * Pos.to_nat p))%nat
        by (rewrite Pos2Nat.inj_succ; ring).
      apply (Nat.le_trans _ _ _ (fact_inc _)).
      apply fact_inc.
    + replace (1 + 2 * Pos.succ p)%positive with (2 + (1 + 2 * p))%positive.
      generalize (1 + 2 * p)%positive. clear p. intro p.
      unfold Qpower.
      rewrite Qpower_plus_positive. reflexivity.
      rewrite Pos.add_comm, <- Pos.add_assoc. apply f_equal.
      rewrite <- Pos.add_1_l.
      rewrite Pos.mul_add_distr_l, Pos.mul_1_r.
      apply Pos.add_comm.
  - rewrite Str_pth_sinStream, Str_pth_sinStream.
    rewrite Qmult_comm, <- Qmult_assoc. apply Qmult_pos_neg.
    discriminate. rewrite Qmult_comm, <- Qmult_assoc.
    apply Qmult_pos_neg. discriminate.
    rewrite <- Pos.add_1_l.
    change ((-1) ^ (1 + p)%positive) with (Qpower_positive (-1) (1 + p)).
    rewrite Qpower_plus_positive. simpl (Qpower_positive (-1) 1).
    rewrite <- Qmult_assoc, <- Qmult_assoc.
    apply (Qopp_le_compat 0).
    rewrite (Qmult_comm (a ^ (1 + 2 * (1 + p)%positive))).
    rewrite Qmult_assoc, Qmult_assoc.
    rewrite <- Qmult_assoc.
    apply Qmult_le_0_compat.
    simpl.
    destruct (Qpower_positive (-1) p), Qnum; discriminate.
    setoid_replace (a ^ (1 + 2 * (1 + p))) with (a ^ (1 + 2 * p) * (a * a)).
    rewrite Qmult_assoc.
    apply Qmult_le_0_compat.
    destruct (a ^ (1 + 2 * p)), Qnum; discriminate.
    destruct a, Qnum; discriminate.
    change (a*a) with (Qpower_positive a 2).
    rewrite <- (Qpower_plus_positive a (1+2*p)).
    change (a ^ (1 + 2 * (1 + p))) with (Qpower_positive a (1 + 2 * (1 + p))).
    replace (1 + 2 * (1 + p))%positive with (1 + 2 * p + 2)%positive.
    reflexivity.
    rewrite <- Pos.add_assoc. apply f_equal.
    rewrite Pos.mul_add_distr_l, Pos.mul_1_r.
    apply Pos.add_comm.
Qed.

Lemma sinStream_zl
  : -1 <= a <= 1
    -> Limit_zero _ sinStream (xH,a)
                 (fun e:Qpos => Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ (proj1_sig e)))))).
Proof.
  intro Ha.
  intros [e epos]. rewrite Str_pth_sinStream, Qabs_Qmult, Qabs_Qmult.
  rewrite Qabs_Qpower. change (Qabs (-1)) with 1.
  rewrite Qpower_1, Qmult_1_l.
  rewrite Qmult_comm.
  apply (Qle_trans
           _ (1 * Qabs (1 # Pos.of_nat (fact (1+2*(Pos.to_nat (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e))))))))))).
  apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
  - rewrite (Qabs_Qpower
               a (1 + 2 * Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ ` (e ↾ epos))))))).
    apply Qpower_le_1. split.
    apply Qabs_nonneg.
    apply Qabs_Qle_condition, Ha.
  - clear Ha a.
    rewrite Qmult_1_l. unfold Qabs, Z.abs, proj1_sig.
    rewrite <- (Qinv_involutive e) at 2.
    assert (0 < /e) as H.
    { apply Qinv_lt_0_compat, epos. }
    apply (@Qinv_le_compat
             (/e) ((Pos.of_nat (fact (1+2*(Pos.to_nat (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e))))))))) # 1)).
    exact H.
    apply (Qle_trans _ _ _ (Qceiling_fact_le H)).
    generalize (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e))))).
    clear H epos e. intro p.
    unfold Qle, Qnum, Qden.
    rewrite Z.mul_1_r, Z.mul_1_r.
    apply Pos2Nat.inj_le.
    rewrite Nat2Pos.id, Nat2Pos.id.
    2: apply fact_neq_0. 2: apply fact_neq_0.
    apply fact_inc_recurse.
    apply (Nat.le_trans (Pos.to_nat p) (1 + Pos.to_nat p)).
    apply le_S, le_refl.
    apply le_n_S.
    rewrite <- (Nat.mul_1_l (Pos.to_nat p)) at 1.
    apply Nat.mul_le_mono_nonneg_r.
    apply le_0_n. apply le_S, le_refl.
Qed.

End SinSeries.

Definition rational_sin_small (a:Q) (p: -1 <= a <= 1) : CR :=
  (inject_Q_CR a + AltSeries _ (sinStream a) (xH,a) _
                             (sinStream_alt p) (sinStream_zl p))%CR.

Lemma rational_sin_small_correct : forall (a:Q) (Ha : -1 <= a <= 1),
    (@rational_sin_small a Ha == IRasCR (Sin (inj_Q IR a)))%CR.
Proof.
  intros a Ha.
  unfold rational_sin_small.
  simpl.
  generalize (fun_series_conv_imp_conv (inj_Q IR a) (inj_Q IR a)
   (leEq_reflexive IR (inj_Q IR a)) sin_ps
     (sin_conv (inj_Q IR a) (inj_Q IR a) (leEq_reflexive IR (inj_Q IR a))
       (compact_single_iprop realline (inj_Q IR a) I)) (inj_Q IR a)
         (compact_single_prop (inj_Q IR a))
           (fun_series_inc_IR realline sin_ps sin_conv (inj_Q IR a) I)).
  intros H.
  (* Replace AltSeries by IRasCR (series_sum ...) *)
  rewrite <- (IR_inj_Q_as_CR a).
  rewrite
       (AltSeries_correct
          _ _ _ _ (sinStream_alt Ha) (sinStream_zl Ha)
          _ (AltSeries_convergent_0 _ _ _ _ (inj_Q IR a)
                                    (sinStream_alt Ha) (sinStream_zl Ha))).
  apply IRasCR_wd.
 - (* Prove the 2 series are equal in IR.
    We need to sum twice as many terms in sin_seq, to get rid of
    the zeros at even indexes. *)
   unfold series_sum.
   apply Lim_seq_eq_Lim_subseq with (fun n => 2*n)%nat.
   intros; lia.
  intros n; exists (S n); lia.
  (* Prove that the partial sums until n are equal. *)
 intros n.
 induction n.
  apply eq_reflexive.
 replace (2*(S n))%nat with (S (S (2*n)))%nat by lia.
 set (n':=(2*n)%nat) in *.
 simpl in *.
 rstepr (seq_part_sum (fun n0 : nat =>
   (sin_seq n0[/]nring (R:=IR) (fact n0)[//]nring_fac_ap_zero IR n0)[*]
     nexp IR n0 (inj_Q IR a[-][0])) n'[+](
       (sin_seq n'[/]nring (R:=IR) (fact n')[//]nring_fac_ap_zero IR n')[*]
         nexp IR n' (inj_Q IR a[-][0])[+] (sin_seq (S n')[/]nring (R:=IR) (fact n' + n' * fact n')[//]
           nring_fac_ap_zero IR (S n'))[*] (nexp IR n' (inj_Q IR a[-][0])[*](inj_Q IR a[-][0])))).
 apply bin_op_wd_unfolded.
 assumption.
 rewrite <- cm_lft_unit.
 unfold sin_seq.
 apply bin_op_wd_unfolded.
   + destruct (even_or_odd_plus n') as [m [Hm|Hm]]; simpl.
     rational.
     elim (not_even_and_odd n').
     apply (even_mult_l 2 n).
     repeat constructor.
     rewrite Hm.
     constructor.
     replace (m + m)%nat with (2*m)%nat by lia.
     apply (even_mult_l 2 m).
     repeat constructor.
   + destruct (even_or_odd_plus (S n')) as [m [Hm|Hm]]; simpl.
  elim (not_even_and_odd (S n')).
   rewrite Hm.
   replace (m + m)%nat with (2*m)%nat by lia.
   apply (even_mult_l 2 m).
   repeat constructor.
  constructor.
  apply (even_mult_l 2 n).
  repeat constructor.
 inversion Hm.
 unfold n' in H1.
 replace m with n by lia.
 clear Hm H1.
 (* Unfold sinStream *)
 transitivity (inj_Q IR ((1#Pos.of_nat (fact (1+2*n))) * ((-1)^n*a^(1+2*n))%Q)).
 clear IHn H. destruct n. simpl.
 apply inj_Q_wd. rewrite Qmult_1_l, Qmult_1_l. reflexivity.
 apply inj_Q_wd. rewrite Str_pth_sinStream.
 rewrite Nat2Pos.id. 2: discriminate.
 replace (Z.pos (Pos.of_nat (S n))) with (Z.of_nat (S n)).
 reflexivity.
 simpl. destruct n. reflexivity.
 rewrite <- Pos.succ_of_nat. reflexivity. discriminate.
 (* Get rid of (-1)^n *)
 transitivity (inj_Q IR ((-(1))^n) [*] (inj_Q IR (a ^ (1 + 2 * n)) [*] inj_Q IR (1 # Pos.of_nat (fact (1 + 2 * n))))).
 rewrite <- inj_Q_mult, <- inj_Q_mult.
 apply inj_Q_wd. rewrite Qmult_comm. rewrite Qmult_assoc. reflexivity.
 change (inj_Q IR ((- (1)) ^ n) [*] (inj_Q IR (a ^ (1 + 2 * n))
  [*] inj_Q IR (1 # Pos.of_nat (fact (1 + 2 * n))))
               [=]
   (nexp IR n [--][1][/]nring (R:=IR) (fact (S n'))[//]nring_fac_ap_zero IR (S n'))[*]
     (nexp IR (S n') (inj_Q IR a[-][0]))).
 rstepr ((nexp IR n [--][1][*](nexp IR (S n') (inj_Q IR a[-][0])[/]nring (R:=IR) (fact (S n'))[//]
   nring_fac_ap_zero IR (S n')))).
 apply mult_wd.
  stepr ((inj_Q IR (-(1)))[^]n).
   apply inj_Q_power.
  apply nexp_wd.
  stepr ([--](inj_Q IR 1)).
   apply inj_Q_inv.
  apply un_op_wd_unfolded.
  rstepr (nring 1:IR).
  apply (inj_Q_nring IR 1).
 stepr (inj_Q IR ((1/P_of_succ_nat (pred (fact (1+2*n))))*a^(1+2*n)%nat)).
 rewrite <- inj_Q_mult.
  apply inj_Q_wd.
  rewrite Qmult_comm.
  apply Qmult_comp.
  replace (1 + 2 * Z.of_nat n)%Z with (Z.of_nat (1 + 2 * n)).
  reflexivity. rewrite <- (Nat2Z.inj_mul 2), <- (Nat2Z.inj_add 1).
  reflexivity. pose proof (fact_neq_0 (1+2*n)).
  destruct (fact (1+2*n)). exfalso; apply H0; reflexivity.
  simpl. destruct n0. reflexivity.
  rewrite <- Pos2SuccNat.id_succ, Nat2Pos.id.
  reflexivity. discriminate.
  (* Finish equality *)
 rstepr ((nring 1[/]nring (R:=IR) (fact (S n'))[//]
   nring_fac_ap_zero IR (S n'))[*](nexp IR (S n') (inj_Q IR a[-][0]))).
 change (1+2*n)%nat with (S n').
 stepr ((inj_Q IR (1 / Zpos (P_of_succ_nat (pred (fact (S n')))))[*](inj_Q IR (a^S n')))).
  apply inj_Q_mult.
 apply mult_wd.
  rewrite <- POS_anti_convert.
  assert (X:inj_Q IR (inject_Z (Z_of_nat (S (pred (fact (S n'))))))[#][0]).
   stepr (inj_Q IR [0]).
    assert (@cs_ap Q_as_CSetoid (inject_Z (Z_of_nat (S (pred (fact (S n')))))) 0).
     discriminate.
    destruct (ap_imp_less _ _ _ X).
     apply less_imp_ap.
     apply inj_Q_less.
     assumption.
    apply Greater_imp_ap.
    apply inj_Q_less.
    assumption.
   apply (inj_Q_nring IR 0).
  stepr ((inj_Q IR 1)[/](inj_Q IR (inject_Z (Z_of_nat (S (pred (fact (S n')))))))[//]X).
   apply inj_Q_div.
  apply div_wd.
   apply (inj_Q_nring IR 1).
  stepl (inj_Q IR (nring (fact (S n')))).
   apply inj_Q_nring.
  assert (Y:=lt_O_fact (S n')).
  apply inj_Q_wd.
  stepr ((fact (S n')):Q).
   clear - n'.
   induction (fact (S n')).
    simpl; reflexivity.
   rewrite inj_S.
   unfold Z.succ.
   simpl in *.
   rewrite -> IHn0.
   rewrite -> injz_plus.
   reflexivity.
  destruct (fact (S n')).
   exfalso; auto with *.
  simpl; reflexivity.
 stepr ((inj_Q IR a)[^](S n')).
  apply inj_Q_power.
 change (inj_Q IR a[^]S n'[=](inj_Q IR a[-][0])[^]S n').
 apply nexp_wd.
 rational.
- intro p.
  pose proof (Pos2Nat.is_pos p). destruct (Pos.to_nat p) eqn:des.
  exfalso; inversion H0.
  rewrite <- des. rewrite Pos2Nat.id. reflexivity.
Qed.

(** Sine's range can then be extended to [[-3^n,3^n]] by [n] applications
of the identity [sin(x) = 3*sin(x/3) - 4*(sin(x/3))^3]. *)
Section Sin_Poly.

Definition sin_poly_fun (x:Q) :Q := x*(3 - 4*x*x).

Global Instance: Proper ((=) ==> (=)) sin_poly_fun.
Proof. unfold sin_poly_fun. solve_proper. Qed.

Lemma sin_poly_fun_correct : forall (q:Q),
 inj_Q IR (sin_poly_fun q)[=]Three[*]inj_Q IR q[-]Four[*](inj_Q IR q[^]3).
Proof.
 intros q.
 unfold sin_poly_fun.
 stepr (inj_Q IR (3*q-4*q^3)).
  apply inj_Q_wd.
  simpl; ring.
  rewrite inj_Q_minus.
 apply cg_minus_wd.
  stepr (inj_Q IR Three[*]inj_Q IR q).
   apply inj_Q_mult.
  apply mult_wdl.
  apply (inj_Q_nring IR 3).
 stepr (inj_Q IR Four[*]inj_Q IR (q^3)).
  apply inj_Q_mult.
 apply mult_wd.
  apply (inj_Q_nring IR 4).
 apply (inj_Q_power IR q 3).
Qed.

Definition sin_poly_modulus (e:Qpos) := Qpos2QposInf ((1#9)*e).

Lemma DthreeXMinusFourX3 : Derivative (clcr (inj_Q IR (-(1))) (inj_Q IR (1:Q)))
                   (inj_Q_less _ (-1) 1 eq_refl)
                   ((Three:IR){**}FId{-}(Four:IR){**}FId{^}3)
 ((Three:IR){**}[-C-]([1]:IR){-}(Four:IR){**}((nring 3){**}([-C-][1]{*}FId{^}2))).
Proof.
 apply Derivative_minus.
  apply Derivative_scal.
  apply Derivative_id.
 apply Derivative_scal.
 apply Derivative_nth.
 apply Derivative_id.
Qed.

Lemma sin_poly_prf : is_UniformlyContinuousFunction (fun x => sin_poly_fun (QboundAbs (1#1) x)) sin_poly_modulus.
Proof.
  apply (fun a => is_UniformlyContinuousD_Q
                 (Some (-(1))%Q) (Some (1:Q)) eq_refl _ _ DthreeXMinusFourX3 sin_poly_fun a (9#1)).
  simpl; intros q _ _.
  apply sin_poly_fun_correct.
 simpl; intros x' _ [Hx0 Hx1].
 set (x:=(inj_Q IR x')) in *.
 stepr (Nine:IR); [| now (apply eq_symmetric; apply (inj_Q_nring IR 9))].
 stepl (ABSIR (Three[-]Twelve[*]x[*]x)); [| now (apply AbsIR_wd; rational)].
 apply AbsSmall_imp_AbsIR.
 split.
  apply shift_zero_leEq_minus'.
  rstepr (Twelve[*]((nring 1)[-]x)[*](x[-][--](nring 1))).
  repeat apply mult_resp_nonneg.
    apply (nring_nonneg IR 12).
   apply shift_zero_leEq_minus.
   stepr (inj_Q IR (nring 1)); [| now apply inj_Q_nring].
   assumption.
  apply shift_zero_leEq_minus.
  stepl (inj_Q IR (-(1))).
   assumption.
  stepr ([--](inj_Q IR 1)).
   apply inj_Q_inv.
  apply un_op_wd_unfolded.
  apply (inj_Q_nring IR 1).
 rstepr (Nine[-][0]:IR).
 apply minus_resp_leEq_both.
  apply nring_leEq.
  lia.
 rstepr (Twelve[*]x[^]2).
 apply mult_resp_nonneg.
  apply (nring_leEq  IR 0 12).
  lia.
 apply sqr_nonneg.
Qed.

Definition sin_poly_uc : Q_as_MetricSpace --> Q_as_MetricSpace :=
Build_UniformlyContinuousFunction sin_poly_prf.

Definition sin_poly : CR --> CR
  := uc_compose compress (Cmap QPrelengthSpace sin_poly_uc).

Lemma sin_poly_correct : forall x,
    AbsSmall (inj_Q IR (1)) x
    -> (IRasCR (Three[*]x[-]Four[*]x[^]3)==sin_poly (IRasCR x))%CR.
Proof.
 intros x Hx.
 assert (Y:Continuous (clcr (inj_Q IR (-(1))) (inj_Q IR (1:Q))) ((Three:IR){**}FId{-}(Four:IR){**}FId{^}3)).
  eapply Derivative_imp_Continuous.
  apply DthreeXMinusFourX3.
  apply: (ContinuousCorrect
            (I:=(clcr (inj_Q IR (-(1))) (inj_Q IR (1:Q))))
            (inj_Q_less _ (-1) 1 eq_refl) Y);
   [|repeat constructor|].
  intros q Hq Hq0.
  transitivity (IRasCR (inj_Q IR (sin_poly_fun q)));[|apply IRasCR_wd; apply sin_poly_fun_correct].
  simpl.
  change (' q)%CR with (Cunit_fun _ q).
  rewrite -> compress_fun_correct.
  rewrite -> Cmap_fun_correct.
  rewrite -> MonadLaw3.
  rewrite -> IR_inj_Q_as_CR.
  rewrite -> CReq_Qeq.
  simpl.
  unfold sin_poly_fun.
  setoid_replace (Qmax (- (1)) (Qmin 1 q)) with q.
   reflexivity.
  setoid_replace (Qmin 1 q) with q.
   rewrite <- Qle_max_r.
   apply leEq_inj_Q with IR.
   destruct Hq0; assumption.
  rewrite <- Qle_min_r.
  apply leEq_inj_Q with IR.
  destruct Hq0; assumption.
 destruct Hx; split;[stepl [--](inj_Q IR (1:Q)); [| now apply eq_symmetric; apply inj_Q_inv] |];assumption.
Qed.

Lemma Sin_triple_angle : forall x, (Sin(Three[*]x)[=]Three[*]Sin x[-]Four[*]Sin x[^]3).
Proof.
 intros x.
 assert (H:Three[*]x[=]x[+]x[+]x) by rational.
 csetoid_rewrite H.
 csetoid_rewrite (Sin_plus (x[+]x) x).
 csetoid_rewrite (Sin_plus x x).
 csetoid_rewrite (Cos_plus x x).
 set (sx:=Sin x).
 set (cx:=Cos x).
 rstepl ((cx[^]2)[*](Three[*]sx)[-]sx[^]3).
 unfold cg_minus.
 csetoid_replace (cx[^]2) ([1][-]sx[^]2).
  rational.
 apply cg_inv_unique_2.
 rstepl ((cx[^]2[+]sx[^]2)[-][1]).
 apply x_minus_x.
 apply FFT.
Qed.

Lemma shrink_by_three : forall n a,
    -(3^(S n))%Z <= a <= (3^(S n))%Z -> -(3^n)%Z <= a/3 <= (3^n)%Z.
Proof.
  intros n a H0.
  apply AbsSmall_Qabs. apply AbsSmall_Qabs in H0.
  apply Qmult_lt_0_le_reg_r with (Qabs 3).
  reflexivity. rewrite <- Qabs_Qmult.
  unfold Qdiv. rewrite <- Qmult_assoc.
  setoid_replace (/ 3 * 3) with 1 by reflexivity.
  rewrite Qmult_1_r.
  apply (Qle_trans _ _ _ H0). clear H0.
  change (Qabs 3) with (inject_Z 3).
  rewrite <- (inject_Z_mult (3^n) 3).
  rewrite <- Zle_Qle.
  change (S n) with (1+n)%nat.
  rewrite (Nat2Z.inj_add 1 n).
  rewrite ZBinary.Z.pow_add_r, Z.mul_comm.
  apply Z.le_refl.
  discriminate.
  apply (Nat2Z.inj_le 0), le_0_n.
Qed.

Fixpoint rational_sin_bounded (n:nat) (a:Q) : -(3^n)%Z <= a <= (3^n)%Z -> CR :=
match n return -(3^n)%Z <= a <= (3^n)%Z -> CR with
| O => @rational_sin_small a
| S n' => fun H => sin_poly (rational_sin_bounded n' (shrink_by_three n' H))
end.

Lemma rational_sin_bounded_correct_aux a :
  (sin_poly (IRasCR (Sin (inj_Q IR (a / 3)))) == IRasCR (Sin (inj_Q IR a)))%CR.
Proof.
 rewrite <- sin_poly_correct; [|apply AbsIR_imp_AbsSmall;
   (stepr (nring 1:IR); [| now apply eq_symmetric; apply (inj_Q_nring IR 1)]); rstepr ([1]:IR);
     apply AbsIR_Sin_leEq_One].
 apply IRasCR_wd.
 stepl (Sin (inj_Q IR (a/3*3))).
  apply Sin_wd.
  apply inj_Q_wd.
  simpl; field; discriminate.
 generalize (a/3).
 intros b; clear -b.
 stepr (Sin (Three[*](inj_Q IR b))).
  apply Sin_wd.
  stepr ((inj_Q IR b)[*](inj_Q IR (3:Q))).
   apply inj_Q_mult.
  csetoid_replace (inj_Q IR (3:Q)) (Three:IR).
   rational.
  apply (inj_Q_nring IR 3).
 apply Sin_triple_angle.
Qed.

Lemma rational_sin_bounded_correct :
  forall (n:nat) (a:Q) (Ha : -(3^n #1) <= a <= (3^n #1)),
    (@rational_sin_bounded n a Ha == IRasCR (Sin (inj_Q IR a)))%CR.
Proof.
 induction n.
  apply rational_sin_small_correct.
 intros a Ha.
 unfold rational_sin_bounded; fold rational_sin_bounded.
 rewrite -> IHn.
 apply rational_sin_bounded_correct_aux.
Qed.
End Sin_Poly.

Definition sin_bound (q:Q) : nat := Z.abs_nat (1 + Qdlog 3 (Qabs q)).

Lemma sin_bound_correct : forall q, -(3 ^ sin_bound q #1) ≤ q ≤ (3 ^ sin_bound q #1).
Proof.
  intro q.
  apply AbsSmall_Qabs.
  unfold sin_bound.
  destruct (Qlt_le_dec (Qabs q) 1).
  - apply (Qle_trans _ 1).
    apply Qlt_le_weak, q0.
    rewrite Qdlog2_le1; simpl; try easy.
    apply Qlt_le_weak, q0.
  - assert (2 ≤ 3%Z) as H by discriminate.
    pose proof (Qdlog_spec 3 (Qabs q) H q0) as [_ H0]. clear H.
    unfold additional_operations.pow, stdlib_rationals.Q_pow in H0.
    assert (0 <= 1 + Qdlog 3 (Qabs q))%Z.
    { apply semirings.nonneg_plus_compat; [easy | now apply Qdlog_bounded_nonneg]. }
    rewrite inj_Zabs_nat, Z.abs_eq.
    apply Qlt_le_weak.
    rewrite <- Zpower_Qpower in H0. apply H0.
    exact H. exact H.
Qed.

(** Therefore sin works on all real numbers. *)
Definition rational_sin (a:Q) : CR :=
  rational_sin_bounded (sin_bound a) (sin_bound_correct a).

Lemma rational_sin_correct : forall (a:Q),
    (rational_sin a == IRasCR (Sin (inj_Q IR a)))%CR.
Proof.
 intros; apply rational_sin_bounded_correct.
Qed.

#[global]
Instance: Proper ((=) ==> (=)) rational_sin.
Proof.
 intros ? ? E.
 rewrite ?rational_sin_correct.
 now apply IRasCR_wd, Sin_wd, inj_Q_wd.
Qed.

Lemma rational_sin_poly (a : Q) :
  sin_poly (rational_sin (a / 3)) = rational_sin a.
Proof.
 rewrite ?rational_sin_correct.
 apply rational_sin_bounded_correct_aux.
Qed.

Lemma rational_sin_correct_aux (a : Q) :
  (- IRasCR (Sin (inj_Q IR (- a)%Q)) == IRasCR (Sin (inj_Q IR a)))%CR.
Proof.
 rewrite <- IR_opp_as_CR.
 apply IRasCR_wd.
 csetoid_rewrite_rev (Sin_inv (inj_Q IR (-a))).
 apply Sin_wd.
 csetoid_rewrite_rev (inj_Q_inv IR (-a)).
 apply inj_Q_wd.
 simpl.
 ring.
Qed.

Lemma rational_sin_opp (a : Q) :
  (-rational_sin (-a) = rational_sin a)%CR.
Proof.
  rewrite ?rational_sin_correct.
  now apply rational_sin_correct_aux.
Qed.

(** Sine is uniformly continuous everywhere. *)
Definition sin_uc_prf : is_UniformlyContinuousFunction rational_sin Qpos2QposInf.
Proof.
 apply (is_UniformlyContinuousFunction_wd) with (fun x => rational_sin x) (Qscale_modulus (1#1)).
   reflexivity.
  intros x.
  simpl.
  autorewrite with QposElim.
  change (/1) with 1.
  replace RHS with (proj1_sig x) by simpl; ring.
  apply Qle_refl.
 apply (is_UniformlyContinuousD None None I Sine Cosine (Derivative_Sin I) rational_sin).
  intros q [] _.
  apply rational_sin_correct.
 intros x [] _.
 stepr ([1]:IR).
  apply: AbsIR_Cos_leEq_One.
 rstepl (nring 1:IR).
 apply eq_symmetric.
 apply (inj_Q_nring IR 1).
Qed.

Definition sin_uc : Q_as_MetricSpace --> CR :=
Build_UniformlyContinuousFunction sin_uc_prf.

Definition sin_slow : CR --> CR := Cbind QPrelengthSpace sin_uc.

Lemma sin_slow_correct : forall x,
 (IRasCR (Sin x) == sin_slow (IRasCR x))%CR.
Proof.
 intros x.
 apply: (ContinuousCorrect (I:proper realline)); [apply Continuous_Sin | | constructor].
 intros q [] _.
 transitivity (rational_sin q);[|apply rational_sin_correct].
 unfold sin_slow.
 rewrite -> (Cbind_fun_correct QPrelengthSpace sin_uc).
 apply: BindLaw1.
Qed.

Definition sin (x:CR) := sin_slow (x - (compress (scale (2*Qceiling (approximate (x*(CRinv_pos (6#1) (scale 2 CRpi))) (Qpos2QposInf (1#2)) -(1#2))) CRpi)))%CR.

Lemma sin_correct : forall x,
  (IRasCR (Sin x) == sin (IRasCR x))%CR.
Proof.
 intros x.
 unfold sin.
 generalize (Qceiling (approximate (IRasCR x * CRinv_pos (6 # 1) (scale 2 CRpi))
   (Qpos2QposInf (1 # 2)) - (1 # 2)))%CR.
 intros z.
 rewrite -> compress_correct.
 rewrite <- CRpi_correct, <- CRmult_scale, <- IR_inj_Q_as_CR, <- IR_mult_as_CR,
   <- IR_minus_as_CR, <- sin_slow_correct.
 apply IRasCR_wd.
 rewrite -> inj_Q_mult.
 change (2:Q) with (@nring Q_as_CRing 2).
 rewrite -> inj_Q_nring.
 rstepr (Sin (x[+]([--](inj_Q IR z))[*](Two[*]Pi))).
 setoid_replace (inj_Q IR z) with (zring z:IR).
  rewrite <- zring_inv.
  symmetry; apply Sin_periodic_Z.
 rewrite <- inj_Q_zring.
 apply inj_Q_wd.
 symmetry; apply zring_Q.
Qed.

(* begin hide *)
#[global]
Hint Rewrite sin_correct : IRtoCR.
(* end hide *)


(* Cases with let-in in constructors types *)

Inductive t : Set :=
    k : let x := t in x -> x.

Print t_rect.

(* Do not contract nested patterns with dependent return type *)
(* see bug #1699 *)

Require Import Arith.

Definition proj (x y:nat) (P:nat -> Type) (def:P x) (prf:P y) : P y :=
  match eq_nat_dec x y return P y with
  | left eqprf =>
    match eqprf in (_ = z) return (P z) with
    | refl_equal => def
    end
  | _ => prf
 end.

Print proj.

(* Use notations even below aliases *)

Require Import List.

Fixpoint foo (A:Type) (l:list A) : option A :=
  match l with
  | nil => None
  | x0 :: nil => Some x0
  | x0 :: (x1 :: xs) as l0 => foo A l0
  end.

Print foo.

(* Do not duplicate the matched term *)

Axiom A : nat -> bool.

Definition foo' :=
  match A 0 with
    | true => true
    | x => x
  end.

Print foo'.