(*  DEC 2.0 language specification.
   Paolo Torrini
   Universite' de Lille - CRIStAL-CNRS
*)

Require Import List.
Require Import Equality.

Require Import AuxLibI1.
Require Import TypSpecI1.
Require Import ModTypI1.
Require Import LangSpecI1.
Require Import StaticSemI1.
Require Import DynamicSemI1.

Import ListNotations.

(** Weakening lemmas *)

Module Weaken (IdT: ModTyp) <: ModTyp.

Module DynamicSemL := DynamicSem IdT.
Export DynamicSemL.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Definition EStepWeaken_def :
  forall (fenv: funEnv) (env: valEnv) (a1 a2: AConfig Exp),
      EStep fenv env a1 a2 -> Type
  := fun (fenv: funEnv) (env: valEnv)
      (a1 a2: AConfig Exp)
      (k: EStep fenv env a1 a2) =>
       forall (fenv': funEnv) (env': valEnv),
         EStep (fenv ++ fenv') (env ++ env') a1 a2.

Definition PStepWeaken_def :
  forall (fenv: funEnv) (env: valEnv) (a1 a2: AConfig Prms),
      PStep fenv env a1 a2 -> Type
  := fun (fenv: funEnv) (env: valEnv)
      (a1 a2: AConfig Prms)
      (k: PStep fenv env a1 a2) =>
       forall (fenv': funEnv) (env': valEnv),
         PStep (fenv ++ fenv') (env ++ env') a1 a2.

Definition Weaken_EStep_mut := EStep_mut EStepWeaken_def PStepWeaken_def.

Definition Weaken_PStep_mut := PStep_mut EStepWeaken_def PStepWeaken_def.

(**********************************************************************)

Definition EStep_mut2
   (P1 : forall (fenv: funEnv) (env: valEnv)
                (s1 s2: W) (n1 n2: nat) (e1 e2: Exp),
       EStep fenv env (Conf Exp s1 n1 e1) (Conf Exp s2 n2 e2) -> Type)
   (P2 : forall (fenv: funEnv) (env: valEnv)
                (s1 s2: W) (n1 n2: nat) (ps1 ps2: Prms),
       PStep fenv env (Conf Prms s1 n1 ps1) (Conf Prms s2 n2 ps2) -> Type) :=
  EStep_mut (fun fenv env a1 a2 => match a1 with Conf _ s1 n1 e1 =>
                                   match a2 with Conf _ s2 n2 e2 =>
                                   P1 fenv env s1 s2 n1 n2 e1 e2 end end)
            (fun fenv env a1 a2 => match a1 with Conf _ s1 n1 ps1 =>
                                   match a2 with Conf _ s2 n2 ps2 =>
                                   P2 fenv env s1 s2 n1 n2 ps1 ps2 end end).

Definition EStepWeaken_def2 :
  forall (fenv: funEnv) (env: valEnv)
         (s1 s2: W) (n1 n2: nat) (e1 e2: Exp),
      EStep fenv env (Conf Exp s1 n1 e1) (Conf Exp s2 n2 e2) -> Type
  := fun (fenv: funEnv) (env: valEnv)
         (s1 s2: W) (n1 n2: nat) (e1 e2: Exp)
         (k: EStep fenv env (Conf Exp s1 n1 e1) (Conf Exp s2 n2 e2)) =>
       forall env': valEnv, EStep fenv (env ++ env')
                            (Conf Exp s1 n1 e1) (Conf Exp s2 n2 e2).

Definition PStepWeaken_def2 :
  forall (fenv: funEnv) (env: valEnv)
         (s1 s2: W) (n1 n2: nat) (ps1 ps2: Prms),
      PStep fenv env (Conf Prms s1 n1 ps1) (Conf Prms s2 n2 ps2) -> Type
  := fun (fenv: funEnv) (env: valEnv)
         (s1 s2: W) (n1 n2: nat) (ps1 ps2: Prms)
         (k: PStep fenv env (Conf Prms s1 n1 ps1) (Conf Prms s2 n2 ps2)) =>
       forall env': valEnv, PStep fenv (env ++ env')
                            (Conf Prms s1 n1 ps1) (Conf Prms s2 n2 ps2).

Definition Weaken_EStep_mut2 := EStep_mut2 EStepWeaken_def2 PStepWeaken_def2.

(*************************************************************************)

Lemma EStepWeakenA
           (fenv fenv': funEnv) (env env': valEnv)
           (a1 a2: AConfig Exp):
      EStep fenv env a1 a2 ->
      EStep (fenv ++ fenv') (env ++ env') a1 a2.
Proof.
  intros.
  eapply Weaken_EStep_mut.
  - intros.
    unfold EStepWeaken_def.
    intros fenv1 env1.
    constructor.
    generalize e as e1; intro.
    eapply override_simpl1 with (env2:=env0) in e.
    rewrite e.
    exact e1.
  - intros.
    unfold EStepWeaken_def.
    intros fenv1 env1.
    constructor.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def.
    intros fenv1 env1.
    constructor.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    econstructor.
    reflexivity.
    specialize (X0 fenv1 env1).
    rewrite e0 in X0.
    rewrite app_assoc.
    exact X0.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    rewrite e in *.
    rewrite e0 in *.
    econstructor.
    exact f.
    reflexivity.
    exact i.
    reflexivity.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    econstructor.
    generalize e as e4; intro.
    eapply (override_simpl1 fenv0 fenv1 x f) in e.
    rewrite e.
    exact e4.
    exact i.
    exact e0.
    exact e1.
    exact e2.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    econstructor.
    exact i.
    generalize e0 as e4; intro.
    eapply (override_simpl1 fenv0 fenv1 x f) in e0.
    rewrite e0.
    exact e4.
    exact e1.
    exact e2.
    exact e3.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def, PStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def, PStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - exact X.
Defined.

Lemma PStepWeakenA
           (fenv fenv': funEnv) (env env': valEnv)
           (a1 a2: AConfig Prms):
      PStep fenv env a1 a2 ->
      PStep (fenv ++ fenv') (env ++ env') a1 a2.
Proof.
  intros.
  eapply Weaken_PStep_mut.
  - intros.
    unfold EStepWeaken_def.
    intros fenv1 env1.
    constructor.
    generalize e as e1; intro.
    eapply override_simpl1 with (env2:=env0) in e.
    rewrite e.
    exact e1.
  - intros.
    unfold EStepWeaken_def.
    intros fenv1 env1.
    constructor.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def.
    intros fenv1 env1.
    constructor.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    econstructor.
    reflexivity.
    specialize (X0 fenv1 env1).
    rewrite e0 in X0.
    rewrite app_assoc.
    exact X0.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    rewrite e in *.
    rewrite e0 in *.
    econstructor.
    exact f.
    reflexivity.
    exact i.
    reflexivity.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    econstructor.
    generalize e as e4; intro.
    eapply (override_simpl1 fenv0 fenv1 x f) in e.
    rewrite e.
    exact e4.
    exact i.
    exact e0.
    exact e1.
    exact e2.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    econstructor.
    exact i.
    generalize e0 as e4; intro.
    eapply (override_simpl1 fenv0 fenv1 x f) in e0.
    rewrite e0.
    exact e4.
    exact e1.
    exact e2.
    exact e3.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
  - intros.
    unfold EStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def, PStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - intros.
    unfold EStepWeaken_def, PStepWeaken_def in *.
    intros fenv1 env1.
    constructor.
    apply X0.
  - exact X.
Defined.

Lemma EClosWeakenA
      (fenv fenv': funEnv) (env env': valEnv)
      (a1 a2: AConfig Exp):
      EClosure fenv env a1 a2 ->
      EClosure (fenv ++ fenv') (env ++ env') a1 a2.
Proof.
  intros.
  dependent induction X.
  constructor.
  eapply EStepWeakenA with (fenv':=fenv') (env':=env') in e.
  econstructor.
  exact e.
  exact IHX.
Defined.

Lemma PClosWeakenA
      (fenv fenv': funEnv) (env env': valEnv)
      (a1 a2: AConfig Prms):
      PClosure fenv env a1 a2 ->
      PClosure (fenv ++ fenv') (env ++ env') a1 a2.
Proof.
  intros.
  dependent induction X.
  constructor.
  eapply PStepWeakenA with (fenv':=fenv') (env':=env') in p.
  econstructor.
  exact p.
  exact IHX.
Defined.

Lemma EClosWeakenA1
      (fenv: funEnv) (env env': valEnv)
      (a1 a2: AConfig Exp):
      EClosure fenv env a1 a2 ->
      EClosure fenv (env ++ env') a1 a2.
Proof.
  intros.
  dependent induction X.
  constructor.
  eapply EStepWeakenA with (fenv':=nil) (env':=env') in e.
  rewrite app_nil_r in e.
  econstructor.
  exact e.
  exact IHX.
Defined.

Lemma PClosWeakenA1
      (fenv: funEnv) (env env': valEnv)
      (a1 a2: AConfig Prms):
      PClosure fenv env a1 a2 ->
      PClosure fenv (env ++ env') a1 a2.
Proof.
  intros.
  dependent induction X.
  constructor.
  eapply PStepWeakenA with (fenv':=nil) (env':=env') in p.
  rewrite app_nil_r in p.
  econstructor.
  exact p.
  exact IHX.
Defined.

Lemma EStepWeaken
           (fenv fenv1 fenv2: funEnv) (env env1 env2: valEnv)
           (a1 a2: AConfig Exp):
  EStep fenv1 env1 a1 a2 ->
  fenv = fenv1 ++ fenv2 ->
  env = env1 ++ env2 ->
  EStep fenv env a1 a2.
Proof.
  intros.
  inversion H; subst.
  eapply EStepWeakenA.
  auto.
Defined.

Lemma PStepWeaken
           (fenv fenv1 fenv2: funEnv) (env env1 env2: valEnv)
           (a1 a2: AConfig Prms):
  PStep fenv1 env1 a1 a2 ->
  fenv = fenv1 ++ fenv2 ->
  env = env1 ++ env2 ->
  PStep fenv env a1 a2.
  intros.
  inversion H; subst.
  eapply PStepWeakenA.
  auto.
Defined.

Lemma EClosWeaken
      (fenv fenv1 fenv2: funEnv) (env env1 env2: valEnv)
      (a1 a2: AConfig Exp):
  EClosure fenv1 env1 a1 a2 ->
  fenv = fenv1 ++ fenv2 ->
  env = env1 ++ env2 ->
  EClosure fenv env a1 a2.
  intros.
  inversion H; subst.
  eapply EClosWeakenA.
  auto.
Defined.

Lemma PClosWeaken
      (fenv fenv1 fenv2: funEnv) (env env1 env2: valEnv)
      (a1 a2: AConfig Prms):
  PClosure fenv1 env1 a1 a2 ->
  fenv = fenv1 ++ fenv2 ->
  env = env1 ++ env2 ->
  PClosure fenv env a1 a2.
  intros.
  inversion H; subst.
  eapply PClosWeakenA.
  auto.
Defined.

(***************************************************************************)

Lemma EnvrWeaken (T: Type) (env env': Envr Id T) (x: Id) (t: T) :
 EnvrAssign env x t -> EnvrAssign (env ++ env') x t.
  intros.
  inversion H; subst.
 (* inversion X0; subst. *)
  unfold EnvrAssign.
 (* constructor. *)
  erewrite override_simpl1.
  exact H.
  exact H1.
Defined.

Lemma IdTWeaken (tenv tenv': valTC) (x: Id) (t: VTyp) :
  IdTyping tenv x t -> IdTyping (tenv ++ tenv') x t.
  apply EnvrWeaken.
Defined.

Lemma IdFTWeaken (ftenv ftenv': funTC) (x: Id) (ft: FTyp) :
  IdFTyping ftenv x ft -> IdFTyping (ftenv ++ ftenv') x ft.
  apply EnvrWeaken.
Defined.

Definition ExpTWeaken_def :
  forall (ftenv: funTC) (tenv: valTC) (e: Exp) (t: VTyp),
      ExpTyping ftenv tenv e t -> Type
  := fun (ftenv: funTC) (tenv: valTC)
      (e: Exp) (t: VTyp)
      (k: ExpTyping ftenv tenv e t) =>
   forall (ftenv': funTC) (tenv': valTC),
       ExpTyping (ftenv ++ ftenv') (tenv ++ tenv') e t.

Definition PrmsTWeaken_def :
  forall (ftenv: funTC) (tenv: valTC) (ps: Prms) (pt: PTyp),
    PrmsTyping ftenv tenv ps pt -> Type
  := fun (ftenv: funTC) (tenv: valTC) (ps: Prms) (pt: PTyp)
          (k: PrmsTyping ftenv tenv ps pt) =>
   forall (ftenv': funTC) (tenv': valTC),
       PrmsTyping (ftenv ++ ftenv') (tenv ++ tenv') ps pt.

Definition Weaken_ExpTyping_mut :=
  ExpTyping_mut ExpTWeaken_def PrmsTWeaken_def.

Definition Weaken_PrmsTyping_mut :=
  PrmsTyping_mut ExpTWeaken_def PrmsTWeaken_def.

Lemma ExpTWeakenA
         (ftenv: funTC) (tenv: valTC)
         (e: Exp) (t: VTyp)
         (k: ExpTyping ftenv tenv e t) :
   forall (ftenv': funTC) (tenv': valTC),
       ExpTyping (ftenv ++ ftenv') (tenv ++ tenv') e t.
  intros.
  eapply Weaken_ExpTyping_mut.
  - intros.
    unfold ExpTWeaken_def.
    intros ftenv1 tenv1.
    constructor.
    exact v0.
  - intros.
    unfold ExpTWeaken_def.
    intros ftenv1 tenv1.
    constructor.
    eapply IdTWeaken.
    exact i.
  - intros.
    unfold ExpTWeaken_def in *.
    intros ftenv1 tenv1.
    econstructor.
    apply X.
    apply X0.
  - intros.
    unfold ExpTWeaken_def in *.
    intros ftenv1 tenv1.
    inversion m0; subst.
    + econstructor.
      eassumption.
      reflexivity.
      apply X.
      rewrite app_comm_cons.
      eapply X0.
    + econstructor.
      eassumption.
      reflexivity.
      apply X.
      simpl.
      rewrite app_comm_cons.
      eapply X0.
  - intros.
    unfold ExpTWeaken_def in *.
    intros ftenv3 tenv3.
    econstructor.
    eassumption.
    reflexivity.
    rewrite e2 in X.
    rewrite app_assoc.
    apply X.
  - intros.
    unfold ExpTWeaken_def in *.
    intros ftenv3 tenv3.
    econstructor.
    apply X.
    apply X0.
    apply X1.
  - intros.
    unfold ExpTWeaken_def, PrmsTWeaken_def in *.
    intros ftenv3 tenv3.
    inversion p; subst.
    + econstructor.
      assumption.
      eapply IdFTWeaken.
      exact i.
      apply X.
      apply X0.
    + econstructor.
      assumption.
      eapply IdFTWeaken.
      exact i.
      apply X.
      apply X0.
  - intros.
    unfold ExpTWeaken_def, PrmsTWeaken_def in *.
    intros ftenv3 tenv3.
    econstructor.
    eapply IdFTWeaken.
    exact i.
    apply X.
  - intros.
    unfold ExpTWeaken_def, PrmsTWeaken_def in *.
    intros ftenv3 tenv3.
    econstructor.
    apply X.
  - intros.
    unfold PrmsTWeaken_def in *.
    intros ftenv3 tenv3.
    constructor.
  - intros.
    unfold PrmsTWeaken_def in *.
    intros ftenv3 tenv3.
    constructor.
    apply X.
    apply X0.
  - exact k.
Defined.

Lemma PrmsTWeakenA
         (ftenv: funTC) (tenv: valTC)
         (ps: Prms) (pt: PTyp)
         (k: PrmsTyping ftenv tenv ps pt) :
   forall (ftenv': funTC) (tenv': valTC),
       PrmsTyping (ftenv ++ ftenv') (tenv ++ tenv') ps pt.
  intros.
  eapply Weaken_PrmsTyping_mut.
  - intros.
    unfold ExpTWeaken_def.
    intros ftenv1 tenv1.
    constructor.
    exact v0.
  - intros.
    unfold ExpTWeaken_def.
    intros ftenv1 tenv1.
    constructor.
    eapply IdTWeaken.
    exact i.
  - intros.
    unfold ExpTWeaken_def in *.
    intros ftenv1 tenv1.
    econstructor.
    apply X.
    apply X0.
  - intros.
    unfold ExpTWeaken_def in *.
    intros ftenv1 tenv1.
    inversion m0; subst.
    + econstructor.
      eassumption.
      reflexivity.
      apply X.
      rewrite app_comm_cons.
      eapply X0.
    + econstructor.
      eassumption.
      reflexivity.
      apply X.
      simpl.
      rewrite app_comm_cons.
      eapply X0.
  - intros.
    unfold ExpTWeaken_def in *.
    intros ftenv3 tenv3.
    econstructor.
    eassumption.
    reflexivity.
    rewrite e1 in X.
    rewrite app_assoc.
    apply X.
  - intros.
    unfold ExpTWeaken_def in *.
    intros ftenv3 tenv3.
    econstructor.
    apply X.
    apply X0.
    apply X1.
  - intros.
    unfold ExpTWeaken_def, PrmsTWeaken_def in *.
    intros ftenv3 tenv3.
    inversion p; subst.
    + econstructor.
      assumption.
      eapply IdFTWeaken.
      exact i.
      apply X.
      apply X0.
    + econstructor.
      assumption.
      eapply IdFTWeaken.
      exact i.
      apply X.
      apply X0.
  - intros.
    unfold ExpTWeaken_def, PrmsTWeaken_def in *.
    intros ftenv3 tenv3.
    econstructor.
    eapply IdFTWeaken.
    exact i.
    apply X.
  - intros.
    unfold ExpTWeaken_def, PrmsTWeaken_def in *.
    intros ftenv3 tenv3.
    econstructor.
    apply X.
  - intros.
    unfold PrmsTWeaken_def in *.
    intros ftenv3 tenv3.
    constructor.
  - intros.
    unfold PrmsTWeaken_def in *.
    intros ftenv3 tenv3.
    constructor.
    apply X.
    apply X0.
  - exact k.
Defined.

Lemma ExpTWeaken
         (ftenv ftenv1 ftenv2: funTC) (tenv tenv1 tenv2: valTC)
         (e: Exp) (t: VTyp)
         (k: ExpTyping ftenv1 tenv1 e t) :
  ftenv = ftenv1 ++ ftenv2 ->
  tenv = tenv1 ++ tenv2 ->
  ExpTyping ftenv tenv e t.
  intros.
  inversion H; subst.
  eapply ExpTWeakenA.
  auto.
Defined.

Lemma PrmsTWeaken
         (ftenv ftenv1 ftenv2: funTC) (tenv tenv1 tenv2: valTC)
         (ps: Prms) (pt: PTyp)
         (k: PrmsTyping ftenv1 tenv1 ps pt) :
  ftenv = ftenv1 ++ ftenv2 ->
  tenv = tenv1 ++ tenv2 ->
  PrmsTyping ftenv tenv ps pt.
  intros.
  inversion H; subst.
  eapply PrmsTWeakenA.
  auto.
Defined.

End Weaken.


Require Import FcEtt.sigs.
Require Export FcEtt.imports.
Require Export FcEtt.ett_inf.
Require Export FcEtt.ett_ind.

Require Import FcEtt.tactics.
Require Import FcEtt.ett_par.

Require Import FcEtt.erase_syntax.

Require Export FcEtt.fc_wf.

(**** Weakening Lemmas ****)

(* TODO: can remove this parameter *)
Module fc_weak (wf : fc_wf_sig) <: fc_weak_sig.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

(* ------------------------------------------------------------------- *)

Lemma ann_respects_atoms_eq_mutual :
  (forall G a A,       AnnTyping  G a A       -> True) /\
  (forall G phi,       AnnPropWff G phi       -> True) /\
  (forall G D g p1 p2, AnnIso     G D g p1 p2 -> forall D', D [=] D' -> AnnIso   G D' g p1 p2) /\
  (forall G D g A B,   AnnDefEq   G D g A B   -> forall D', D [=] D' -> AnnDefEq G D' g A B) /\
  (forall G,           AnnCtx     G           -> True).
Proof.
  eapply ann_typing_wff_iso_defeq_mutual.
  all: pre; subst; eauto 3.
  all: econstructor; eauto.
  fsetdec.
Qed.

Definition AnnIso_respects_atoms_eq   := third  ann_respects_atoms_eq_mutual.
Definition AnnDefEq_respects_atoms_eq := fourth ann_respects_atoms_eq_mutual.

Instance AnnIso_atoms_eq_mor : Morphisms.Proper
                                 (eq ==> AtomSetImpl.Equal ==> eq ==> eq ==> eq ==> iff)
                                 AnnIso.
Proof.
  simpl_relation; split=> ?;
  eauto using AnnIso_respects_atoms_eq, AtomSetProperties.equal_sym.
Qed.

Instance AnnDefEq_atoms_eq_mor : Morphisms.Proper
                                   (eq ==> AtomSetImpl.Equal ==> eq ==> eq ==> eq ==> iff)
                                   AnnDefEq.
Proof.
  simpl_relation; split=> ?;
  eauto using AnnDefEq_respects_atoms_eq, AtomSetProperties.equal_sym.
Qed.

Lemma ann_strengthen_noncovar:
  (forall G1  a A,   AnnTyping G1 a A -> True) /\
  (forall G1  phi,   AnnPropWff G1 phi -> True) /\
  (forall G1 D g p1 p2, AnnIso G1 D g p1 p2 -> forall x, not (exists phi, binds x (Co phi) G1) ->
                     AnnIso G1 (remove x D) g p1 p2) /\
  (forall G1 D g A B,   AnnDefEq G1 D g A B ->  forall x, not (exists phi, binds x (Co phi) G1) ->
                    AnnDefEq G1 (remove x D) g A B) /\
  (forall G1 ,       AnnCtx G1 -> True).
Proof.
  apply ann_typing_wff_iso_defeq_mutual; eauto 3; try done.
  - econstructor; eauto.
  - intros. destruct (x == c).
    + subst. assert False. apply H0. eexists. eauto. done.
    + eapply An_Assn; eauto.
  - econstructor; eauto.
  - intros.
    eapply (An_PiCong (L \u singleton x \u dom G)); eauto.
    intros. eapply H0; auto.
    unfold not in *. intros. destruct H6. apply H4.
    simpl in H6.
    destruct (binds_cons_1 _ x x0 _ (Tm A1) G H6). destruct H7. inversion H8.
    exists x1. auto.
  - intros.
    eapply (An_AbsCong (L \u singleton x)); eauto.
    intros. eapply H0; auto.
    unfold not in *. intros. destruct H6. apply H4.
    simpl in H6.
    destruct (binds_cons_1 _ x x0 _ (Tm A1) G H6). destruct H7. inversion H8.
    exists x1. auto.
  - eauto.
  - eauto.
  - intros.
    eapply (An_CPiCong (L \u singleton x)); eauto.
    intros.
    eapply H0; auto.
    unfold not in *. intros. destruct H6. apply H4.
    simpl in H6.
    destruct (binds_cons_1 _ x c _ (Co phi1) G H6). destruct H7.
    subst. fsetdec.
    exists x0. auto.
  - intros.
    eapply (An_CAbsCong (L \u singleton x)); eauto.
    move=> c Fr.
    eapply H0; first fsetdec.
    move=> [phi b].
    move: b => /binds_cons_iff [[? [?]] | /= b]; first (subst; fsetdec).
      by apply H5; exists phi.
  - eauto.
Qed. (* strengthen_nocovar *)

Lemma AnnDefEq_strengthen_available_tm :
  forall G D g A B, AnnDefEq G D g A B ->  forall x A', binds x (Tm A') G ->
                    forall D', D' [=] remove x D ->
                    AnnDefEq G D' g A B.
Proof.
  intros. eapply ann_respects_atoms_eq_mutual.
  eapply (fourth ann_strengthen_noncovar). eauto.
  unfold not.
  intros b. destruct b as [phi b].
  assert (Tm A' = Co phi). eapply binds_unique; eauto with ctx_wff.
  inversion H2.
  fsetdec.
Qed.

Lemma ann_weaken_available_mutual:
  (forall G1  a A,   AnnTyping G1 a A -> True) /\
  (forall G1  phi,   AnnPropWff G1 phi -> True) /\
  (forall G1 D g p1 p2, AnnIso G1 D g p1 p2 -> forall D', D [<=] D' -> AnnIso G1 D' g p1 p2) /\
  (forall G1 D g A B,   AnnDefEq G1 D g A B -> forall D', D [<=] D' -> AnnDefEq G1 D' g A B) /\
  (forall G1 ,       AnnCtx G1 -> True).
Proof.
  apply ann_typing_wff_iso_defeq_mutual; eauto 3; try done.
  all: econstructor; eauto.
Qed.

Lemma ann_remove_available_mutual:
  (forall G1  a A,   AnnTyping G1 a A -> True) /\
  (forall G1  phi,   AnnPropWff G1 phi -> True) /\
  (forall G1 D g p1 p2, AnnIso G1 D g p1 p2 ->
                   AnnIso G1 (AtomSetImpl.inter D (dom G1)) g p1 p2) /\
  (forall G1 D g A B,   AnnDefEq G1 D g A B ->
                   AnnDefEq G1 (AtomSetImpl.inter D (dom G1)) g A B) /\
  (forall G1 ,       AnnCtx G1 -> True).
Proof.
  apply ann_typing_wff_iso_defeq_mutual; eauto 3; try done.
  - intros L G D. intros.
    eapply (An_PiCong (L \u dom G \u D)); eauto.
    intros.
    eapply (fourth ann_respects_atoms_eq_mutual). eapply H0. eauto.
    simpl. fsetdec.
  - intros L G D. intros.
    eapply (An_AbsCong (L \u dom G \u D)); eauto.
    intros.
    eapply (fourth ann_respects_atoms_eq_mutual). eapply H0. eauto.
    simpl. fsetdec.
  - intros L G D. intros.
    eapply (An_CPiCong (L \u dom G \u D)); eauto.
    intros.
    eapply (fourth ann_respects_atoms_eq_mutual). eapply H0. eauto.
    simpl. fsetdec.
  - intros L G D. intros.
    eapply (An_CAbsCong (L \u dom G \u D)); eauto 1.
    intros.
    eapply (fourth ann_respects_atoms_eq_mutual). eapply H0. eauto.
    simpl. fsetdec.
    eauto.
Qed.

Lemma AnnDefEq_weaken_available :
  forall G D g A B, AnnDefEq G D g A B -> AnnDefEq G (dom G) g A B.
Proof.
  intros.
  remember (AtomSetImpl.inter D (dom G)) as D'.
  eapply (fourth ann_weaken_available_mutual).
  eapply (fourth ann_remove_available_mutual).
  eauto. subst. fsetdec.
Qed.

Lemma AnnIso_weaken_available :
  forall G D g A B, AnnIso G D g A B -> AnnIso G (dom G) g A B.
Proof.
  intros G D. intros.
  remember (AtomSetImpl.inter D (dom G)) as D'.
  eapply (third ann_weaken_available_mutual).
  eapply (third ann_remove_available_mutual).
  eauto. subst. fsetdec.
Qed.

Instance AnnIso_atoms_sub_mor : Morphisms.Proper
                                    (eq ==> AtomSetImpl.Subset ==> eq ==> eq ==> eq ==> impl)
                                    AnnIso.
Proof.
  simpl_relation; eapply (third ann_weaken_available_mutual); eassumption.
Qed.

Instance AnnDefEq_atoms_sub_mor : Morphisms.Proper
                                    (eq ==> AtomSetImpl.Subset ==> eq ==> eq ==> eq ==> impl)
                                    AnnDefEq.
Proof.
  simpl_relation; eapply (fourth ann_weaken_available_mutual); eassumption.
Qed.

(* FIXME: temporary hack *)
Ltac ann_weak_speedup :=
  first [eapply An_AppCong | eapply An_PiSnd].

(* ------------------------------------------------------------------- *)

Lemma ann_typing_weakening_mutual:
  (forall G0 a A,       AnnTyping  G0 a A       ->
     forall E F G, (G0 = F ++ G) -> AnnCtx (F ++ E ++ G) -> AnnTyping (F ++ E ++ G) a A) /\
  (forall G0 phi,       AnnPropWff G0 phi       ->
     forall E F G, (G0 = F ++ G) ->
        AnnCtx (F ++ E ++ G) -> AnnPropWff (F ++ E ++ G) phi) /\
  (forall G0 D g p1 p2, AnnIso     G0 D g p1 p2 ->
     forall E F G, (G0 = F ++ G) ->
        AnnCtx (F ++ E ++ G) -> AnnIso (F ++ E ++ G) D g p1 p2) /\
  (forall G0 D g A B,   AnnDefEq   G0 D g A B   ->
     forall E F G, (G0 = F ++ G) ->
        AnnCtx (F ++ E ++ G) -> AnnDefEq (F ++ E ++ G) D g A B) /\
  (forall G0,           AnnCtx     G0           ->
     forall E F G, (G0 = F ++ G) ->
        AnnCtx (F ++ E ++ G) -> AnnCtx (F ++ E ++ G)).
Proof.
  eapply ann_typing_wff_iso_defeq_mutual.
  all: pre; subst.
  all: eauto 3.
  all: try first [ ann_weak_speedup
                 | An_pick_fresh x;
                   try auto_rew_env;
                   try apply_first_hyp;
                   try simpl_env];
                   eauto 3.
  all: try solve [econstructor; eauto 2].
  all: try solve [eapply AnnDefEq_weaken_available; eauto 2].
  all: try solve [try rewrite <- dom_app; try rewrite <- dom_app;
                  eapply AnnDefEq_weaken_available;  eauto].
  all: try solve [econstructor; eauto 2;
                  eapply AnnDefEq_weaken_available; eauto 2].
  all: try solve [
    (* These are all AnnCtx goals. Need to show the new assumption
       is well-formed by using induction on a term that mentions it.
     *)
    econstructor; eauto 2;
      by move: (H1 E F G0 eq_refl ltac:(auto)); inversion 1].

  (* Left/Right
  eapply An_Right with (a:=a)(a':=a'); eauto 2;
    eapply AnnDefEq_weaken_available; eauto 2. *)
Qed.

Definition AnnTyping_weakening  := first  ann_typing_weakening_mutual.
Definition AnnPropWff_weakening := second ann_typing_weakening_mutual.
Definition AnnIso_weakening     := third  ann_typing_weakening_mutual.
Definition AnnDefEq_weakening   := fourth ann_typing_weakening_mutual.
Definition AnnCtx_weakening     := fifth  ann_typing_weakening_mutual.

End fc_weak.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Rounding to nearest, ties to even: existence, unicity... *)

From Coq Require Import Lia.
Require Import Raux Defs Round_pred Generic_fmt Float_prop Ulp.

Notation ZnearestE := (Znearest (fun x => negb (Z.even x))).

Section Fcore_rnd_NE.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

Context { valid_exp : Valid_exp fexp }.

Notation format := (generic_format beta fexp).
Notation canonical := (canonical beta fexp).

Definition NE_prop (_ : R) f :=
  exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = true.

Definition Rnd_NE_pt :=
  Rnd_NG_pt format NE_prop.

Definition DN_UP_parity_pos_prop :=
  forall x xd xu,
  (0 < x)%R ->
  ~ format x ->
  canonical xd ->
  canonical xu ->
  F2R xd = round beta fexp Zfloor x ->
  F2R xu = round beta fexp Zceil x ->
  Z.even (Fnum xu) = negb (Z.even (Fnum xd)).

Definition DN_UP_parity_prop :=
  forall x xd xu,
  ~ format x ->
  canonical xd ->
  canonical xu ->
  F2R xd = round beta fexp Zfloor x ->
  F2R xu = round beta fexp Zceil x ->
  Z.even (Fnum xu) = negb (Z.even (Fnum xd)).

Lemma DN_UP_parity_aux :
  DN_UP_parity_pos_prop ->
  DN_UP_parity_prop.
Proof.
intros Hpos x xd xu Hfx Hd Hu Hxd Hxu.
destruct (total_order_T 0 x) as [[Hx|Hx]|Hx].
(* . *)
exact (Hpos x xd xu Hx Hfx Hd Hu Hxd Hxu).
elim Hfx.
rewrite <- Hx.
apply generic_format_0.
(* . *)
assert (Hx': (0 < -x)%R).
apply Ropp_lt_cancel.
now rewrite Ropp_involutive, Ropp_0.
destruct xd as (md, ed).
destruct xu as (mu, eu).
simpl.
rewrite <- (Bool.negb_involutive (Z.even mu)).
apply f_equal.
apply sym_eq.
rewrite <- (Z.even_opp mu), <- (Z.even_opp md).
change (Z.even (Fnum (Float beta (-md) ed)) = negb (Z.even (Fnum (Float beta (-mu) eu)))).
apply (Hpos (-x)%R _ _ Hx').
intros H.
apply Hfx.
rewrite <- Ropp_involutive.
now apply generic_format_opp.
now apply canonical_opp.
now apply canonical_opp.
rewrite round_DN_opp, F2R_Zopp.
now apply f_equal.
rewrite round_UP_opp, F2R_Zopp.
now apply f_equal.
Qed.

Class Exists_NE :=
  exists_NE : Z.even beta = false \/ forall e,
  ((fexp e < e)%Z -> (fexp (e + 1) < e)%Z) /\ ((e <= fexp e)%Z -> fexp (fexp e + 1) = fexp e).

Context { exists_NE_ : Exists_NE }.

Theorem DN_UP_parity_generic_pos :
  DN_UP_parity_pos_prop.
Proof with auto with typeclass_instances.
intros x xd xu H0x Hfx Hd Hu Hxd Hxu.
destruct (mag beta x) as (ex, Hexa).
specialize (Hexa (Rgt_not_eq _ _ H0x)).
generalize Hexa. intros Hex.
rewrite (Rabs_pos_eq _ (Rlt_le _ _ H0x)) in Hex.
destruct (Zle_or_lt ex (fexp ex)) as [Hxe|Hxe].
(* small x *)
assert (Hd3 : Fnum xd = Z0).
apply eq_0_F2R with beta (Fexp xd).
change (F2R xd = R0).
rewrite Hxd.
apply round_DN_small_pos with (1 := Hex) (2 := Hxe).
assert (Hu3 : xu = Float beta (1 * Zpower beta (fexp ex - fexp (fexp ex + 1))) (fexp (fexp ex + 1))).
apply canonical_unique with (1 := Hu).
apply (f_equal fexp).
rewrite <- F2R_change_exp.
now rewrite F2R_bpow, mag_bpow.
now apply valid_exp.
rewrite <- F2R_change_exp.
rewrite F2R_bpow.
apply sym_eq.
rewrite Hxu.
apply sym_eq.
apply round_UP_small_pos with (1 := Hex) (2 := Hxe).
now apply valid_exp.
rewrite Hd3, Hu3.
rewrite Zmult_1_l.
simpl.
destruct exists_NE_ as [H|H].
apply Zeven_Zpower_odd with (2 := H).
apply Zle_minus_le_0.
now apply valid_exp.
rewrite (proj2 (H ex)).
now rewrite Zminus_diag.
exact Hxe.
(* large x *)
assert (Hd4: (bpow (ex - 1) <= Rabs (F2R xd) < bpow ex)%R).
rewrite Rabs_pos_eq.
rewrite Hxd.
split.
apply (round_DN_pt beta fexp x).
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
lia.
apply Hex.
apply Rle_lt_trans with (2 := proj2 Hex).
apply (round_DN_pt beta fexp x).
rewrite Hxd.
apply (round_DN_pt beta fexp x).
apply generic_format_0.
now apply Rlt_le.
assert (Hxe2 : (fexp (ex + 1) <= ex)%Z) by now apply valid_exp.
assert (Hud: (F2R xu = F2R xd + ulp beta fexp x)%R).
rewrite Hxu, Hxd.
now apply round_UP_DN_ulp.
destruct (total_order_T (bpow ex) (F2R xu)) as [[Hu2|Hu2]|Hu2].
(* - xu > bpow ex  *)
elim (Rlt_not_le _ _ Hu2).
rewrite Hxu.
apply round_bounded_large_pos...
(* - xu = bpow ex *)
assert (Hu3: xu = Float beta (1 * Zpower beta (ex - fexp (ex + 1))) (fexp (ex + 1))).
apply canonical_unique with (1 := Hu).
apply (f_equal fexp).
rewrite <- F2R_change_exp.
now rewrite F2R_bpow, mag_bpow.
now apply valid_exp.
rewrite <- Hu2.
apply sym_eq.
rewrite <- F2R_change_exp.
apply F2R_bpow.
exact Hxe2.
assert (Hd3: xd = Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex)).
assert (H: F2R xd = F2R (Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex))).
unfold F2R. simpl.
rewrite minus_IZR.
unfold Rminus.
rewrite Rmult_plus_distr_r.
rewrite IZR_Zpower, <- bpow_plus.
ring_simplify (ex - fexp ex + fexp ex)%Z.
rewrite Hu2, Hud.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
unfold cexp.
rewrite mag_unique with beta x ex.
unfold F2R.
simpl. ring.
rewrite Rabs_pos_eq.
exact Hex.
now apply Rlt_le.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
apply canonical_unique with (1 := Hd) (3 := H).
apply (f_equal fexp).
rewrite <- H.
apply sym_eq.
now apply mag_unique.
rewrite Hd3, Hu3.
unfold Fnum.
rewrite Z.even_mul. simpl.
unfold Zminus at 2.
rewrite Z.even_add.
rewrite eqb_sym. simpl.
fold (negb (Z.even (beta ^ (ex - fexp ex)))).
rewrite Bool.negb_involutive.
rewrite (Z.even_pow beta (ex - fexp ex)) by lia.
destruct exists_NE_.
rewrite H.
apply Zeven_Zpower_odd with (2 := H).
now apply Zle_minus_le_0.
apply Z.even_pow.
specialize (H ex).
lia.
(* - xu < bpow ex *)
revert Hud.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
unfold F2R.
rewrite Hd, Hu.
unfold cexp.
rewrite mag_unique with beta (F2R xu) ex.
rewrite mag_unique with (1 := Hd4).
rewrite mag_unique with (1 := Hexa).
intros H.
replace (Fnum xu) with (Fnum xd + 1)%Z.
rewrite Z.even_add.
now apply eqb_sym.
apply sym_eq.
apply eq_IZR.
rewrite plus_IZR.
apply Rmult_eq_reg_r with (bpow (fexp ex)).
rewrite H.
simpl. ring.
apply Rgt_not_eq.
apply bpow_gt_0.
rewrite Rabs_pos_eq.
split.
apply Rle_trans with (1 := proj1 Hex).
rewrite Hxu.
apply (round_UP_pt beta fexp x).
exact Hu2.
apply Rlt_le.
apply Rlt_le_trans with (1 := H0x).
rewrite Hxu.
apply (round_UP_pt beta fexp x).
Qed.

Theorem DN_UP_parity_generic :
  DN_UP_parity_prop.
Proof.
apply DN_UP_parity_aux.
apply DN_UP_parity_generic_pos.
Qed.

Theorem Rnd_NE_pt_total :
  round_pred_total Rnd_NE_pt.
Proof.
apply satisfies_any_imp_NG.
now apply generic_format_satisfies_any.
intros x d u Hf Hd Hu.
generalize (proj1 Hd).
unfold generic_format.
set (ed := cexp beta fexp d).
set (md := Ztrunc (scaled_mantissa beta fexp d)).
intros Hd1.
case_eq (Z.even md) ; [ intros He | intros Ho ].
right.
exists (Float beta md ed).
unfold Generic_fmt.canonical.
rewrite <- Hd1.
now repeat split.
left.
generalize (proj1 Hu).
unfold generic_format.
set (eu := cexp beta fexp u).
set (mu := Ztrunc (scaled_mantissa beta fexp u)).
intros Hu1.
rewrite Hu1.
eexists ; repeat split.
unfold Generic_fmt.canonical.
now rewrite <- Hu1.
rewrite (DN_UP_parity_generic x (Float beta md ed) (Float beta mu eu)).
simpl.
now rewrite Ho.
exact Hf.
unfold Generic_fmt.canonical.
now rewrite <- Hd1.
unfold Generic_fmt.canonical.
now rewrite <- Hu1.
rewrite <- Hd1.
apply Rnd_DN_pt_unique with (1 := Hd).
now apply round_DN_pt.
rewrite <- Hu1.
apply Rnd_UP_pt_unique with (1 := Hu).
now apply round_UP_pt.
Qed.

Theorem Rnd_NE_pt_monotone :
  round_pred_monotone Rnd_NE_pt.
Proof.
apply Rnd_NG_pt_monotone.
intros x d u Hd Hdn Hu Hun (cd, (Hd1, Hd2)) (cu, (Hu1, Hu2)).
destruct (Req_dec x d) as [Hx|Hx].
rewrite <- Hx.
apply sym_eq.
apply Rnd_UP_pt_idempotent with (1 := Hu).
rewrite Hx.
apply Hd.
rewrite (DN_UP_parity_aux DN_UP_parity_generic_pos x cd cu) in Hu2 ; try easy.
now rewrite (proj2 Hd2) in Hu2.
intros Hf.
apply Hx.
apply sym_eq.
now apply Rnd_DN_pt_idempotent with (1 := Hd).
rewrite <- Hd1.
apply Rnd_DN_pt_unique with (1 := Hd).
now apply round_DN_pt.
rewrite <- Hu1.
apply Rnd_UP_pt_unique with (1 := Hu).
now apply round_UP_pt.
Qed.

Theorem Rnd_NE_pt_round :
  round_pred Rnd_NE_pt.
Proof.
split.
apply Rnd_NE_pt_total.
apply Rnd_NE_pt_monotone.
Qed.

Lemma round_NE_pt_pos :
  forall x,
  (0 < x)%R ->
  Rnd_NE_pt x (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances.
intros x Hx.
split.
now apply round_N_pt.
unfold NE_prop.
set (mx := scaled_mantissa beta fexp x).
set (xr := round beta fexp ZnearestE x).
destruct (Req_dec (mx - IZR (Zfloor mx)) (/2)) as [Hm|Hm].
(* midpoint *)
left.
exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (cexp beta fexp xr)).
split.
apply round_N_pt...
split.
unfold Generic_fmt.canonical. simpl.
apply f_equal.
apply round_N_pt...
simpl.
unfold xr, round, Znearest.
fold mx.
rewrite Hm.
rewrite Rcompare_Eq. 2: apply refl_equal.
case_eq (Z.even (Zfloor mx)) ; intros Hmx.
(* . even floor *)
change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zfloor x))) = true).
destruct (Rle_or_lt (round beta fexp Zfloor x) 0) as [Hr|Hr].
rewrite (Rle_antisym _ _ Hr).
unfold scaled_mantissa.
rewrite Rmult_0_l.
now rewrite Ztrunc_IZR.
rewrite <- (round_0 beta fexp Zfloor).
apply round_le...
now apply Rlt_le.
rewrite scaled_mantissa_DN...
now rewrite Ztrunc_IZR.
(* . odd floor *)
change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zceil x))) = true).
destruct (mag beta x) as (ex, Hex).
specialize (Hex (Rgt_not_eq _ _ Hx)).
rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hx)) in Hex.
destruct (Z_lt_le_dec (fexp ex) ex) as [He|He].
(* .. large pos *)
assert (Hu := round_bounded_large_pos _ _ Zceil _ _ He Hex).
assert (Hfc: Zceil mx = (Zfloor mx + 1)%Z).
apply Zceil_floor_neq.
intros H.
rewrite H in Hm.
unfold Rminus in Hm.
rewrite Rplus_opp_r in Hm.
elim (Rlt_irrefl 0).
rewrite Hm at 2.
apply Rinv_0_lt_compat.
now apply IZR_lt.
destruct (proj2 Hu) as [Hu'|Hu'].
(* ... u <> bpow *)
unfold scaled_mantissa.
rewrite cexp_fexp_pos with (1 := conj (proj1 Hu) Hu').
unfold round, F2R. simpl.
rewrite cexp_fexp_pos with (1 := Hex).
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
rewrite Ztrunc_IZR.
fold mx.
rewrite Hfc.
now rewrite Z.even_add, Hmx.
(* ... u = bpow *)
rewrite Hu'.
unfold scaled_mantissa, cexp.
rewrite mag_bpow.
rewrite <- bpow_plus, <- IZR_Zpower.
rewrite Ztrunc_IZR.
case_eq (Z.even beta) ; intros Hr.
destruct exists_NE_ as [Hs|Hs].
now rewrite Hs in Hr.
destruct (Hs ex) as (H,_).
rewrite Z.even_pow.
exact Hr.
lia.
assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx.
replace (Zfloor mx) with (Zceil mx + -1)%Z by lia.
rewrite Z.even_add.
apply eqb_true.
unfold mx.
replace (Zceil (scaled_mantissa beta fexp x)) with (Zpower beta (ex - fexp ex)).
rewrite Zeven_Zpower_odd with (2 := Hr).
easy.
lia.
apply eq_IZR.
rewrite IZR_Zpower by lia.
apply Rmult_eq_reg_r with (bpow (fexp ex)).
unfold Zminus.
rewrite bpow_plus.
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l, Rmult_1_r.
pattern (fexp ex) ; rewrite <- cexp_fexp_pos with (1 := Hex).
now apply sym_eq.
apply Rgt_not_eq.
apply bpow_gt_0.
generalize (proj1 (valid_exp ex) He).
lia.
(* .. small pos *)
assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx.
unfold mx, scaled_mantissa.
rewrite cexp_fexp_pos with (1 := Hex).
now rewrite mantissa_DN_small_pos.
(* not midpoint *)
right.
intros g Hg.
destruct (Req_dec x g) as [Hxg|Hxg].
rewrite <- Hxg.
apply sym_eq.
apply round_generic...
rewrite Hxg.
apply Hg.
set (d := round beta fexp Zfloor x).
set (u := round beta fexp Zceil x).
apply Rnd_N_pt_unique with (d := d) (u := u) (4 := Hg).
now apply round_DN_pt.
now apply round_UP_pt.
2: now apply round_N_pt.
rewrite <- (scaled_mantissa_mult_bpow beta fexp x).
unfold d, u, round, F2R. simpl. fold mx.
rewrite <- 2!Rmult_minus_distr_r.
intros H.
apply Rmult_eq_reg_r in H.
apply Hm.
apply Rcompare_Eq_inv.
rewrite Rcompare_floor_ceil_middle.
now apply Rcompare_Eq.
contradict Hxg.
apply sym_eq.
apply Rnd_N_pt_idempotent with (1 := Hg).
rewrite <- (scaled_mantissa_mult_bpow beta fexp x).
fold mx.
rewrite <- Hxg.
change (IZR (Zfloor mx) * bpow (cexp beta fexp x))%R with d.
now eapply round_DN_pt.
apply Rgt_not_eq.
apply bpow_gt_0.
Qed.

Theorem round_NE_opp :
  forall x,
  round beta fexp ZnearestE (-x) = (- round beta fexp ZnearestE x)%R.
Proof.
intros x.
unfold round. simpl.
rewrite scaled_mantissa_opp, cexp_opp.
rewrite Znearest_opp.
rewrite <- F2R_Zopp.
apply (f_equal (fun v => F2R (Float beta (-v) _))).
set (m := scaled_mantissa beta fexp x).
unfold Znearest.
case Rcompare ; trivial.
apply (f_equal (fun (b : bool) => if b then Zceil m else Zfloor m)).
rewrite Bool.negb_involutive.
rewrite Z.even_opp.
rewrite Z.even_add.
now rewrite eqb_sym.
Qed.

Lemma round_NE_abs:
  forall x : R,
  round beta fexp ZnearestE (Rabs x) = Rabs (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances.
intros x.
apply sym_eq.
unfold Rabs at 2.
destruct (Rcase_abs x) as [Hx|Hx].
rewrite round_NE_opp.
apply Rabs_left1.
rewrite <- (round_0 beta fexp ZnearestE).
apply round_le...
now apply Rlt_le.
apply Rabs_pos_eq.
rewrite <- (round_0 beta fexp ZnearestE).
apply round_le...
now apply Rge_le.
Qed.

Theorem round_NE_pt :
  forall x,
  Rnd_NE_pt x (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances.
intros x.
destruct (total_order_T x 0) as [[Hx|Hx]|Hx].
apply Rnd_NG_pt_opp_inv.
apply generic_format_opp.
unfold NE_prop.
intros _ f ((mg,eg),(H1,(H2,H3))).
exists (Float beta (- mg) eg).
repeat split.
rewrite H1.
now rewrite F2R_Zopp.
now apply canonical_opp.
simpl.
now rewrite Z.even_opp.
rewrite <- round_NE_opp.
apply round_NE_pt_pos.
now apply Ropp_0_gt_lt_contravar.
rewrite Hx, round_0...
apply Rnd_NG_pt_refl.
apply generic_format_0.
now apply round_NE_pt_pos.
Qed.

End Fcore_rnd_NE.

(** Notations for backward-compatibility with Flocq 1.4. *)
Notation rndNE := ZnearestE (only parsing).


Require Import Stlc.SpecEvaluation.
Require Import Stlc.SpecSyntax.
Require Import Stlc.StlcOmega.
Require Import Stlc.SpecTyping.
Require Import Stlc.LemmasTyping.
Require Import Stlc.LemmasEvaluation.
Require Import Stlc.CanForm.
Require Import Common.Relations.

Fixpoint UVal (n : nat) : Ty :=
  match n with
    | 0 => tunit
    | S n => tunit ⊎ tunit ⊎ tbool ⊎ (UVal n × UVal n) ⊎ (UVal n ⇒ UVal n) ⊎ (UVal n ⊎ UVal n)
  end.

Fixpoint unkUVal (n : nat) : Tm :=
  match n with
    | 0 => unit
    | S n => inl unit
  end.

Lemma unkUVal_Value {n : nat} : Value (unkUVal n).
Proof.
  destruct n; simpl; trivial.
Qed.

Lemma unkUValT {Γ n} : ⟪ Γ ⊢ unkUVal n : UVal n ⟫.
Proof.
  induction n; eauto using Typing.
Qed.

Definition inUnit_pctx (n : nat) := pinr (pinl phole).
Definition inUnit (n : nat) (t : Tm) := pctx_app t (inUnit_pctx n).
Arguments inUnit_pctx / n.

Lemma inUnit_Value {n v} : Value v → Value (inUnit n v).
Proof.
  simpl; trivial.
Qed.

Lemma inUnit_pctx_T {Γ n} : ⟪ ⊢ inUnit_pctx n : Γ , tunit → Γ , UVal (S n) ⟫.
Proof.
  unfold inUnit_pctx. crushTyping.
Qed.

Lemma inUnitT {Γ n t} : ⟪ Γ ⊢ t : tunit ⟫ → ⟪ Γ ⊢ inUnit n t : UVal (S n) ⟫.
Proof.
  unfold inUnit. eauto using inUnit_pctx_T with typing.
Qed.

Arguments inUnit n t : simpl never.

Definition inBool_pctx (n : nat) : PCtx := pinr (pinr (pinl phole)).
Definition inBool (n : nat) (t : Tm): Tm := pctx_app t (inBool_pctx n).

Arguments inBool_pctx /n.

Lemma inBool_pctx_T {Γ n} : ⟪ ⊢ inBool_pctx n : Γ , tbool → Γ , UVal (S n) ⟫.
Proof.
  unfold inBool_pctx. crushTyping.
Qed.

Lemma inBoolT {Γ n t} : ⟪ Γ ⊢ t : tbool ⟫ → ⟪ Γ ⊢ inBool n t : UVal (S n) ⟫.
Proof.
  unfold inBool. eauto using inBool_pctx_T with typing.
Qed.

Lemma inBool_Value {n v} : Value v → Value (inBool n v).
Proof.
  simpl; trivial.
Qed.

Definition inProd_pctx (n : nat) : PCtx := pinr (pinr (pinr (pinl phole))).
Definition inProd (n : nat) (t : Tm) : Tm := pctx_app t (inProd_pctx n).

Lemma inProd_pctx_T {Γ n} : ⟪ ⊢ inProd_pctx n : Γ , UVal n × UVal n → Γ , UVal (S n) ⟫.
Proof.
  unfold inProd_pctx. crushTyping.
Qed.

Lemma inProd_T {Γ n t} : ⟪ Γ ⊢ t : UVal n × UVal n ⟫ → ⟪ Γ ⊢ inProd n t : UVal (S n) ⟫.
Proof.
  unfold inProd. eauto using inProd_pctx_T with typing.
Qed.

Lemma inProd_Value {n v} : Value v → Value (inProd n v).
Proof.
  simpl; trivial.
Qed.

Definition inArr_pctx (n : nat) : PCtx := pinr (pinr (pinr (pinr (pinl phole)))).
Definition inArr (n : nat) (t : Tm) : Tm := pctx_app t (inArr_pctx n).

Arguments inArr_pctx / n.

Lemma inArr_pctx_T {Γ n} : ⟪ ⊢ inArr_pctx n : Γ , UVal n ⇒ UVal n → Γ , UVal (S n) ⟫.
Proof.
  unfold inArr_pctx. crushTyping.
Qed.

Lemma inArr_T {Γ n t} : ⟪ Γ ⊢ t : UVal n ⇒ UVal n ⟫ → ⟪ Γ ⊢ inArr n t : UVal (S n) ⟫.
Proof.
  unfold inArr. eauto using inArr_pctx_T with typing.
Qed.

Lemma inArr_Value {n v} : Value v → Value (inArr n v).
Proof.
  simpl; trivial.
Qed.

Definition inSum_pctx (n : nat) : PCtx := pinr (pinr (pinr (pinr (pinr phole)))).
Definition inSum (n : nat) (t : Tm) : Tm := pctx_app t (inSum_pctx n).

Lemma inSum_pctx_T {Γ n} : ⟪ ⊢ inSum_pctx n : Γ , UVal n ⊎ UVal n → Γ , UVal (S n) ⟫.
Proof.
  unfold inSum_pctx. crushTyping.
Qed.

Lemma inSum_T {Γ n t} : ⟪ Γ ⊢ t : UVal n ⊎ UVal n ⟫ → ⟪ Γ ⊢ inSum n t : UVal (S n) ⟫.
Proof.
  unfold inSum. eauto using inSum_pctx_T with typing.
Qed.

Lemma inSum_Value {n v} : Value v → Value (inSum n v).
Proof.
  simpl; trivial.
Qed.

Definition caseV0 (case₁ : Tm) (case₂ : Tm) :=
  caseof (var 0) (case₁ [wkm↑]) (case₂[wkm↑]).

Lemma caseV0_T {Γ τ₁ τ₂ τ case₁ case₂} :
  ⟪ Γ ▻ τ₁ ⊢ case₁ : τ ⟫ →
  ⟪ Γ ▻ τ₂ ⊢ case₂ : τ ⟫ →
  ⟪ Γ ▻ (τ₁ ⊎ τ₂) ⊢ caseV0 case₁ case₂ : τ ⟫.
Proof.
  unfold caseV0.
  crushTyping.
Qed.

Hint Resolve caseV0_T : uval_typing.

Definition caseUVal_pctx (tunk tcunit tcbool tcprod tcsum tcarr : Tm) : PCtx :=
  pcaseof₁ phole
         (tunk [wkm])
         (caseV0 tcunit
                 (caseV0 tcbool
                         (caseV0 tcprod
                                 (caseV0 tcarr tcsum)))).
Definition caseUVal (tscrut tunk tcunit tcbool tcprod tcsum tcarr : Tm) :=
  pctx_app tscrut (caseUVal_pctx tunk tcunit tcbool tcprod tcsum tcarr).

Arguments caseUVal tscrut tunk tcunit tcbool tcprod tcsum tcarr : simpl never.

Lemma caseUVal_pctx_T {Γ n tunk tcunit tcbool tcprod tcsum tcarr τ} :
  ⟪ Γ ⊢ tunk : τ ⟫ →
  ⟪ Γ ▻ tunit ⊢ tcunit : τ ⟫ →
  ⟪ Γ ▻ tbool ⊢ tcbool : τ ⟫ →
  ⟪ Γ ▻ (UVal n × UVal n) ⊢ tcprod : τ ⟫ →
  ⟪ Γ ▻ (UVal n ⊎ UVal n) ⊢ tcsum : τ ⟫ →
  ⟪ Γ ▻ (UVal n ⇒ UVal n) ⊢ tcarr : τ ⟫ →
  ⟪ ⊢ caseUVal_pctx tunk tcunit tcbool tcprod tcsum tcarr : Γ , UVal (S n) → Γ , τ ⟫.
Proof.
  unfold caseUVal_pctx.
  crushTyping.
  eauto with typing uval_typing.
Qed.

Lemma caseUVal_T {Γ n tscrut tunk tcunit tcbool tcprod tcsum tcarr τ} :
  ⟪ Γ ⊢ tscrut : UVal (S n) ⟫ →
  ⟪ Γ ⊢ tunk : τ ⟫ →
  ⟪ Γ ▻ tunit ⊢ tcunit : τ ⟫ →
  ⟪ Γ ▻ tbool ⊢ tcbool : τ ⟫ →
  ⟪ Γ ▻ (UVal n × UVal n) ⊢ tcprod : τ ⟫ →
  ⟪ Γ ▻ (UVal n ⊎ UVal n) ⊢ tcsum : τ ⟫ →
  ⟪ Γ ▻ (UVal n ⇒ UVal n) ⊢ tcarr : τ ⟫ →
  ⟪ Γ ⊢ caseUVal tscrut tunk tcunit tcbool tcprod tcsum tcarr : τ ⟫.
Proof.
  unfold caseUVal.
  eauto using caseUVal_pctx_T with typing.
Qed.

Arguments UVal n : simpl never.
Hint Resolve unkUValT : uval_typing.
Hint Resolve inUnitT : uval_typing.
Hint Resolve inBoolT : uval_typing.
Hint Resolve inProd_T : uval_typing.
Hint Resolve inSum_T : uval_typing.
Hint Resolve inArr_T : uval_typing.
Hint Resolve inUnit_pctx_T : uval_typing.
Hint Resolve inBool_pctx_T : uval_typing.
Hint Resolve inProd_pctx_T : uval_typing.
Hint Resolve inSum_pctx_T : uval_typing.
Hint Resolve inArr_pctx_T : uval_typing.
Hint Resolve caseUVal_pctx_T : uval_typing.
Hint Resolve caseUVal_T : uval_typing.

Local Ltac crush :=
  repeat (subst*;
          repeat rewrite
          (*   ?protect_wkm_beta1, ?protect_wkm2_beta1, *)
          (*   ?confine_wkm_beta1, ?confine_wkm2_beta1, *)
           ?apply_wkm_beta1_up_cancel;
          (*   ?apply_up_def_S; *)
          repeat crushDbLemmasMatchH;
          repeat crushDbSyntaxMatchH;
          repeat crushStlcSyntaxMatchH;
          repeat crushTypingMatchH2;
          repeat crushTypingMatchH;
          repeat match goal with
                     [ |- _ ∧ _ ] => split
                 end;
          trivial;
          eauto with ws typing uval_typing eval
         ).

Lemma caseV0_eval_inl {v case₁ case₂}:
  Value v →
  (caseV0 case₁ case₂)[beta1 (inl v)] --> case₁ [beta1 v].
Proof.
  intros vv.
  unfold caseV0; apply eval₀_to_eval; crush.
  change ((caseof (var 0) case₁[wkm↑] case₂ [wkm↑])[beta1 (inl v)]) with
  (caseof (inl v) (case₁[wkm↑][(beta1 (inl v))↑]) (case₂[wkm↑][(beta1 (inl v))↑])).
  crush.
Qed.

Lemma caseV0_eval_inr {v case₁ case₂}:
  Value v →
  (caseV0 case₁ case₂)[beta1 (inr v)] --> case₂ [beta1 v].
Proof.
  intros vv.
  unfold caseV0; apply eval₀_to_eval; crush.
  change ((caseof (var 0) case₁[wkm↑] case₂ [wkm↑])[beta1 (inr v)]) with
  (caseof (inr v) (case₁[wkm↑][(beta1 (inr v))↑]) (case₂[wkm↑][(beta1 (inr v))↑])).
  crush.
Qed.

Lemma caseV0_eval {v τ₁ τ₂ case₁ case₂}:
  Value v → ⟪ empty ⊢ v : τ₁ ⊎ τ₂ ⟫ →
  (exists v', v = inl v' ∧ (caseV0 case₁ case₂)[beta1 v] --> case₁ [beta1 v']) ∨
  (exists v', v = inr v' ∧ (caseV0 case₁ case₂)[beta1 v] --> case₂ [beta1 v']).
Proof.
  intros vv ty.
  stlcCanForm; [left|right]; exists x;
  crush; eauto using caseV0_eval_inl, caseV0_eval_inr.
Qed.

Local Ltac crushEvalsInCaseUVal :=
  repeat
    (match goal with
         [ |- caseof (inl _) _ _ -->* _ ] => (eapply (evalStepStar _); [eapply eval₀_to_eval; crush|])
       | [ |- caseof (inr _) _ _ -->* _ ] => (eapply (evalStepStar _); [eapply eval₀_to_eval; crush|])
       | [ |- (caseV0 _ _) [beta1 (inl _)] -->* _ ] => (eapply (evalStepStar _); [eapply caseV0_eval_inl; crush|])
       | [ |- (caseV0 _ _) [beta1 (inr _)] -->* _ ] => (eapply (evalStepStar _); [eapply caseV0_eval_inr; crush|])
       | [ |- ?t -->* ?t ] => eauto with eval
     end;
     try rewrite -> apply_wkm_beta1_cancel
    ).

Lemma canonUValS {n v} :
  ⟪ empty ⊢ v : UVal (S n) ⟫ → Value v →
  (v = unkUVal (S n)) ∨
  (∃ v', v = inUnit n v' ∧ Value v' ∧ ⟪ empty ⊢ v' : tunit ⟫) ∨
  (∃ v', v = inBool n v' ∧ Value v' ∧ ⟪ empty ⊢ v' : tbool ⟫) ∨
  (∃ v', v = inProd n v' ∧ Value v' ∧ ⟪ empty ⊢ v' : UVal n × UVal n ⟫) ∨
  (∃ v', v = inSum n v' ∧ Value v' ∧ ⟪ empty ⊢ v' : UVal n ⊎ UVal n ⟫) ∨
  (∃ v', v = inArr n v' ∧ Value v' ∧ ⟪ empty ⊢ v' : UVal n ⇒ UVal n ⟫).
Proof.
  intros ty vv.
  unfold UVal in ty; simpl.
  (* Apply canonical form lemmas but only as far as we need. *)
  stlcCanForm1;
    [left|right;stlcCanForm1;
       [left|right;stlcCanForm1;
          [left|right;stlcCanForm1;
                [left|right;stlcCanForm1;
                      [right|left]]]]].
  - stlcCanForm; crush.
  - exists x0; crush.
  - exists x; crush.
  - exists x0; crush.
  - exists x; crush.
  - exists x; crush.
Qed.

Lemma canonUVal {n v} :
  ⟪ empty ⊢ v : UVal n ⟫ → Value v →
  (v = unkUVal n) ∨
  ∃ n', n = S n' ∧
        ((∃ v', v = inUnit n' v' ∧ Value v' ∧ ⟪ empty ⊢ v' : tunit ⟫) ∨
         (∃ v', v = inBool n' v' ∧ Value v' ∧ ⟪ empty ⊢ v' : tbool ⟫) ∨
         (∃ v', v = inProd n' v' ∧ Value v' ∧ ⟪ empty ⊢ v' : UVal n' × UVal n' ⟫) ∨
         (∃ v', v = inSum n' v' ∧ Value v' ∧ ⟪ empty ⊢ v' : UVal n' ⊎ UVal n' ⟫) ∨
         (∃ v', v = inArr n' v' ∧ Value v' ∧ ⟪ empty ⊢ v' : UVal n' ⇒ UVal n' ⟫)).
Proof.
  intros ty vv.
  destruct n.
  - left. unfold UVal, unkUVal in *. stlcCanForm. trivial.
  - destruct (canonUValS ty vv) as [? | ?].
    + left; crush.
    + right; crush.
Qed.

Ltac canonUVal :=
  match goal with
      [ H : Value ?v, H' : ⟪ empty ⊢ ?v : UVal 0 ⟫ |- _ ] =>
      (unfold UVal in H'; stlcCanForm; subst)
    | [ H : Value ?v, H' : ⟪ empty ⊢ ?v : UVal (S _) ⟫ |- _ ] =>
      (destruct (canonUValS H' H) as
          [?| [(? & ? & ? & ?)
              |[(? & ? & ? & ?)
               |[(? & ? & ? & ?)
                |[(? & ? & ? & ?)
                 |(? & ? & ? & ?)]]]]]; subst)
    | [ H : Value ?v, H' : ⟪ empty ⊢ ?v : UVal (S _ + _) ⟫ |- _ ] =>
      (destruct (canonUValS H' H) as
          [?| [(? & ? & ? & ?)
              |[(? & ? & ? & ?)
               |[(? & ? & ? & ?)
                |[(? & ? & ? & ?)
                 |(? & ? & ? & ?)]]]]]; subst)
    | [ H : Value ?v, H' : ⟪ empty ⊢ ?v : UVal _ ⟫ |- _ ] =>
      (destruct (canonUVal H' H) as
          [?| (? & ? & [(? & ? & ? & ?)
                       |[(? & ? & ? & ?)
                        |[(? & ? & ? & ?)
                         |[(? & ? & ? & ?)
                          |(? & ? & ? & ?)]]]])]; subst)
  end.

Lemma caseUVal_eval_unk {n tunk tcunit tcbool tcprod tcsum tcarr} :
  caseUVal (unkUVal (S n)) tunk tcunit tcbool tcprod tcsum tcarr -->* tunk.
Proof.
  unfold caseUVal, unkUVal; simpl.
  (* why doesn't crush do the following? *)
  assert (Value (inl unit)) by (simpl; trivial).
  crushEvalsInCaseUVal.
Qed.

Lemma caseUVal_eval_unit {n tunk tcunit tcbool tcprod tcsum tcarr v} :
  Value v →
  caseUVal (inUnit n v) tunk tcunit tcbool tcprod tcsum tcarr -->* tcunit [beta1 v].
Proof.
  intros vv.
  unfold caseUVal, inUnit; simpl.
  crushEvalsInCaseUVal.
Qed.

Lemma caseUVal_eval_bool {n tunk tcunit tcbool tcprod tcsum tcarr v} :
  Value v →
  caseUVal (inBool n v) tunk tcunit tcbool tcprod tcsum tcarr -->* tcbool [beta1 v].
Proof.
  intros vv.
  unfold caseUVal, inBool; simpl.
  crushEvalsInCaseUVal.
Qed.

Lemma caseUVal_eval_prod {n tunk tcunit tcbool tcprod tcsum tcarr v} :
  Value v →
  caseUVal (inProd n v) tunk tcunit tcbool tcprod tcsum tcarr -->* tcprod [beta1 v].
Proof.
  intros vv.
  unfold caseUVal, inProd; simpl.
  crushEvalsInCaseUVal.
Qed.

Lemma caseUVal_eval_sum {n tunk tcunit tcbool tcprod tcsum tcarr v} :
  Value v →
  caseUVal (inSum n v) tunk tcunit tcbool tcprod tcsum tcarr -->* tcsum [beta1 v].
Proof.
  intros vv.
  unfold caseUVal, inSum; simpl.
  crushEvalsInCaseUVal.
Qed.

Lemma caseUVal_eval_arr {n tunk tcunit tcbool tcprod tcsum tcarr v} :
  Value v →
  caseUVal (inArr n v) tunk tcunit tcbool tcprod tcsum tcarr -->* tcarr [beta1 v].
Proof.
  intros vv.
  unfold caseUVal, inArr; simpl.
  crushEvalsInCaseUVal.
Qed.

Lemma caseUVal_sub {t tunk tcunit tcbool tcprod tcsum tcarr} γ :
  (caseUVal t tunk tcunit tcbool tcprod tcsum tcarr)[γ] =
  caseUVal (t[γ]) (tunk[γ]) (tcunit[γ↑]) (tcbool[γ↑]) (tcprod[γ↑]) (tcsum[γ↑]) (tcarr[γ↑]).
Proof.
  unfold caseUVal, caseUVal_pctx, caseV0. cbn.
  crush;
    rewrite <- ?apply_wkm_comm, <- ?(apply_wkm_up_comm);
    reflexivity.
Qed.

Arguments caseUVal tscrut tunk tcunit tcbool tcprod tcsum tcarr : simpl never.
Arguments caseUVal_pctx tunk tcunit tcbool tcprod tcsum tcarr : simpl never.

Lemma caseUVal_pctx_ECtx {tunk tcunit tcbool tcprod tcsum tcarr} :
  ECtx (caseUVal_pctx tunk tcunit tcbool tcprod tcsum tcarr).
Proof.
  simpl; trivial.
Qed.

(* Definition caseUVal (n : nat) (tscrut tunk tcunit tcbool tcprod tcsum tcarr : Tm) := *)

Definition caseUnit_pctx := caseUVal_pctx (stlcOmega tunit) (var 0) (stlcOmega tunit) (stlcOmega tunit) (stlcOmega tunit) (stlcOmega tunit).
Definition caseBool_pctx := caseUVal_pctx (stlcOmega tbool) (stlcOmega tbool) (var 0) (stlcOmega tbool) (stlcOmega tbool) (stlcOmega tbool).
Definition caseProd_pctx n := caseUVal_pctx (stlcOmega (UVal n × UVal n)) (stlcOmega (UVal n × UVal n)) (stlcOmega (UVal n × UVal n)) (var 0) (stlcOmega (UVal n × UVal n)) (stlcOmega (UVal n × UVal n)).
Definition caseSum_pctx n := caseUVal_pctx (stlcOmega (UVal n ⊎ UVal n)) (stlcOmega (UVal n ⊎ UVal n)) (stlcOmega (UVal n ⊎ UVal n)) (stlcOmega (UVal n ⊎ UVal n)) (var 0) (stlcOmega (UVal n ⊎ UVal n)).
Definition caseArr_pctx n := caseUVal_pctx (stlcOmega (UVal n ⇒ UVal n)) (stlcOmega (UVal n ⇒ UVal n)) (stlcOmega (UVal n ⇒ UVal n)) (stlcOmega (UVal n ⇒ UVal n)) (stlcOmega (UVal n ⇒ UVal n)) (var 0).
Definition caseUnit t := pctx_app t caseUnit_pctx.
Definition caseBool t := pctx_app t caseBool_pctx.
Definition caseProd n t := pctx_app t (caseProd_pctx n).
Definition caseSum n t := pctx_app t (caseSum_pctx n).
Definition caseArr n t := pctx_app t (caseArr_pctx n).

Lemma caseUnit_pctx_ECtx : ECtx caseUnit_pctx.
Proof.
  simpl; trivial.
Qed.

Lemma caseBool_pctx_ECtx : ECtx caseBool_pctx.
Proof.
  simpl; trivial.
Qed.

Lemma caseProd_pctx_ECtx {n}: ECtx (caseProd_pctx n).
Proof.
  simpl; trivial.
Qed.

Lemma caseSum_pctx_ECtx {n}: ECtx (caseSum_pctx n).
Proof.
  simpl; trivial.
Qed.

Lemma caseArr_pctx_ECtx {n}: ECtx (caseArr_pctx n).
Proof.
  simpl; trivial.
Qed.

Lemma caseUnit_sub {t γ} :
  (caseUnit t) [γ] = caseUnit (t [γ]).
Proof.
  unfold caseUnit; crush.
Qed.

Lemma caseBool_sub {t γ} :
  caseBool t [γ] = caseBool (t [γ]).
Proof.
  unfold caseBool; crush.
Qed.

Lemma caseProd_sub {n t γ} :
  caseProd n t [γ] = caseProd n (t [γ]).
Proof.
  unfold caseProd; crush.
Qed.

Lemma caseSum_sub {n t γ} :
  caseSum n t [γ] = caseSum n (t [γ]).
Proof.
  unfold caseSum; crush.
Qed.

Lemma caseArr_sub {n t γ} :
  (caseArr n t) [γ] = caseArr n (t [γ]).
Proof.
  unfold caseArr; crush.
Qed.

(* Arguments caseUnit n t : simpl never. *)
(* Arguments caseBool n t : simpl never. *)
(* Arguments caseProd n t : simpl never. *)
(* Arguments caseSum n t : simpl never. *)
(* Arguments caseArr n t : simpl never. *)

Lemma caseUnit_pctx_T {Γ n} :
  ⟪ ⊢ caseUnit_pctx : Γ , UVal (S n) → Γ , tunit ⟫.
Proof.
  unfold caseUnit_pctx.
  eauto with typing uval_typing.
Qed.

Lemma caseUnit_T {Γ n t} :
  ⟪ Γ ⊢ t : UVal (S n) ⟫ → ⟪ Γ ⊢ caseUnit t : tunit ⟫.
Proof.
  unfold caseUnit.
  eauto using caseUnit_pctx_T with typing.
Qed.

Lemma caseBool_pctx_T {Γ n} :
  ⟪ ⊢ caseBool_pctx : Γ , UVal (S n) → Γ , tbool ⟫.
Proof.
  unfold caseBool_pctx.
  eauto with typing uval_typing.
Qed.

Lemma caseBool_T {Γ n t} :
  ⟪ Γ ⊢ t : UVal (S n) ⟫ → ⟪ Γ ⊢ caseBool t : tbool ⟫.
Proof.
  unfold caseBool.
  eauto using caseBool_pctx_T with typing.
Qed.

Lemma caseProd_pctx_T {Γ n} :
  ⟪ ⊢ caseProd_pctx n : Γ , UVal (S n) → Γ , UVal n × UVal n ⟫.
Proof.
  unfold caseProd_pctx.
  eauto with typing uval_typing.
Qed.

Lemma caseProd_T {Γ n t} :
  ⟪ Γ ⊢ t : UVal (S n) ⟫ → ⟪ Γ ⊢ caseProd n t : UVal n × UVal n ⟫.
Proof.
  unfold caseProd.
  eauto using caseProd_pctx_T with typing.
Qed.

Lemma caseSum_pctx_T {Γ n} :
  ⟪ ⊢ caseSum_pctx n : Γ , UVal (S n) → Γ , UVal n ⊎ UVal n ⟫.
Proof.
  unfold caseSum_pctx.
  eauto with typing uval_typing.
Qed.

Lemma caseSum_T {Γ n t} :
  ⟪ Γ ⊢ t : UVal (S n) ⟫ → ⟪ Γ ⊢ caseSum n t : UVal n ⊎ UVal n ⟫.
Proof.
  unfold caseSum.
  eauto using caseSum_pctx_T with typing.
Qed.

Lemma caseArr_pctx_T {Γ n} :
  ⟪ ⊢ caseArr_pctx n : Γ , UVal (S n) → Γ , UVal n ⇒ UVal n ⟫.
Proof.
  unfold caseArr_pctx.
  eauto with typing uval_typing.
Qed.

Lemma caseArr_T {Γ n t} :
  ⟪ Γ ⊢ t : UVal (S n) ⟫ → ⟪ Γ ⊢ caseArr n t : UVal n ⇒ UVal n ⟫.
Proof.
  unfold caseArr.
  eauto using caseArr_pctx_T with typing.
Qed.

Hint Resolve caseUnit_T : uval_typing.
Hint Resolve caseBool_T : uval_typing.
Hint Resolve caseProd_T : uval_typing.
Hint Resolve caseSum_T : uval_typing.
Hint Resolve caseArr_T : uval_typing.


Require Export CatSem.CAT.cat_INDEXED_TYPE.
Require Export CatSem.TLC.TLC_types.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Notation "V * u" := (opt u V).
Notation "^ f" := (lift (M:= opt_monad _) f) (at level 5).
Notation "a '~>' b" := (TLCarrow a b)
   (at level 69, right associativity).
Notation "'TY'" := TLCtypes.
Notation "'IT'" := (ITYPE TY).

Ltac fin := simpl in *; intros;
   autorewrite with fin; auto with fin.
Ltac opt := simpl; intros; elim_opt; fin.

Hint Unfold lift : fin.
Hint Extern 1 (_ = _) => f_equal : fin.

Lemma l_eq (V W : TY -> Type) (f g : forall t, V t -> W t) r:
   (forall t v, f t v = g t v) ->
       (forall t (v : opt r V t),
       lift (M:=opt_monad r) f t v = ^g t v).
Proof.
  intros;
  elim_opt;
  unfold lift;
  simpl;
  repeat rew_hyp_2;
  auto.
Qed.

Inductive TLC (V : ITYPE TY) : ITYPE TY :=
  | var : forall t, V t -> TLC V t
  | abs : forall r s, TLC (V * r) s -> TLC V (r ~> s)
  | app : forall r s, TLC V (r ~> s) -> TLC V r -> TLC V s.

Fixpoint _rename V W (f : V ---> W) t (y : TLC V t) : TLC W t :=
  match y with
  | var _ v => var (f _ v)
  | abs _ _  v => abs (_rename ^f v)
  | app _ _  s t => app (_rename f s) (_rename f t)
  end.

Definition _inj u V := _rename (V:=V) (W:=V * u)
                (@some TY u V).

Hint Unfold _inj : fin.

Definition _shift (u : TY) (V W : IT) (f : V ---> TLC W) :
         V * u ---> TLC (W * u) :=
   fun t v =>
   match v in (opt _ _ y) return (TLC (W * u) y) with
   | some t0 p => _inj u (f t0 p)
   | none => var (none u W)
   end.

Fixpoint _subst (V W : IT) (f : V ---> TLC W) t (y : TLC V t) : TLC W t :=
  match y with
  | var _ v => f _ v
  | abs _ _ v => abs (_subst (_shift f) v)
  | app _ _ s t => app (_subst f s) (_subst f t)
  end.

Definition _substar (u : TY) (V : IT) (M : TLC V u) :
           TLC (V * u) ---> TLC V :=
 _subst (fun t (y : opt u V t) => match y with
         | none => M
         | some _ v => var v
         end).

Notation "M [*:= N ]" := (_substar N M) (at level 40).

(** Notations for functions *)
Notation "y //- f" := (_rename f y)(at level 42, left associativity).
Notation "y >- f" := (_shift f y) (at level 40).
Notation "y >>= f" := (_subst f y) (at level 59, left associativity).

Hint Extern 1 (_ = _) => apply f_equal.

Lemma rename_eq : forall (V : IT) (t : TY) (v : TLC V t)
         (W : IT) (f g : V ---> W),
     (forall t y, f t y = g t y) -> v //- f = v //- g.
Proof.
  induction v;
  cat;
  try apply f_equal.
  apply IHv.
  simpl; intros.

  intros.
  assert (H':= l_eq (r:=r) H).
  simpl in *.
  auto.

  rewrite (IHv1 _ _ _ H).
  rewrite (IHv2 _ _ _ H).
  auto.
Qed.

Hint Resolve rename_eq l_eq : fin.
Hint Rewrite rename_eq l_eq : fin.

Lemma rename_comp V t (y : TLC V t) W
         (f : V ---> W) Z (g : W ---> Z):
 y //- (fun s y => g s (f s y)) =  y //- f //- g.
Proof.
  intros V t y.
  induction y;
  simpl;
  intros;
  fin.

  apply f_equal.
  rewrite <- IHy.
  apply rename_eq.
  opt.
Qed.

Lemma rename_id_eq V t (y : TLC V t) (f : V ---> V)
        (H : forall t v, f t v = v) :
    y //- f = y.
Proof.
  intros V t y.
  induction y;
  simpl;
  intros;
  fin.
  apply f_equal.
  apply IHy.
  intros t v;
  destruct v;
  fin. unfold lift.
  fin.
Qed.

Lemma rename_id V t (y : TLC V t) : y //- id _ = y .
Proof.
  intros V t y.
  apply rename_id_eq.
  fin.
Qed.

Lemma _shift_eq u V W (f g : V ---> TLC W)
     (H : forall t v, f t v = g t v) t (y : opt u V t) :
          y >- f = y >- g.
Proof.
  opt.
Qed.

Hint Resolve  rename_id _shift_eq : fin.
Hint Rewrite  rename_id _shift_eq : fin.

Lemma shift_var u (V : IT) t (y : opt u V t) :
       y >- @var _ = var y.
Proof.
  opt.
Qed.

Hint Resolve shift_var : fin.
Hint Rewrite shift_var : fin.

Lemma var_lift_shift (u : TY) V W (f : V ---> W) t (y : opt u V t) :
     var (^f _ y) = y >- (f ;; @var _ ).
Proof.
  opt.
Qed.

Hint Resolve var_lift_shift : fin.

Lemma shift_lift u V W Z (f : V ---> W)
         (g : W ---> TLC Z) t (y : opt u V t) :
      (^f _ y) >- g = y >- (f ;; g).
Proof.
  opt.
Qed.

Hint Resolve shift_lift : fin.
Hint Rewrite shift_lift : fin.

Lemma subst_eq V t (y : TLC V t)
      W (f g : V ---> TLC W)
       (H : forall t y, f t y = g t y):  y >>= f = y >>= g.
Proof.
  intros V t y.
  induction y;
  fin.
Qed.

Hint Resolve subst_eq : fin.
Hint Rewrite subst_eq : fin.

Obligation Tactic := unfold Proper; red; fin.

Program Instance subst_oid V W :
 Proper (equiv ==> equiv (Setoid:=mor_oid (TLC V) (TLC W)))
                (@_subst V W).

Lemma subst_var (V : IT) :
    forall t (v : TLC V t), v >>= (@var V) = v .
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite <- IHy at 2.
  apply subst_eq.
  fin.
Qed.

Lemma subst_eq_rename V t (v : TLC V t) W (f : V ---> W)  :
     v //- f  = v >>= f ;; var (V:=W).
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite IHy.
  apply subst_eq.
  opt.
Qed.

Lemma rename_shift a V W Z (f : V ---> TLC W) (g : W ---> Z) t
       (y : opt a V t) :
    (y >- f) //- ^g = y >- (f ;; _rename g).
Proof.
  intros a V W Z f g t y.
  induction y;
  fin.
  unfold _inj.
  rewrite <- rename_comp.
  rewrite <- rename_comp.
  fin.
Qed.

Hint Rewrite rename_shift : fin.
Hint Resolve rename_shift : fin.

Hint Unfold _inj : fin.

Lemma rename_subst V t (v : TLC V t) W Z (f : V ---> TLC W)
      (g : W ---> Z) :
      (v >>= f) //- g  = v >>= (f ;; _rename g).
Proof.
  intros V t y.
  induction y;
  fin.
  rewrite IHy.
  apply f_equal.
  apply subst_eq.
  intros t z;
  destruct z;
  simpl; auto.
  unfold _inj.
  rewrite <- rename_comp.
  rewrite <- rename_comp.
  apply rename_eq.
  fin.
Qed.

Lemma subst_rename V t (v : TLC V t) W Z (f : V ---> W)
      (g : W ---> TLC Z) :
      v //- f >>= g = v >>= (f ;; g).
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite IHy.
  apply subst_eq.
  opt.
Qed.

Lemma rename_substar V u t (v : TLC (opt u V) t) W
       (f : V ---> W) N:
     v [*:= N] //- f = (v //- ^f) [*:= N //- f ].
Proof.
  intros.
  unfold _substar.
  rewrite rename_subst.
  rewrite subst_rename.
  apply subst_eq.
  opt.
Qed.

Hint Rewrite subst_rename rename_subst rename_shift : fin.
Hint Resolve rename_shift : fin.

Lemma subst_shift_shift (u:TY) V (t:TY)(v : opt u V t)
         W Z (f: V ---> TLC W) (g: W ---> TLC Z):
    (v >- f) >>= (_shift g)  =
             v >- (f ;; _subst g).
Proof.
  intros u V t v.
  induction v;
  simpl; intros;
  try apply subst_term_inj; auto.
  unfold _inj.
  rewrite subst_rename.
  fin.
Qed.

Hint Resolve subst_shift_shift : fin.
Hint Rewrite subst_shift_shift : fin.

Lemma subst_subst V t (v : TLC V t) W Z (f : V ---> TLC W)
             (g : W ---> TLC Z) :
     v >>= f >>= g = v >>= f;; _subst g.
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite IHy.
  apply subst_eq.
  opt;
  unfold _inj;
  fin.
Qed.

Lemma subst_var_eta (V:TY -> Type)(t:TY)(v:TLC V t):
        v >>= (fun t z => var z) = v.
Proof.
  induction v; intros; simpl; auto.

  rewrite <- IHv at 2.
  apply f_equal. apply subst_eq.
  intros; apply shift_var.
    rewrite IHv1. rewrite IHv2; auto.
Qed.

Lemma subst_substar (V W : IT)
      (s t:TY) (M: TLC (V * s) t) (N:TLC V s)
      (f:forall t, V t -> TLC W t):
   M [*:=N]  >>= f = (M >>= _shift f) [*:= (N >>= f)].
Proof.
  intros V W s t M N f.
  unfold _substar. simpl.
  repeat rewrite subst_subst.
  apply subst_eq.
  opt.
  unfold _shift.
  unfold _inj.
  simpl.
  rewrite subst_rename. simpl.
  rewrite subst_var_eta. auto.
Qed.

Lemma lift_rename V t (s : TLC V t) W (f : V ---> W) :
          s >>= (fun t z => var (f t z)) = s //- f.
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite <- IHy.
  apply subst_eq.
  opt.
Qed.

Hint Resolve subst_var subst_var_eta subst_subst lift_rename : fin.
Hint Rewrite subst_subst lift_rename subst_var subst_var_eta : fin.