Require Import STLCdbjSub.syntax.
Require Import STLCdbjSub.bindings.
Require Import STLCdbjSub.context.
Require Import Cpdt.CpdtTactics.
Require Import STLCdbjSub.dynamic.
Require Import PLF.LibTactics.
Require Import Utf8.
Require Import Coq.Strings.String.

Definition safe (x: Exp0) :=
  forall y, steps x y  -> irreducible y -> val y.

Notation Val0 := (Val Empty_set).

Theorem val_intersect1:
  forall {V} {name} {t t2 : Exp V},
    (val (e_intsctrcd t name t2)) -> val t2.
    intros V name t t2 H. inversion H; eauto.
Qed.

Theorem val_intersect0:
  forall {V} {name} {t t2 : Exp V},
    (val (e_intsctrcd t name t2)) -> val t.
  intros V name t t2 H. inversion H; eauto.
Qed.

Fixpoint lookup0 (name : string) (e : Exp0) {struct e} : option Exp0 :=
  match e  with
  | e_intsctrcd t' name2 t =>
    if (eqb name name2) then Some t else (lookup0 name t')
  | _ => None
  end.

Fixpoint lookup1 {V} (name : string) (e : Exp V) {struct e} : option (Exp V) :=
    match e  with
    | e_intsctrcd t' name2 t =>
      if (eqb name name2) then Some t else (lookup1 name t')
    | _ => None
    end.

Ltac destruct_ALL :=
    repeat
      match goal with
      | [h : _ \/ _ |- _ ] => destruct h; subst; eauto
      | [h : _ /\ _ |- _ ] => destruct h; subst; eauto
      | [h : exists _ , _ |- _ ] => destruct h; subst; eauto
      | [h : Some _ = Some _ |- _] => inversion h; subst; eauto
      | [h : {_} + {_} |- _] => destruct h; subst; eauto
      end.

Theorem lookup0_preserve_val:
  forall {e},
    val e ->
    forall {name t},
    lookup0 name e = Some t ->
    val t.
  intros e h.
  induction h; intros; eauto; try discriminate.
  cbn in *.
  destruct (string_dec name0 name); destruct (eqb name0 name); subst; eauto; try discriminate; try contradiction;
  destruct_ALL; eauto.
Qed.

Theorem lookup1_preserve_val:
  forall {V} {e : Exp V},
    val e ->
    forall {name t},
    lookup1 name e = Some t ->
    val t.
  intros V e h.
  induction h; intros; eauto; try discriminate.
  cbn in *.
  destruct (string_dec name0 name); destruct (eqb name0 name); subst; eauto; try discriminate; try contradiction;
  destruct_ALL; eauto.
Qed.

(* Definition lookup (name : string) (e : Val0)  : option Val0.
  destruct e.

  destruct (lookup0 name x) eqn: Heq.
  + pose (lookup0_preserve_val v Heq).
    pose (exist _ e v0). exact (Some s).
  + exact None.
Defined. *)

(* Print lookup. *)

Definition lookup : string → Val0 → option Val0 :=
  λ (name : string) (e : Val0),
  let (x, v) := e in
  let o := lookup0 name x in
  let Heq : lookup0 name x = o := eq_refl in
  match o as o0 return (lookup0 name x = o0 → option Val0) with
  | Some e0 =>
	  λ Heq0 : lookup0 name x = Some e0,
        let v0 : val e0 := lookup0_preserve_val v Heq0 in
        let s := exist val e0 v0 in Some s
  | None => λ _ : lookup0 name x = None, None
  end Heq.

(* Print lookup. *)

Inductive wfrcd {V:Set} : Exp V -> Prop :=
  | wr_top  : wfrcd e_top
  | wr_cons : forall name t1 t2,
    wfrcd t1 ->
    wfrcd (e_intsctrcd t1 name t2).

(* Do I want commutative here? *)

Hint Constructors wfrcd .

Ltac cleanup_impossible:=
  match goal with
  (* | h0 :  val_has_type _ (v_abs _ _ _) ty_bool |- _ => inversion h0 *)
  | [h : step (e_if  (e_var _) _ _) _ |- _] => inversion h
  | [h : step (e_if  (e_abs _ _) _ _) _ |- _] => inversion h

  end.

Fixpoint wfrcd_dec {V} (x : Exp V):
  {wfrcd x} + {~ wfrcd x}.

  Ltac try_both_side_wfrcd  :=
    try (left; eauto; crush; fail);
    try (right; intros h; destruct_ALL; intros;
      match goal with
      | [h : wfrcd _ |- _ ] => inversion h
      end;
    subst; eauto; try contradiction; try discriminate; try cleanup_impossible; eauto;crush; fail).

  refine (
    match x as e return x = e -> _ with
    | e_intsctrcd t0 name _ => _
    | _ => _
    end eq_refl
  );try_both_side_wfrcd.
  destruct (wfrcd_dec _ t0); try_both_side_wfrcd.
Qed.

Theorem inv_wfrcd0:
  forall {V: Set} {x : Exp V},
    wfrcd x -> ~ x = e_top ->  exists t0 name t1, x = e_intsctrcd t0 name t1 /\ wfrcd t0 .
  intros V x h.
  induction h; intros; eauto; try discriminate; try contradiction.
Qed.

Theorem inv_wfrcd1:
  forall {V: Set} {x : Exp V},
    wfrcd x -> ~ x = e_top ->  {t0 & {name & {t1 | x = e_intsctrcd t0 name t1 /\ wfrcd t0}}} .
  intros V x.
  (* induction x; intros; eauto; try discriminate; try contradiction.
  pose (inv_wfrcd0 H H0).  *)
Abort.

Hint Constructors Exp val step steps.

Definition v_true {V : Set} : Val V.
  refine (exist _ e_true _); eauto.
Defined.

Definition v_false {V: Set} : Val V.
  refine (exist _ e_false _); eauto.
Defined.

Definition v_abs {V: Set} (T : ty) (body : Exp (inc V)) : Val V.
  refine (exist _ (e_abs T body) _); eauto.
Defined.

Definition v_intsctrcd {V: Set} (t0 : Val V) (name : string) (t1 : Val V) : Val V.
  refine(
    let (v0, pf0) := t0 in
    let (v1, pf1) := t1 in
    (exist _ (e_intsctrcd v0 name v1) _)
  ); eauto.
Defined.

Definition E' (T : ty) (x: Exp0) (k : Exp0 -> Prop) : Prop :=
    forall y, steps x y -> irreducible y -> k y.

Fixpoint V (T : ty) (x : Exp0) {struct T}  : Prop :=
  match T with
  | ty_bool => x = e_true \/ x = e_false
  | ty_arrow A B =>  exists body, (x = e_abs A body) /\ forall input (h : val input),  (V A input) -> (E' B (V_subst_exp input body) (V B))
  | ty_top  => val x
  | ty_intsct A B => (V A x) /\ (V B x)
  | ty_rcdt name T2 =>
    exists t0 name2 t1 t2,
      x = e_intsctrcd t0 name2 t1 /\
      val x /\
      wfrcd x /\
      lookup1 name x = Some t2 /\
      V T2 t2
  end.

(* About Context *)
Definition Env (V : Set) := V -> Exp0.

Notation env_append G t := (DV_extend G t).

Inductive good_subst : forall (Vs: Set), Ctx Vs -> Env Vs -> Prop :=
  | gs_empty : forall f g,
    good_subst Empty_set f g
  | gs_extend : forall Vs f g T v (h : val v),
    V T v ->
    good_subst Vs f g ->
    good_subst (inc Vs) (ctx_append f T) (env_append g v).

Arguments good_subst {Vs}.

Notation E T t := (E' T t (V T)).

Definition type_safe_model {Vs : Set} (Γ : Ctx Vs) (e : Exp Vs) (T : ty) : Prop :=
   (forall gs (hh: good_subst Γ gs), E T (V_bind_exp0 gs e)).

Notation "Gamma '⊨' t '∈' T" := (type_safe_model Gamma t T)
(at level 101).

(* We don't have the following *)
(* Lemma val0_as_V:
  forall (x : Exp0),
  val x ->
  exists T y, V T y /\ proj1_sig y = x.
  intros x h.
  Ltac try_Type TK :=
    exists TK; eexists; cbn in *; eauto.
  induction h; intros; eauto;
  try (try_Type ty_bool; fail);

  try (try_Type ty_top; fail). *)

(* We don't have the following either *)
(* Theorem canoncity:
  forall {G : Ctx Empty_set} x T,
  (G ⊨ x  ∈ T) ->
  val x. *)

  Hint Extern 4 =>
  repeat (cbn in *;
    match goal with
      | |- context[type_safe_model _ _ _] => unfold type_safe_model
    end).

Ltac unfoldAll :=
   repeat (cbn in *;
  match goal with
    | |- context[type_safe_model _ _ _] => unfold type_safe_model
    | |- context[E' _ _ _] => unfold E'
    (* | |- context[V ?T _] =>
        let newName := (fresh "HeqV") in
        destruct T eqn: newName;
        subst; cbn in *; intros *)
  end).

Ltac unfoldAll2 :=
    repeat (cbn in *;
   match goal with
     | |- context[type_safe_model _ _ _] => unfold type_safe_model
     | h: context[type_safe_model _ _ _] |- _ => unfold type_safe_model
     | |- context[E' _ _ _] => unfold E'
     | h: context[E' _ _ _] |- _ => unfold E'
     (* | |- context[V ?T _] =>
         let newName := (fresh "HeqV") in
         destruct T eqn: newName;
         subst; cbn in *; intros *)
   end).

Theorem good_subst_in_V:
   forall {Vs} {G : Ctx Vs} {gs : Env Vs},
     good_subst G gs ->
     forall x, V (G x) (gs x).
   intros Vs G gs h.
   induction h; intros; crush.
Qed.

Ltac better_subst :=
    subst;
    repeat match goal with
    | H : _ = _ |- _ => rewrite H in *;  generalize H; clear H; better_subst
    end; intros.

Ltac cleanup_impossible2:=
    match goal with
    (* | h0 :  val_has_type _ (v_abs _ _ _) ty_bool |- _ => inversion h0 *)
    | [h : step (e_if  (e_var _) _ _) _ |- _] => inversion h
    | [h : step (e_if  (e_abs _ _) _ _) _ |- _] => inversion h
    | [h : step (e_var _) _ |- _] => inversion h
    | [h : step (e_abs _ _) _ |- _] => inversion h
    | [h : step e_true _ |- _] => inversion h
    | [h : step e_false _ |- _] => inversion h
    | [h : step e_top _ |- _] => inversion h
    end.
Theorem val_not_steppable:
    forall {V} {v : Exp V},
      val v -> irreducible v.
    intros V v h.
    induction h; intros h3; destruct_ALL; try cleanup_impossible2; eauto.
    inversion H; eauto.
  Qed.

Hint Extern 1  =>
  match goal with
  | [h1 : irreducible ?x, h2 : step ?x _ |- _]
    => destruct (irreducible_non_stepping h2 h1)
  | [h1 : val ?x, h2 : step ?x _ |- _]
    => destruct (irreducible_non_stepping h2 (val_not_steppable h1))

  end
.

Theorem V_as_val:
  forall {T v},
    V T v ->
    val v.
  intros T. induction T; cbn in *; destruct_ALL; intros; eauto; destruct_ALL; eauto.
Qed.

Hint Extern 1  =>
  match goal with
  | [h1 : V _ ?x, h2 : step ?x _ |- _]
    => destruct (irreducible_non_stepping h2 (val_not_steppable (V_as_val h1)))

  end.

Theorem compat_var:
forall {V} {G : Ctx V} x T (H: G x = T),
G ⊨ (e_var x) ∈ T.

unfoldAll2.
intros.
pose (good_subst_in_V hh x).
rewrite H in *; clear H;  eauto.
match goal with
| [h : steps _ _ |- _ ] => inversion h; subst; eauto
end.
Qed.

Definition EmptyContext : Ctx Empty_set.
  unfold Ctx. intros; eauto.
Defined.

Hint Constructors good_subst.

Lemma E_close_under_step:
  forall {x y},
    step x y ->
    forall {T},
    E T x ->
    E T y.
  unfold E.
  intros; eauto.
Qed.

Fixpoint E_close_under_steps {x y}
(h :steps x y) {struct h}:
    forall {T},
    E T x ->
    E T y.
destruct h. eauto.
  intros.
  try eapply (E_close_under_steps);
  try eapply E_close_under_step; eauto.
Qed.

Theorem E_close_under_backstep:
  forall {x y},
    step x y ->
    forall {T},
    E T y ->
    E T x.
  unfold E. intros. eapply H0; eauto.
(* Need step_determinsitic *)
Abort.

(* Hint Extern 1  =>
  match goal with
  | [h1 : step ?x ?y, h2 : step ?x ?z |- _]
    => rewrite (step_determinsitic h1 h2); clear h1

  end
. *)

Lemma close_compat_if:
  forall cond a b T,
    E ty_bool cond ->
    E T a ->
    E T b ->
    E T (e_if cond a b).

  intros.
  unfold E.
  intros.
assert (
  forall x y,
    steps x y ->
    forall cond a b T,
    E ty_bool cond ->
    E T a ->
    E T b ->
    x = e_if cond a b ->
    irreducible y ->
    V T y
); [clear | eauto].
  intros x y h.
  induction h; intros; subst; eauto.
  + destruct (steppable_dec _ cond); subst; destruct_ALL; eauto;
    match goal with
    | [h : irreducible (e_if cond ?a ?b) |- _] =>
      assert (exists n, step (e_if cond a b) n); eauto; try destruct_ALL; try cleanup_impossible2
    end.
    cbn in H; eauto.
    forwards* : H; destruct_ALL; eauto.
  +  destruct (steppable_dec _ cond); subst; destruct_ALL; eauto.
     assert (step (e_if cond a b) (e_if x a b)); eauto.
     rewrite (step_determinsitic H H5) in *; eauto.
     eapply (IHh x a b _ _); eauto.
     cbn in H0; forwards*: H0.
     destruct_ALL; subst;
     match goal with
     | [h : step (e_if _ _ _) _ |- _ ] =>
      inversion h; subst; eauto; try discriminate; try contradiction
     end.
    Unshelve. eapply E_close_under_step; eauto.
Qed.

Theorem compate_if: forall {V} {G : Ctx V} cond a b T,
type_safe_model G cond ty_bool ->
type_safe_model G a T ->
type_safe_model G b T ->
type_safe_model G (e_if cond a b) T.

  unfold type_safe_model.
  intros. cbn.
  eapply close_compat_if; eauto.
Qed.

(* Idea is to see cond[gs |-> values] as Exp0 is either steppable or not
    if not, then
*)

Hint Resolve V_as_val.

Hint Extern 1 =>
  match goal with
  | [h : E ?T ?x, h2 : step ?x ?y |- E ?T ?y] => eapply E_close_under_step; eauto
  end.

Lemma close_compat_app:
  forall a b A B,
    E (ty_arrow A B) a ->
    E A b ->
    E B (e_app a b).

  intros. unfold E.
  intros.
  assert (
    forall x y,
      steps x y ->
    forall a b A B,
    E (ty_arrow A B) a ->
    E A b ->
    x = (e_app a b) ->
    irreducible y ->
    V B y
  ); [clear| eauto].
  intros x y h.
  induction h; intros; subst;eauto.
  + cbn in *. destruct (steppable_dec _ a); destruct_ALL; subst; eauto.
    assert (exists k, step (e_app a b) k); eauto; destruct_ALL; eauto.
    forwards*: H; eauto; destruct_ALL; eauto.
    destruct (steppable_dec _ b); destruct_ALL; subst; eauto.
    assert (exists k, step (e_app (e_abs A x) b) k); eauto; destruct_ALL; eauto.
    forwards*: H0; eauto; destruct_ALL; eauto.
    forwards*: (V_as_val H5); eauto.
    assert (exists k, (step (e_app (e_abs A x) b) k)); eauto; destruct_ALL; eauto.
  +
  destruct (steppable_dec _ a); destruct_ALL; subst; eauto.
  assert (step (e_app a b) (e_app x b)); eauto; destruct_ALL; eauto.
  rewrite (step_determinsitic H H4) in IHh.
  eapply (IHh x b _ _); eauto. eauto.
  destruct (steppable_dec _ b); destruct_ALL; subst; eauto.
  assert (step (e_app a b) (e_app a x)); eauto; destruct_ALL; eauto.
  rewrite (step_determinsitic H H5) in IHh.
  eapply (IHh a x); eauto.

  forwards*: H0; forwards*: H1; eauto. cbn in H5; destruct_ALL; subst; eauto.
  pose (V_as_val H6). inversion H; subst; eauto.
  eapply (H7 b); eauto.
Qed.

Theorem compate_app :
forall {V} {G : Ctx V} x y T1 T2,
type_safe_model G x (ty_arrow T1 T2) ->
type_safe_model G y T1 ->
type_safe_model G (e_app x y) T2.

unfold type_safe_model.
  intros. cbn.
  eapply close_compat_app; eauto.
Qed.

Lemma wfrcd_close_under_bind:
  forall {V }  {t : Exp V},
    wfrcd t ->
    forall {W : Set} {gs : V -> Exp W},
    wfrcd (V_bind_exp0 gs t).
  intros V t h.
  induction h; intros; subst; eauto; cbn in *; eauto.
Qed.

Lemma lookupNone_close_under_bind:
    forall {V : Set} {t : Exp V} ,
      wfrcd t ->
      forall {key},
      lookup1 key t = None ->
      forall {W : Set} {gs : V -> Exp W},
      lookup1 key (V_bind_exp0 gs t) = None.
    intros V t h. induction h; intros; subst; eauto; cbn in *; eauto.
    destruct (eqb key name); subst; eauto; try discriminate.
Qed.

Theorem type_safe_correct:
  forall {e T},
  type_safe_model EmptyContext e T ->
  safe e.

  unfold type_safe_model. unfold safe. unfold E.
  intros. eauto.
  assert (Env Empty_set) as HH; crush.
  idtac.
  pose (H HH (gs_empty _ _) y) as HHH.
  (* assert ((V_bind_exp0 HH e) = e) as Heq; eauto.  *)
  erewrite V_bind_exp_id0 in HHH; eauto; crush.
Qed.

Lemma wfrcd_close_step:
  forall {V} {x: Exp V},
    wfrcd x ->
    forall {y : Exp V},
    step x y ->
    wfrcd y.
intros V x h.
induction h; intros y H; subst; eauto;
inversion H; subst; eauto.
Qed.

Lemma lookup1None_close_step:
    forall {V} {x : Exp V},
      wfrcd x ->
      forall { y : Exp V} {key},
      step x y ->
      lookup1 key x = None ->
      lookup1 key y = None.
intros V x h.
induction h; intros y key H H1; subst; eauto.
inversion H.
cbn in *; eauto.
destruct (string_dec key name); subst; eauto; try rewrite eqb_refl in H1; try discriminate; try contradiction.
assert (key <> name -> (eqb key name) = false) as Hrewrite; try eapply eqb_neq; eauto.
rewrite Hrewrite in H1; eauto.
inversion H; subst; eauto; try discriminate; try contradiction; crush.
Qed.

Ltac issteppable k :=
  assert (exists z, (step k z)); eauto; destruct_ALL; eauto.

Lemma close_compate_addfield:
  forall  {rcddef term newfield T U},
  wfrcd rcddef ->
  E T term ->
  E U rcddef ->
  lookup1 newfield rcddef = None ->
  E (ty_rcdt newfield T) (e_intsctrcd rcddef newfield term) .

  intros. unfold E. intros.
  assert (
    forall x y,
      steps x y ->
    forall  {rcddef term newfield T U},
    wfrcd rcddef ->
    E T term ->
    E U rcddef ->
    lookup1 newfield rcddef = None ->
    x = (e_intsctrcd rcddef newfield term) ->
    irreducible y ->
    V (ty_rcdt newfield T) y
  ); [clear | eauto].
  intros x y h. induction h; intros; subst; eauto; try discriminate; try contradiction.
  + destruct (steppable_dec _ rcddef); subst; destruct_ALL; subst; eauto; try cleanup_impossible2; try discriminate; try contradiction.
    assert (exists k, (step (e_intsctrcd rcddef newfield term) k)); destruct_ALL; eauto.
    forwards*: H1; eauto. forwards*: (V_as_val H5); eauto.
    destruct (steppable_dec _ term); subst; destruct_ALL; subst; eauto; try cleanup_impossible2; try discriminate; try contradiction.
    issteppable (e_intsctrcd rcddef newfield term).
    forwards*: H0; eauto. cbn.
    repeat eexists; eauto.
    rewrite eqb_refl; eauto.
  + destruct (steppable_dec _ rcddef); subst; destruct_ALL; subst; eauto; try cleanup_impossible2; try discriminate; try contradiction.
    assert ((step (e_intsctrcd rcddef newfield term) (e_intsctrcd x newfield term))); destruct_ALL; eauto.
    rewrite (step_determinsitic H H6) in IHh; eauto.
    eapply (IHh x term newfield); eauto;
    try (eapply wfrcd_close_step);
    try (eapply E_close_under_step);
    try (eapply lookup1None_close_step); eauto.
    forwards*: H2; eauto.
    destruct (steppable_dec _ term); subst; destruct_ALL; subst; eauto; try cleanup_impossible2; try discriminate; try contradiction.
    assert ((step (e_intsctrcd rcddef newfield term) (e_intsctrcd rcddef newfield x))); destruct_ALL; eauto.
    rewrite (step_determinsitic H H8) in IHh; eauto.
    eapply (IHh rcddef x newfield); eauto.
    forwards*: H1; eauto.
    inversion H; subst; eauto; try cleanup_impossible2.
Qed.

Lemma V_compate_addfield2:
  forall {rcddef term newfield T U},
  wfrcd rcddef ->
  V T term ->
  V U rcddef ->
  lookup1 newfield rcddef = None ->
  V U (e_intsctrcd rcddef newfield term).
  intros rcddef term newfield T U H. intros.
  induction U; cbn in *;
  destruct_ALL; subst;
  try (inversion H; subst; eauto; fail);
  repeat eexists; eauto.
  destruct (string_dec s newfield); subst; eauto;
  better_subst; try discriminate; try contradiction.
  assert (s <> newfield -> (eqb s newfield) = false) as K; try eapply eqb_neq; eauto.
  try erewrite K; eauto.
Qed.

Lemma close_compate_addfield2:
  forall {rcddef term newfield T U},
  wfrcd rcddef ->
  E T term ->
  E U rcddef ->
  lookup1 newfield rcddef = None ->
  E U (e_intsctrcd rcddef newfield term) .

intros.
unfold E. intros.
assert (
  forall x y,
    steps x y ->
    forall {rcddef term newfield T U},
    wfrcd rcddef ->
    E T term ->
    E U rcddef ->
    lookup1 newfield rcddef = None ->
    x = (e_intsctrcd rcddef newfield term) ->
    irreducible y ->
    V U y
); [clear | eauto].
  intros x y h. induction h; intros; subst; eauto; try discriminate; try contradiction.

  + destruct (steppable_dec _ rcddef); subst; destruct_ALL; subst; eauto; try cleanup_impossible2; try discriminate; try contradiction.
    assert (exists k, (step (e_intsctrcd rcddef newfield term) k)); destruct_ALL; eauto.
    forwards*: H1; eauto. forwards*: (V_as_val H5); eauto.
    destruct (steppable_dec _ term); subst; destruct_ALL; subst; eauto; try cleanup_impossible2; try discriminate; try contradiction.
    issteppable (e_intsctrcd rcddef newfield term).
    forwards*: H0; eauto. eapply V_compate_addfield2; eauto.

  + destruct (steppable_dec _ rcddef); subst; destruct_ALL; subst; eauto; try cleanup_impossible2; try discriminate; try contradiction.
    assert ((step (e_intsctrcd rcddef newfield term) (e_intsctrcd x newfield term))); destruct_ALL; eauto.
    rewrite (step_determinsitic H H6) in IHh; eauto.
    eapply (IHh x term newfield); eauto;
    try (eapply wfrcd_close_step);
    try (eapply E_close_under_step);
    try (eapply lookup1None_close_step); eauto.
    forwards*: H2; eauto.
    destruct (steppable_dec _ term); subst; destruct_ALL; subst; eauto; try cleanup_impossible2; try discriminate; try contradiction.
    assert ((step (e_intsctrcd rcddef newfield term) (e_intsctrcd rcddef newfield x))); destruct_ALL; eauto.
    rewrite (step_determinsitic H H8) in IHh; eauto.
    eapply (IHh rcddef x newfield); eauto. eapply E_close_under_step; eauto.
    forwards*: H1; eauto.
    inversion H; subst; eauto; try cleanup_impossible2.
Qed.

Theorem compate_addfield:
  forall {V} {G : Ctx V} {rcddef term newfield T U},
  wfrcd rcddef ->
  type_safe_model G term T ->
  type_safe_model G rcddef U ->
  lookup1 newfield rcddef = None ->
  type_safe_model G (e_intsctrcd rcddef newfield term) (ty_rcdt newfield T).

  unfold type_safe_model. cbn.
  intros.  eapply close_compate_addfield; eauto;
  try (eapply wfrcd_close_under_bind; eauto);
  try (eapply lookupNone_close_under_bind; eauto).

Qed.

Theorem compate_addfield2:
  forall {V} {G : Ctx V} {rcddef term newfield T U},
  wfrcd rcddef ->
  type_safe_model G term T ->
  type_safe_model G rcddef U ->
  lookup1 newfield rcddef = None ->
  type_safe_model G (e_intsctrcd rcddef newfield term) U.

  unfold type_safe_model. cbn.
  intros.  eapply close_compate_addfield2; eauto;
  try (eapply wfrcd_close_under_bind; eauto);
  try (eapply lookupNone_close_under_bind; eauto).
Qed.

(* So elinimation might only requires everything to be closed...? *)

(* Interpret subtyping judgement *)
(* Can I do that in this way? Because usually it will be ⟦ T 〛  *)
(* Definition type_safe_subtype {V} (Γ : Ctx V) T U :=
  forall x, type_safe_model Γ x T -> type_safe_model Γ x U.

  Notation "Gamma '⊨' T '<:' U" := (type_safe_subtype Gamma T U)
  (at level 101).

Theorem compate_subtype3:
  forall {V} {Γ : Ctx V} {T U x},
  type_safe_model Γ x T ->
  type_safe_subtype Γ T U ->
  type_safe_model Γ x U.
  unfold type_safe_subtype. intros. auto.
Qed. *)

(* Definition type_safe_subtype {V} (Γ : Ctx V) T U :=
  forall gs x, good_subst Γ gs -> E T (V_bind_exp0 gs x) -> E U (V_bind_exp0 gs x). *)

Definition type_safe_subtype {V} (Γ : Ctx V) T U :=
    forall x,  E T x -> E U x.

  Notation "Gamma '⊨' T '<:' U" := (type_safe_subtype Gamma T U)
  (at level 101).

Theorem compate_subtype3:
  forall {V} {Γ : Ctx V} {T U x},
  type_safe_model Γ x T ->
  type_safe_subtype Γ T U ->
  type_safe_model Γ x U.
  unfold type_safe_subtype. unfold type_safe_model. intros. auto.
Qed.

Lemma close_compat_subtype_and:
  forall {T U} {e},
    E T e ->
    E U e ->
    E (ty_intsct T U) e.

  unfold E. cbn. intros. auto.
Qed.

Lemma close_compat_subtype_left:
  forall {T U} {e},
    E (ty_intsct T U) e ->
    E T e.

unfold E. cbn. intros T U e H. intros. eauto.
eapply H; eauto.
Qed.

Lemma close_compat_subtype_right:
  forall {T U} {e},
    E (ty_intsct T U) e ->
    E U e.

unfold E. cbn. intros T U e H. intros. eauto.
eapply H; eauto.
Qed.

Theorem compate_subtype_refl:
  forall {V} {Γ : Ctx V} {T},
  type_safe_subtype Γ T T.
unfold type_safe_subtype. intros. auto.
Qed.

Theorem compate_subtype_and:
  forall {V} {Γ : Ctx V} {X T U},
    type_safe_subtype Γ X T ->
    type_safe_subtype Γ X U ->
    type_safe_subtype Γ X (ty_intsct T U).
  unfold type_safe_subtype. unfold type_safe_model.
  intros.
  eapply close_compat_subtype_and; eauto.
Qed.

Theorem compate_subtype_left:
  forall {V} {Γ : Ctx V} {T U},
    type_safe_subtype Γ (ty_intsct T U) T.
  unfold type_safe_subtype.
  unfold type_safe_model.
  intros. eapply close_compat_subtype_left; eauto.
Qed.

Theorem compate_subtype_right:
  forall {V} {Γ : Ctx V} {T U},
    type_safe_subtype Γ (ty_intsct T U) U.
    unfold type_safe_subtype.
    unfold type_safe_model.
    intros. eapply close_compat_subtype_right; eauto.
  Qed.

Lemma close_compate_subtype_rcd:
  forall {T U},
    (forall {x}, (E T x -> E U x)) ->
    forall {y name},
    (E (ty_rcdt name T) y) ->
    (E (ty_rcdt name U) y).
  unfold E.
  intros T U  Hsubset y name Hrcd.
  intros.
  forwards*: Hrcd; eauto.
  cbn in *; destruct_ALL; subst; eauto.
  repeat eexists; eauto.
  eapply (Hsubset);  intros;
  try (eapply val_not_steppable);
  try (eapply V_as_val);
  eauto.
  match goal with
  | [h : steps ?x2 _ , h1 : V _ ?x2 |- _] =>
  inversion h; subst; eauto
  end.
Qed.

(* Lemma Exp0_inject_ExpV:
  forall (x : Exp0) {V },
  exists (z : Exp V), forall gs, V_bind_exp0 gs z = x.
  assert (
    forall {W} {x : Exp W} {V},
      W = Empty_set ->
      exists (z : Exp V), forall gs, V_bind_exp0 gs z = x
  );[ clear | eauto].
  intros W x. induction x; intros; subst; eauto.

Abort.
   *)

Lemma compate_subtype_rcd:
  forall  {Vs} {Γ : Ctx Vs} {T U},
    type_safe_subtype Γ T U ->
    forall {name},
    type_safe_subtype Γ (ty_rcdt name T) (ty_rcdt name U).
  unfold type_safe_subtype.
  unfold type_safe_model.
  intros.
  eapply close_compate_subtype_rcd; eauto.
Qed.

Theorem compate_subtype_top:
  forall {Vs} {Γ : Ctx Vs} {T},
  type_safe_subtype Γ T ty_top.
  unfold type_safe_subtype.
  unfold type_safe_model.
  cbn. unfold E. intros. eauto.
Qed.

Hint Constructors steps step.

Lemma eproj_step_lookup:
  forall {Vs} {x : Exp Vs},
    wfrcd x ->
    forall  {name t},
    lookup1 name x = Some t ->
    val x ->
    steps (e_prj name x) t.

  intros Vs x h.
  induction h. intros name t h0 h1; cbn in *; try discriminate; try contradiction.
  intros name0 t H HH.
  destruct (string_dec name0 name); cbn in *; subst; eauto;
  repeat rewrite eqb_refl in H;
  repeat rewrite eqb_neq in H; eauto;
  destruct_ALL; subst; eauto;
  inversion HH; subst; eauto.
  assert (name0 <> name -> (eqb name0 name) = false) as Hneq; try eapply eqb_neq; eauto.

  rewrite Hneq in H. eauto. eauto.
Qed.

Lemma close_compate_remove_field:
  forall {rcddef},
  wfrcd rcddef ->
  forall { term T name name0},
  E (ty_rcdt name T) (e_intsctrcd rcddef name0 term) ->
  val term ->
  name <> name0 ->
  E (ty_rcdt name T) rcddef.
  intros rcddef h.
  induction h; unfold E; intros; subst; eauto.
  inversion H2; subst; eauto.
  forwards*: (H e_top).

Abort.

Theorem steps_converge:
  forall {V} {x y : Exp V},
    steps x y ->
    forall {z},
    steps x z ->
    (steps y z) \/ (steps z y).
  intros V x y h.
  induction h;intros; subst; eauto.
  inversion H0; subst; eauto.
  rewrite (step_determinsitic H1 H) in H2; subst; eauto.
Qed.

Theorem V_as_E:
  forall T t,
    V T t ->
    E T t.
  unfold E. intros; eauto.
  pose (V_as_val H); eauto.
  inversion H0; subst; eauto.
Qed.

Lemma close_compate_lookup:
  forall  {x},
    wfrcd x ->
    forall {name t T},
    lookup1 name x = Some t ->
    V ty_top x ->
    V T t ->
    V (ty_rcdt name T) x.
  intros x h.
  induction h. intros; subst; eauto.
  + cbn in *; eauto; try discriminate; try contradiction.
  +
  intros. eauto.
  cbn. unfold E'.
  repeat eexists; eauto.
Qed.

Lemma close_compate_proj:
  forall {name T x},
    E (ty_rcdt name T) x ->
    E T (e_prj name x).
  intros. unfold E. intros.
assert (
  forall u y,
    steps u y->
  forall name T x,
  E (ty_rcdt name T) x ->
    u = e_prj name x ->
    irreducible y ->
  V T y
); [clear | eauto].
intros u y h.
induction h; intros; subst; eauto.
+ destruct (steppable_dec _ x0); destruct_ALL; subst; eauto.
  issteppable (e_prj name x0).
  unfold E in H. cbn in *.
  forwards* : H; destruct_ALL.
  inversion H2; subst ;eauto.
  issteppable (e_prj name (e_intsctrcd x x1 x2)).
  destruct (string_dec name x1); subst; eauto;
  repeat eexists; eauto.
+ destruct (steppable_dec _ x0); destruct_ALL; subst; eauto.
  assert (step (e_prj name x0) (e_prj name x)); eauto.
  rewrite (step_determinsitic H H3) in IHh; subst; eauto.
  eapply (IHh name T x); subst; eauto.
  forwards*: H0; subst; eauto. cbn in H3; destruct_ALL; eauto.
  destruct (string_dec name x1); subst; eauto;
  inversion H; subst; eauto; try discriminate; try contradiction. cbn in H5; eauto.
  try rewrite eqb_refl in H5; subst; eauto; destruct_ALL; eauto.
  inversion h; subst; eauto.
  cbn in H5. assert (name <> x1 -> (eqb name x1) = false) as HHeq; subst; try eapply eqb_neq; eauto.
  rewrite HHeq in H5; eauto.
  eapply (IHh name T x); eauto.
  eapply V_as_E.
  eapply close_compate_lookup; eauto. inversion H4; subst; eauto.
Qed.

Theorem comapate_proj:
  forall {Vs} (Γ : Ctx Vs) x name T,
    type_safe_model Γ x (ty_rcdt name T) ->
    type_safe_model Γ (e_prj name x) T.

  unfold type_safe_model.
  intros. eapply close_compate_proj; eauto.
Qed.

Definition compate_abs :
forall {V} {G : Ctx V}  body T1 T2,
type_safe_model (ctx_append G T1) body T2 ->
type_safe_model G (e_abs T1 body) (ty_arrow T1 T2).

unfoldAll. intros; eauto.
inversion H0; subst; eauto; try cleanup_impossible2.

repeat eexists; eauto.
intros. eapply H; eauto. eapply gs_extend; eauto.

erewrite V_bind_bind_exp0 in *. eauto.

intros.  destruct x; cbn; eauto.
idtac.
erewrite (V_bind_map_exp0 ); eauto; crush.
erewrite (V_bind_exp_id0); eauto.
erewrite V_map_exp_id; eauto.
Unshelve. eauto.
Qed.


(* En este archivo se formalizan las funciones parciales. El código del
 * mismo fue tomado del trabajo "Formally verifying isolation and availability in an
 * idealized model of virtualization" de Gilles Barthe et al.                        *)

Require Import List.
Require Import Classical.
Require Import FunInd.

Set Implicit Arguments.

Section Exc_Type.

(* The type representing the codomain of the partial function *)
Inductive exc (V E : Set) : Set :=
  | Value : V -> exc V E
  | Error : E -> exc V E.

Variable V1 V2 V3 E1 E2 : Set.
Variable v : V1.

Definition is_Value (e : exc V1 E1) : Prop :=
  match e with
  | Value _ _ => True
  | Error _ _ => False
  end.

Definition is_ValueBool (e : exc V1 E1) : bool:=
  match e with
  | Value _ _ => true
  | Error _ _ => false
  end.
End Exc_Type.

(* This module describes a naive implementation of a dictionary (maps) using
   association lists. *)
Notation "'If' c1 'then' c2 'else' c3" :=
  match c1 with
  | left _ => c2
  | right _ => c3
  end (at level 200).

Section Mapping_Definition.

(* The type of index for accessing the map *)
Variable index : Set.
Variable index_eq : forall x y : index, {x = y} + {x <> y}.

(* The type of information associated to each index *)
Variable info : Set.

Record item : Set :=
 Item
    (* the index *)
    {item_index : index;
    (* the data associated to the index *)
    item_info : info
   }.

(* Mappings as lists *)
Definition mapping : Set := list item.

(* Empty map  *)
Definition map_empty : mapping := nil.

(* Map add *)
(* Adding of a new entry in the map.
   If the key already exists in the map, the info is redefined. *)
Function map_add (mp : mapping) (idx : index)
  (inf : info) : mapping :=
  let newit := (Item idx inf) in
  match mp with
  | nil =>  newit :: map_empty
  | it :: mp1 =>
      If index_eq (item_index it) idx
      then newit :: mp1
      else it :: map_add mp1 idx inf
  end.

(* Map apply *)
Function map_apply (mp : mapping)
  (idx : index) : exc info index :=
  match mp with
  | nil => Error info idx
  | it :: mp1 =>
      If index_eq idx (item_index it)
      then Value index (item_info it)
      else map_apply mp1 idx
  end.

(* Map drop *)
Function map_drop (mp : mapping)
  (idx : index) : mapping :=
  match mp with
  | nil => nil
  | it :: mp1 =>
      If index_eq idx (item_index it)
      then map_drop mp1 idx
      else it :: map_drop mp1 idx
  end.

(* Several map observers *)

Definition map_valid_index (mp : mapping) (idx : index) : Prop :=
  exists it : _, map_apply mp idx = Value index it.

Fixpoint map_valid_index_fix (mp:mapping) (idx:index) : bool :=
  match mp with
    | nil => false
    | it::mp' =>
      If (index_eq (item_index it) idx) then
        true
      else
        map_valid_index_fix mp' idx
  end.

(* Map size *)
Definition map_size (mp : mapping) : nat := length mp.

Definition map_getKeys (mp : mapping) : list index :=
    map (fun item => item_index item) mp.

Fixpoint map_correct (mp:mapping) : Prop :=
    match mp with
    | nil => True
    | (a::rest) => ~(In (item_index a) (map_getKeys rest)) /\ map_correct rest
    end.

End Mapping_Definition.

Section Mapping_Properties.

Lemma addAndApply : forall (index values:Set) (indexeq: forall x y : index, {x = y} + {x <> y}) (i:index) (v:values) (mp:mapping index values), Value index v = map_apply indexeq (map_add indexeq mp i v) i.
Proof.
    intros.
    induction mp.
    simpl.
    destruct (indexeq i i).
    auto.
    destruct n.
    auto.
    case(indexeq i (item_index a));intros.
    simpl.
    rewrite<- e.
    destruct (indexeq i i).
    simpl.
    destruct (indexeq i i).
    auto.
    destruct n;auto.
    destruct n;auto.
    simpl.
    destruct (indexeq (item_index a) i).
    simpl.
    destruct (indexeq i i).
    auto.
    destruct n0;auto.
    simpl.
    destruct (indexeq i (item_index a)).
    destruct n0;auto.
    rewrite IHmp.
    auto.
Qed.

Lemma overrideNotEq : forall (index values:Set) (indexeq: forall x y : index, {x = y} + {x <> y}) (i i':index) (v:values) (mp:mapping index values), i<>i' -> map_apply indexeq (map_add indexeq mp i v) i' = map_apply indexeq mp i'.
Proof.
    intros.
    induction mp.
    simpl.
    destruct indexeq.
    rewrite e in H.
    unfold not in H.
    destruct H.
    auto.
    auto.
    simpl.
    case(indexeq i' (item_index a));intros.
    simpl.
    destruct (indexeq i' (item_index a)).
    rewrite<- e.
    destruct (indexeq i' i).
    unfold not in H.
    destruct H.
    auto.
    simpl.
    rewrite <-e.
    destruct (indexeq i' i').
    auto.
    unfold not in n0.
    destruct n0.
    auto.
    unfold not in n.
    destruct n.
    auto.
    destruct (indexeq (item_index a) i).
    simpl.
    destruct (indexeq i' i).
    rewrite<- IHmp.
    rewrite e0.
    apply (addAndApply).
    auto.
    simpl.
    destruct (indexeq i' (item_index a)).
    destruct n;auto.
    auto.
Qed.

Lemma dropNotExists : forall (index values:Set) (indexeq: forall x y : index, {x = y} + {x <> y}) (i:index) (mp:mapping index values), ~(exists (it:item index values), In it (map_drop indexeq mp i) /\ item_index it=i).
Proof.
    intros.
    induction mp.
    unfold not;intros.
    destruct H.
    destruct H.
    simpl in H.
    auto.

    unfold not;intros.
    destruct H.
    destruct H.
    apply IHmp.
    exists x.
    split.
    assert (item_index a<>i).
    unfold not;intros.
    unfold map_drop in H;simpl in H.
    destruct indexeq in H.
    apply IHmp.
    exists x.
    split; auto.
    symmetry in H1.
    contradiction.

    unfold map_drop in H;simpl in H.
    destruct indexeq in H.
    auto.
    inversion H.
    rewrite H2 in H1.
    contradiction.
    auto.
    auto.
Qed.

Lemma isValueExists : forall (index values:Set) (indexeq: forall x y : index, {x = y} + {x <> y}) (i:index) (mp:mapping index values), is_Value (map_apply indexeq mp i) -> (exists (it:item index values), In it mp /\ item_index it=i).
Proof.
    intros.
    case_eq (map_apply indexeq mp i);intros.
    exists (Item i v).
    simpl;split;auto.
    induction mp.
    simpl in H0.
    discriminate H0.
    elim (classic (item_index a=i));intros.

    left.
    simpl in H0.
    destruct indexeq in H0.
    assert (item_info a=v).
    Focus 2.
    case_eq a;intros.
    f_equal.
    assert (item_index a=item_index0).
    rewrite H3; auto.
    rewrite H4 in H1.
    auto.
    assert (item_info a=item_info0).
    rewrite H3; auto.
    rewrite H4 in H2.
    auto.
    injection H0;auto.
    symmetry in H1.
    contradiction.

    right.
    simpl in H0.
    destruct indexeq in H0.
    symmetry in e.
    contradiction.
    apply IHmp.
    rewrite H0.
    simpl;auto.
    auto.

    rewrite H0 in H.
    simpl in H.
    destruct H.
Qed.

Lemma valueDropNotValue : forall (index values:Set) (indexeq: forall x y : index, {x = y} + {x <> y}) (i:index) (mp:mapping index values), ~(is_Value (map_apply indexeq (map_drop indexeq mp i) i)).
Proof.
    intros.
    unfold not;intros.
    assert (exists (it:item index values), In it (map_drop indexeq mp i) /\ item_index it=i).
    apply (isValueExists indexeq);auto.
    absurd (exists it : item index values, In it (map_drop indexeq mp i) /\ item_index it = i).
    apply dropNotExists.
    auto.
Qed.

Lemma valueDropDiffImpliesValue : forall (index values:Set) (indexeq: forall x y : index, {x = y} + {x <> y}) (i i':index) (v:values) (mp:mapping index values), map_apply indexeq (map_drop indexeq mp i) i' = Value index v -> i <> i' -> map_apply indexeq mp i' = Value index v.
Proof.
    intros.
    induction mp.
    simpl in H.
    discriminate H.
    simpl in H;destruct indexeq in H.
    rewrite e in H0.
    simpl.
    destruct (indexeq i' (item_index a)).
    symmetry in e0.
    contradiction.
    apply IHmp;auto.
    simpl in H;destruct indexeq in H.
    simpl;destruct (indexeq i (item_index a)).
    contradiction.
    destruct (indexeq i' (item_index a)).
    auto.
    contradiction.
    simpl.
    destruct (indexeq i' (item_index a)).
    contradiction.
    auto.
Qed.

Lemma valueDropValue : forall (index values:Set) (indexeq: forall x y : index, {x = y} + {x <> y}) (i i':index) (v:values) (mp:mapping index values), map_apply indexeq (map_drop indexeq mp i) i' = Value index v <-> map_apply indexeq mp i' = Value index v /\ i<>i'.
Proof.
    split;intros.
    assert (i<>i').
    unfold not;intros.
    absurd (is_Value (map_apply indexeq (map_drop indexeq mp i) i')).
    rewrite H0 in *.
    apply (valueDropNotValue).
    rewrite H.
    simpl.
    auto.
    split.
    apply (valueDropDiffImpliesValue indexeq mp H).
    auto.
    auto.

    destruct H.

    induction mp.
    simpl in H.
    discriminate H.
    simpl in H;destruct indexeq in H.
    rewrite e in H0.
    simpl.
    destruct (indexeq i' (item_index a)).
    destruct (indexeq i (item_index a)).
    symmetry in e0.
    contradiction.
    simpl.
    destruct (indexeq i' (item_index a)).
    auto.
    contradiction.
    contradiction.
    simpl.
    destruct (indexeq i (item_index a)).
    apply IHmp;auto.
    simpl.
    destruct (indexeq i' (item_index a)).
    contradiction.
    auto.

Qed.

Lemma valueIffExists : forall (index values:Set) (indexeq: forall x y : index, {x = y} + {x <> y}) (i:index) (v:values) (mp:mapping index values) (mpCorrect : map_correct mp), map_apply indexeq mp i = Value index v <-> In (Item i v) mp.
Proof.
    split;intros.
    clear mpCorrect.
    induction mp.
    unfold map_apply in H.
    inversion H.
    simpl in H.
    destruct indexeq in H.
    inversion H.
    rewrite e.
    remember ({| item_index := item_index a; item_info := item_info a |}) as theitem.
    assert (theitem=a).
    case_eq a;intros.
    rewrite H0 in Heqtheitem.
    simpl in Heqtheitem.
    auto.
    rewrite H0.
    apply in_eq.

    apply in_cons.
    apply IHmp; auto.

    induction mp.
    inversion H.
    remember {| item_index := i; item_info := v |} as theItem.
    inversion H.
    simpl.
    rewrite H0.
    rewrite HeqtheItem.
    simpl.
    destruct (indexeq i i).
    auto.
    absurd (i=i);auto.
    assert (item_index a <>i).
    unfold map_correct in mpCorrect.
    unfold not;intros.
    apply mpCorrect.
    unfold map_getKeys.
    rewrite in_map_iff.
    exists theItem.
    split;auto.
    rewrite HeqtheItem.
    simpl.
    auto.
    simpl.
    destruct (indexeq i (item_index a)).
    symmetry in e.
    contradiction.
    apply IHmp.
    unfold map_correct in mpCorrect.
    destruct mpCorrect.
    auto.
    auto.
Qed.

Lemma dropSthElse : forall (index values:Set) (indexeq: forall x y : index, {x = y} + {x <> y}) (i i':index) (mp:mapping index values), i<>i' -> map_apply indexeq mp i = map_apply indexeq (map_drop indexeq mp i') i.
Proof.
    intros.
    induction mp.
    simpl.
    auto.
    simpl.
    destruct (indexeq i (item_index a)).
    destruct (indexeq i' (item_index a)).
    rewrite <-e in e0.
    symmetry in e0;contradiction.
    simpl.
    destruct (indexeq i (item_index a)).
    auto.
    contradiction.
    destruct (indexeq i' (item_index a)).
    auto.
    simpl.
    destruct (indexeq i (item_index a)).
    contradiction.
    auto.
Qed.

Lemma valueIffInGetKeys : forall (index values:Set) (indexeq: forall x y : index, {x = y} + {x <> y}) (i:index) (mp:mapping index values) (mpCorrect:map_correct mp), is_Value (map_apply indexeq mp i) <-> In i (map_getKeys mp).
Proof.
    unfold map_getKeys.
    split;intros.
    rewrite in_map_iff.
    case_eq (map_apply indexeq mp i);intros.
    exists{| item_index := i; item_info := v |}.
    rewrite <-valueIffExists.
    split;auto.
    exact H0.
    auto.
    rewrite H0 in H.
    inversion H.

    rewrite in_map_iff in H.
    destruct H.
    destruct H.
    case_eq x;intros.
    rewrite H1 in H0.
    assert (map_apply indexeq mp i = Value index item_info0).
    apply valueIffExists; auto.
    rewrite H1 in H.
    simpl in H.
    rewrite <-H.
    auto.
    rewrite H2.
    unfold is_Value.
    auto.
Qed.

Lemma addPreservesCorrectness : forall (index values:Set) (indexeq: forall x y : index, {x = y} + {x <> y}) (i:index) (v:values) (mp:mapping index values) (mpCorrect:map_correct mp), map_correct (map_add indexeq mp i v).
Proof.
    intros.
    functional induction (map_add indexeq mp i v).
    unfold map_empty.
    unfold map_correct.
    split;auto.
    unfold map_correct in mpCorrect.
    destruct mpCorrect.
    unfold map_correct.
    simpl.
    split;auto.
    assert (map_correct mp1).
    unfold map_correct in mpCorrect.
    destruct mpCorrect.
    auto.
    unfold map_correct.
    specialize (IHm H).
    split.
    rewrite <-(valueIffInGetKeys indexeq);auto.
    unfold not;intros.
    rewrite overrideNotEq in H0.
    unfold map_correct in mpCorrect.
    destruct mpCorrect.
    rewrite (valueIffInGetKeys indexeq) in H0;auto.
    auto.
    unfold map_correct in IHm.
    auto.
Qed.

Lemma dropPreservesCorrectness : forall (index values:Set) (indexeq: forall x y : index, {x = y} + {x <> y}) (i:index) (mp:mapping index values) (mpCorrect:map_correct mp), map_correct (map_drop indexeq mp i).
Proof.
    intros.
    functional induction (map_drop indexeq mp i).
    auto.
    assert (map_correct mp1).
    unfold map_correct in mpCorrect.
    destruct mpCorrect.
    auto.
    specialize (IHm H).
    auto.
    unfold map_correct.
    split.

    assert (map_correct mp1).
    unfold map_correct in mpCorrect.
    destruct mpCorrect.
    auto.
    specialize (IHm H).
    rewrite <-(valueIffInGetKeys indexeq);auto.
    rewrite<-dropSthElse;auto.
    rewrite (valueIffInGetKeys indexeq);auto.
    unfold map_correct in mpCorrect.
    destruct mpCorrect.
    auto.
    assert (map_correct mp1).
    unfold map_correct in mpCorrect.
    destruct mpCorrect.
    auto.
    specialize (IHm H).
    auto.
Qed.

End Mapping_Properties.


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

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-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.
*)

(** * IEEE-754 arithmetic *)

From Coq Require Import ZArith Reals Psatz SpecFloat.

Require Import Core Round Bracket Operations Div Sqrt Relative BinarySingleNaN.

Module BSN := BinarySingleNaN.

Arguments BSN.B754_zero {prec emax}.
Arguments BSN.B754_infinity {prec emax}.
Arguments BSN.B754_nan {prec emax}.
Arguments BSN.B754_finite {prec emax}.

Section AnyRadix.

Inductive full_float :=
  | F754_zero (s : bool)
  | F754_infinity (s : bool)
  | F754_nan (s : bool) (m : positive)
  | F754_finite (s : bool) (m : positive) (e : Z).

Definition FF2SF x :=
  match x with
  | F754_zero s => S754_zero s
  | F754_infinity s => S754_infinity s
  | F754_nan _ _ => S754_nan
  | F754_finite s m e => S754_finite s m e
  end.

Definition FF2R beta x :=
  match x with
  | F754_finite s m e => F2R (Float beta (cond_Zopp s (Zpos m)) e)
  | _ => 0%R
  end.

Lemma SF2R_FF2SF :
  forall beta x,
  SF2R beta (FF2SF x) = FF2R beta x.
Proof.
now intros beta [s|s|s m|s m e].
Qed.

Definition SF2FF x :=
  match x with
  | S754_zero s => F754_zero s
  | S754_infinity s => F754_infinity s
  | S754_nan => F754_nan false xH
  | S754_finite s m e => F754_finite s m e
  end.

Lemma FF2SF_SF2FF :
  forall x,
  FF2SF (SF2FF x) = x.
Proof.
now intros [s|s| |s m e].
Qed.

Lemma FF2R_SF2FF :
  forall beta x,
  FF2R beta (SF2FF x) = SF2R beta x.
Proof.
now intros beta [s|s| |s m e].
Qed.

Definition is_nan_FF f :=
  match f with
  | F754_nan _ _ => true
  | _ => false
  end.

Lemma is_nan_SF2FF :
  forall x,
  is_nan_FF (SF2FF x) = is_nan_SF x.
Proof.
now intros [s|s| |s m e].
Qed.

Lemma is_nan_FF2SF :
  forall x,
  is_nan_SF (FF2SF x) = is_nan_FF x.
Proof.
now intros [s|s|s m|s m e].
Qed.

Lemma SF2FF_FF2SF :
  forall x,
  is_nan_FF x = false ->
  SF2FF (FF2SF x) = x.
Proof.
now intros [s|s|s m|s m e] H.
Qed.

Definition sign_FF x :=
  match x with
  | F754_nan s _ => s
  | F754_zero s => s
  | F754_infinity s => s
  | F754_finite s _ _ => s
  end.

Definition is_finite_FF f :=
  match f with
  | F754_finite _ _ _ => true
  | F754_zero _ => true
  | _ => false
  end.

Lemma is_finite_SF2FF :
  forall x,
  is_finite_FF (SF2FF x) = is_finite_SF x.
Proof.
now intros [| | |].
Qed.

Lemma sign_SF2FF :
  forall x,
  sign_FF (SF2FF x) = sign_SF x.
Proof.
now intros [| | |].
Qed.

End AnyRadix.

Section Binary.

Arguments exist {A} {P}.

(** [prec] is the number of bits of the mantissa including the implicit one;
    [emax] is the exponent of the infinities.
    For instance, binary32 is defined by [prec = 24] and [emax = 128]. *)
Variable prec emax : Z.
Context (prec_gt_0_ : Prec_gt_0 prec).
Context (prec_lt_emax_ : Prec_lt_emax prec emax).

Notation emin := (emin prec emax) (only parsing).
Notation fexp := (fexp prec emax) (only parsing).
Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec.
Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec.

Notation canonical_mantissa := (canonical_mantissa prec emax).

Notation bounded := (SpecFloat.bounded prec emax).

Definition nan_pl pl :=
  Zlt_bool (Zpos (digits2_pos pl)) prec.

Notation valid_binary_SF := (valid_binary prec emax).

Definition valid_binary x :=
  match x with
  | F754_finite _ m e => bounded m e
  | F754_nan _ pl => nan_pl pl
  | _ => true
  end.

Lemma valid_binary_SF2FF :
  forall x,
  is_nan_SF x = false ->
  valid_binary (SF2FF x) = valid_binary_SF x.
Proof.
now intros [sx|sx| |sx mx ex] H.
Qed.

(** Basic type used for representing binary FP numbers.
    Note that there is exactly one such object per FP datum. *)

Inductive binary_float :=
  | B754_zero (s : bool)
  | B754_infinity (s : bool)
  | B754_nan (s : bool) (pl : positive) :
    nan_pl pl = true -> binary_float
  | B754_finite (s : bool) (m : positive) (e : Z) :
    bounded m e = true -> binary_float.

Definition B2BSN (x : binary_float) : BSN.binary_float prec emax :=
  match x with
  | B754_zero s => BSN.B754_zero s
  | B754_infinity s => BSN.B754_infinity s
  | B754_nan _ _ _ => BSN.B754_nan
  | B754_finite s m e H => BSN.B754_finite s m e H
  end.

Definition FF2B x :=
  match x as x return valid_binary x = true -> binary_float with
  | F754_finite s m e => B754_finite s m e
  | F754_infinity s => fun _ => B754_infinity s
  | F754_zero s => fun _ => B754_zero s
  | F754_nan b pl => fun H => B754_nan b pl H
  end.

Definition B2FF x :=
  match x with
  | B754_finite s m e _ => F754_finite s m e
  | B754_infinity s => F754_infinity s
  | B754_zero s => F754_zero s
  | B754_nan b pl _ => F754_nan b pl
  end.

Definition B2R f :=
  match f with
  | B754_finite s m e _ => F2R (Float radix2 (cond_Zopp s (Zpos m)) e)
  | _ => 0%R
  end.

Definition B2SF (x : binary_float) :=
  match x with
  | B754_finite s m e _ => S754_finite s m e
  | B754_infinity s => S754_infinity s
  | B754_zero s => S754_zero s
  | B754_nan _ _ _ => S754_nan
  end.

Lemma B2SF_B2BSN :
  forall x,
  BSN.B2SF (B2BSN x) = B2SF x.
Proof.
now intros [sx|sx|sx px Px|sx mx ex Bx].
Qed.

Lemma B2SF_FF2B :
  forall x Bx,
  B2SF (FF2B x Bx) = FF2SF x.
Proof.
now intros [sx|sx|sx px|sx mx ex] Bx.
Qed.

Lemma B2R_B2BSN :
  forall x, BSN.B2R (B2BSN x) = B2R x.
Proof.
intros x.
now destruct x.
Qed.

Lemma FF2SF_B2FF :
  forall x,
  FF2SF (B2FF x) = B2SF x.
Proof.
now intros [sx|sx|sx plx|sx mx ex].
Qed.

Theorem FF2R_B2FF :
  forall x,
  FF2R radix2 (B2FF x) = B2R x.
Proof.
now intros [sx|sx|sx plx Hplx|sx mx ex Hx].
Qed.

Theorem B2FF_FF2B :
  forall x Hx,
  B2FF (FF2B x Hx) = x.
Proof.
now intros [sx|sx|sx plx|sx mx ex] Hx.
Qed.

Theorem valid_binary_B2FF :
  forall x,
  valid_binary (B2FF x) = true.
Proof.
now intros [sx|sx|sx plx Hplx|sx mx ex Hx].
Qed.

Theorem FF2B_B2FF :
  forall x H,
  FF2B (B2FF x) H = x.
Proof.
intros [sx|sx|sx plx Hplx|sx mx ex Hx] H ; try easy.
apply f_equal, eqbool_irrelevance.
apply f_equal, eqbool_irrelevance.
Qed.

Theorem FF2B_B2FF_valid :
  forall x,
  FF2B (B2FF x) (valid_binary_B2FF x) = x.
Proof.
intros x.
apply FF2B_B2FF.
Qed.

Theorem B2R_FF2B :
  forall x Hx,
  B2R (FF2B x Hx) = FF2R radix2 x.
Proof.
now intros [sx|sx|sx plx|sx mx ex] Hx.
Qed.

Theorem match_FF2B :
  forall {T} fz fi fn ff x Hx,
  match FF2B x Hx return T with
  | B754_zero sx => fz sx
  | B754_infinity sx => fi sx
  | B754_nan b p _ => fn b p
  | B754_finite sx mx ex _ => ff sx mx ex
  end =
  match x with
  | F754_zero sx => fz sx
  | F754_infinity sx => fi sx
  | F754_nan b p => fn b p
  | F754_finite sx mx ex => ff sx mx ex
  end.
Proof.
now intros T fz fi fn ff [sx|sx|sx plx|sx mx ex] Hx.
Qed.

Theorem canonical_canonical_mantissa :
  forall (sx : bool) mx ex,
  canonical_mantissa mx ex = true ->
  canonical radix2 fexp (Float radix2 (cond_Zopp sx (Zpos mx)) ex).
Proof.
intros sx mx ex H.
assert (Hx := Zeq_bool_eq _ _ H). clear H.
apply sym_eq.
simpl.
pattern ex at 2 ; rewrite <- Hx.
apply (f_equal fexp).
rewrite mag_F2R_Zdigits.
rewrite <- Zdigits_abs.
rewrite Zpos_digits2_pos.
now case sx.
now case sx.
Qed.

Theorem generic_format_B2R :
  forall x,
  generic_format radix2 fexp (B2R x).
Proof.
intros [sx|sx|sx plx Hx |sx mx ex Hx] ; try apply generic_format_0.
simpl.
apply generic_format_canonical.
apply canonical_canonical_mantissa.
now destruct (andb_prop _ _ Hx) as (H, _).
Qed.

Theorem FLT_format_B2R :
  forall x,
  FLT_format radix2 emin prec (B2R x).
Proof with auto with typeclass_instances.
intros x.
apply FLT_format_generic...
apply generic_format_B2R.
Qed.

Theorem B2FF_inj :
  forall x y : binary_float,
  B2FF x = B2FF y ->
  x = y.
Proof.
intros [sx|sx|sx plx Hplx|sx mx ex Hx] [sy|sy|sy ply Hply|sy my ey Hy] ; try easy.
(* *)
intros H.
now inversion H.
(* *)
intros H.
now inversion H.
(* *)
intros H.
inversion H.
clear H.
revert Hplx.
rewrite H2.
intros Hx.
apply f_equal, eqbool_irrelevance.
(* *)
intros H.
inversion H.
clear H.
revert Hx.
rewrite H2, H3.
intros Hx.
apply f_equal, eqbool_irrelevance.
Qed.

Definition is_finite_strict f :=
  match f with
  | B754_finite _ _ _ _ => true
  | _ => false
  end.

Lemma is_finite_strict_B2BSN :
  forall x, BSN.is_finite_strict (B2BSN x) = is_finite_strict x.
Proof.
intros x.
now destruct x.
Qed.

Theorem B2R_inj:
  forall x y : binary_float,
  is_finite_strict x = true ->
  is_finite_strict y = true ->
  B2R x = B2R y ->
  x = y.
Proof.
intros [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; try easy.
simpl.
intros _ _ Heq.
assert (Hs: sx = sy).
(* *)
revert Heq. clear.
case sx ; case sy ; try easy ;
  intros Heq ; apply False_ind ; revert Heq.
apply Rlt_not_eq.
apply Rlt_trans with R0.
now apply F2R_lt_0.
now apply F2R_gt_0.
apply Rgt_not_eq.
apply Rgt_trans with R0.
now apply F2R_gt_0.
now apply F2R_lt_0.
assert (mx = my /\ ex = ey).
(* *)
refine (_ (canonical_unique _ fexp _ _ _ _ Heq)).
rewrite Hs.
now case sy ; intro H ; injection H ; split.
apply canonical_canonical_mantissa.
exact (proj1 (andb_prop _ _ Hx)).
apply canonical_canonical_mantissa.
exact (proj1 (andb_prop _ _ Hy)).
(* *)
revert Hx.
rewrite Hs, (proj1 H), (proj2 H).
intros Hx.
apply f_equal.
apply eqbool_irrelevance.
Qed.

Definition Bsign x :=
  match x with
  | B754_nan s _ _ => s
  | B754_zero s => s
  | B754_infinity s => s
  | B754_finite s _ _ _ => s
  end.

Theorem Bsign_FF2B :
  forall x H,
  Bsign (FF2B x H) = sign_FF x.
Proof.
now intros [sx|sx|sx plx|sx mx ex] H.
Qed.

Definition is_finite f :=
  match f with
  | B754_finite _ _ _ _ => true
  | B754_zero _ => true
  | _ => false
  end.

Lemma is_finite_B2BSN :
  forall x, BSN.is_finite (B2BSN x) = is_finite x.
Proof.
intros x.
now destruct x.
Qed.

Theorem is_finite_FF2B :
  forall x Hx,
  is_finite (FF2B x Hx) = is_finite_FF x.
Proof.
now intros [| | |].
Qed.

Theorem is_finite_B2FF :
  forall x,
  is_finite_FF (B2FF x) = is_finite x.
Proof.
now intros [| | |].
Qed.

Theorem B2R_Bsign_inj:
  forall x y : binary_float,
    is_finite x = true ->
    is_finite y = true ->
    B2R x = B2R y ->
    Bsign x = Bsign y ->
    x = y.
Proof.
intros. destruct x, y; try (apply B2R_inj; now eauto).
- simpl in H2. congruence.
- symmetry in H1. apply Rmult_integral in H1.
  destruct H1. apply (eq_IZR _ 0) in H1. destruct s0; discriminate H1.
  simpl in H1. pose proof (bpow_gt_0 radix2 e).
  rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3.
- apply Rmult_integral in H1.
  destruct H1. apply (eq_IZR _ 0) in H1. destruct s; discriminate H1.
  simpl in H1. pose proof (bpow_gt_0 radix2 e).
  rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3.
Qed.

Definition is_nan f :=
  match f with
  | B754_nan _ _ _ => true
  | _ => false
  end.

Lemma is_nan_B2BSN :
  forall x,
  BSN.is_nan (B2BSN x) =  is_nan x.
Proof.
now intros [s|s|s p H|s m e H].
Qed.

Theorem is_nan_FF2B :
  forall x Hx,
  is_nan (FF2B x Hx) = is_nan_FF x.
Proof.
now intros [| | |].
Qed.

Theorem is_nan_B2FF :
  forall x,
  is_nan_FF (B2FF x) = is_nan x.
Proof.
now intros [| |? []|].
Qed.

Definition get_nan_pl (x : binary_float) : positive :=
  match x with B754_nan _ pl _ => pl | _ => xH end.

Definition build_nan (x : { x | is_nan x = true }) : binary_float.
Proof.
apply (B754_nan (Bsign (proj1_sig x)) (get_nan_pl (proj1_sig x))).
destruct x as [x H].
assert (K: false = true -> nan_pl 1 = true) by (intros K ; now elim Bool.diff_false_true).
simpl.
revert H.
destruct x as [sx|sx|sx px Px|sx mx ex Bx]; try apply K.
intros _.
apply Px.
Defined.

Theorem build_nan_correct :
  forall x : { x | is_nan x = true },
  build_nan x = proj1_sig x.
Proof.
intros [x H].
now destruct x.
Qed.

Theorem B2R_build_nan :
  forall x, B2R (build_nan x) = 0%R.
Proof.
easy.
Qed.

Theorem is_finite_build_nan :
  forall x, is_finite (build_nan x) = false.
Proof.
easy.
Qed.

Theorem is_nan_build_nan :
  forall x, is_nan (build_nan x) = true.
Proof.
easy.
Qed.

Definition BSN2B (nan : {x : binary_float | is_nan x = true }) (x : BSN.binary_float prec emax) : binary_float :=
  match x with
  | BSN.B754_nan => build_nan nan
  | BSN.B754_zero s => B754_zero s
  | BSN.B754_infinity s => B754_infinity s
  | BSN.B754_finite s m e H => B754_finite s m e H
  end.

Lemma B2BSN_BSN2B :
  forall nan x,
  B2BSN (BSN2B nan x) = x.
Proof.
now intros nan [s|s| |s m e H].
Qed.

Lemma B2R_BSN2B :
  forall nan x, B2R (BSN2B nan x) = BSN.B2R x.
Proof.
now intros nan [s|s| |s m e H].
Qed.

Lemma is_finite_BSN2B :
  forall nan x, is_finite (BSN2B nan x) = BSN.is_finite x.
Proof.
now intros nan [s|s| |s m e H].
Qed.

Lemma is_nan_BSN2B :
  forall nan x, is_nan (BSN2B nan x) = BSN.is_nan x.
Proof.
now intros nan [s|s| |s m e H].
Qed.

Lemma Bsign_B2BSN :
  forall x, is_nan x = false -> BSN.Bsign (B2BSN x) = Bsign x.
Proof.
now intros [s|s| |s m e H].
Qed.

Lemma Bsign_BSN2B :
  forall nan x, BSN.is_nan x = false ->
  Bsign (BSN2B nan x) = BSN.Bsign x.
Proof.
now intros nan [s|s| |s m e H].
Qed.

Definition BSN2B' (x : BSN.binary_float prec emax) : BSN.is_nan x = false -> binary_float.
Proof.
destruct x as [sx|sx| |sx mx ex Bx] ; intros H.
exact (B754_zero sx).
exact (B754_infinity sx).
now elim Bool.diff_true_false.
exact (B754_finite sx mx ex Bx).
Defined.

Lemma B2BSN_BSN2B' :
  forall x Nx,
  B2BSN (BSN2B' x Nx) = x.
Proof.
now intros [s|s| |s m e H] Nx.
Qed.

Lemma B2R_BSN2B' :
  forall x Nx,
  B2R (BSN2B' x Nx) = BSN.B2R x.
Proof.
now intros [sx|sx| |sx mx ex Bx] Nx.
Qed.

Lemma B2FF_BSN2B' :
  forall x Nx,
  B2FF (BSN2B' x Nx) = SF2FF (BSN.B2SF x).
Proof.
now intros [sx|sx| |sx mx ex Bx] Nx.
Qed.

Lemma Bsign_BSN2B' :
  forall x Nx,
  Bsign (BSN2B' x Nx) = BSN.Bsign x.
Proof.
now intros [sx|sx| |sx mx ex Bx] Nx.
Qed.

Lemma is_finite_BSN2B' :
  forall x Nx,
  is_finite (BSN2B' x Nx) = BSN.is_finite x.
Proof.
now intros [sx|sx| |sx mx ex Bx] Nx.
Qed.

Lemma is_nan_BSN2B' :
  forall x Nx,
  is_nan (BSN2B' x Nx) = false.
Proof.
now intros [sx|sx| |sx mx ex Bx] Nx.
Qed.

Definition erase (x : binary_float) : binary_float.
Proof.
destruct x as [s|s|s pl H|s m e H].
- exact (B754_zero s).
- exact (B754_infinity s).
- apply (B754_nan s pl).
  destruct nan_pl.
  apply eq_refl.
  exact H.
- apply (B754_finite s m e).
  destruct bounded.
  apply eq_refl.
  exact H.
Defined.

Theorem erase_correct :
  forall x, erase x = x.
Proof.
destruct x as [s|s|s pl H|s m e H] ; try easy ; simpl.
- apply f_equal, eqbool_irrelevance.
- apply f_equal, eqbool_irrelevance.
Qed.

(** Opposite *)

Definition Bopp opp_nan x :=
  match x with
  | B754_nan _ _ _ => build_nan (opp_nan x)
  | B754_infinity sx => B754_infinity (negb sx)
  | B754_finite sx mx ex Hx => B754_finite (negb sx) mx ex Hx
  | B754_zero sx => B754_zero (negb sx)
  end.

Theorem Bopp_involutive :
  forall opp_nan x,
  is_nan x = false ->
  Bopp opp_nan (Bopp opp_nan x) = x.
Proof.
now intros opp_nan [sx|sx|sx plx|sx mx ex Hx] ; simpl ; try rewrite Bool.negb_involutive.
Qed.

Theorem B2R_Bopp :
  forall opp_nan x,
  B2R (Bopp opp_nan x) = (- B2R x)%R.
Proof.
intros opp_nan [sx|sx|sx plx Hplx|sx mx ex Hx]; apply sym_eq ; try apply Ropp_0.
simpl.
rewrite <- F2R_opp.
now case sx.
Qed.

Theorem is_finite_Bopp :
  forall opp_nan x,
  is_finite (Bopp opp_nan x) = is_finite x.
Proof.
now intros opp_nan [| | |].
Qed.

Lemma Bsign_Bopp :
  forall opp_nan x, is_nan x = false -> Bsign (Bopp opp_nan x) = negb (Bsign x).
Proof. now intros opp_nan [s|s|s pl H|s m e H]. Qed.

(** Absolute value *)

Definition Babs abs_nan (x : binary_float) : binary_float :=
  match x with
  | B754_nan _ _ _ => build_nan (abs_nan x)
  | B754_infinity sx => B754_infinity false
  | B754_finite sx mx ex Hx => B754_finite false mx ex Hx
  | B754_zero sx => B754_zero false
  end.

Theorem B2R_Babs :
  forall abs_nan x,
  B2R (Babs abs_nan x) = Rabs (B2R x).
Proof.
  intros abs_nan [sx|sx|sx plx Hx|sx mx ex Hx]; apply sym_eq ; try apply Rabs_R0.
  simpl. rewrite <- F2R_abs. now destruct sx.
Qed.

Theorem is_finite_Babs :
  forall abs_nan x,
  is_finite (Babs abs_nan x) = is_finite x.
Proof.
  now intros abs_nan [| | |].
Qed.

Theorem Bsign_Babs :
  forall abs_nan x,
  is_nan x = false ->
  Bsign (Babs abs_nan x) = false.
Proof.
  now intros abs_nan [| | |].
Qed.

Theorem Babs_idempotent :
  forall abs_nan (x: binary_float),
  is_nan x = false ->
  Babs abs_nan (Babs abs_nan x) = Babs abs_nan x.
Proof.
  now intros abs_nan [sx|sx|sx plx|sx mx ex Hx].
Qed.

Theorem Babs_Bopp :
  forall abs_nan opp_nan x,
  is_nan x = false ->
  Babs abs_nan (Bopp opp_nan x) = Babs abs_nan x.
Proof.
  now intros abs_nan opp_nan [| | |].
Qed.

(** Comparison

[Some c] means ordered as per [c]; [None] means unordered. *)

Definition Bcompare (f1 f2 : binary_float) : option comparison :=
  BSN.Bcompare (B2BSN f1) (B2BSN f2).

Theorem Bcompare_correct :
  forall f1 f2,
  is_finite f1 = true -> is_finite f2 = true ->
  Bcompare f1 f2 = Some (Rcompare (B2R f1) (B2R f2)).
Proof.
  intros f1 f2 H1 H2.
  unfold Bcompare.
  rewrite BSN.Bcompare_correct.
  now rewrite 2!B2R_B2BSN.
  now rewrite is_finite_B2BSN.
  now rewrite is_finite_B2BSN.
Qed.

Theorem Bcompare_swap :
  forall x y,
  Bcompare y x = match Bcompare x y with Some c => Some (CompOpp c) | None => None end.
Proof.
  intros.
  apply BSN.Bcompare_swap.
Qed.

Theorem bounded_le_emax_minus_prec :
  forall mx ex,
  bounded mx ex = true ->
  (F2R (Float radix2 (Zpos mx) ex)
   <= bpow radix2 emax - bpow radix2 (emax - prec))%R.
Proof.
now apply BSN.bounded_le_emax_minus_prec.
Qed.

Theorem bounded_lt_emax :
  forall mx ex,
  bounded mx ex = true ->
  (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R.
Proof.
now apply bounded_lt_emax.
Qed.

Theorem bounded_ge_emin :
  forall mx ex,
  bounded mx ex = true ->
  (bpow radix2 emin <= F2R (Float radix2 (Zpos mx) ex))%R.
Proof.
now apply bounded_ge_emin.
Qed.

Theorem abs_B2R_le_emax_minus_prec :
  forall x,
  (Rabs (B2R x) <= bpow radix2 emax - bpow radix2 (emax - prec))%R.
Proof.
intros x.
rewrite <- B2R_B2BSN.
now apply abs_B2R_le_emax_minus_prec.
Qed.

Theorem abs_B2R_lt_emax :
  forall x,
  (Rabs (B2R x) < bpow radix2 emax)%R.
Proof.
intros x.
rewrite <- B2R_B2BSN.
now apply abs_B2R_lt_emax.
Qed.

Theorem abs_B2R_ge_emin :
  forall x,
  is_finite_strict x = true ->
  (bpow radix2 emin <= Rabs (B2R x))%R.
Proof.
intros x.
rewrite <- is_finite_strict_B2BSN.
rewrite <- B2R_B2BSN.
now apply abs_B2R_ge_emin.
Qed.

Theorem bounded_canonical_lt_emax :
  forall mx ex,
  canonical radix2 fexp (Float radix2 (Zpos mx) ex) ->
  (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R ->
  bounded mx ex = true.
Proof.
intros mx ex.
now apply bounded_canonical_lt_emax.
Qed.

(** Truncation *)

Notation shr_fexp := (shr_fexp prec emax) (only parsing).

Theorem shr_truncate :
  forall m e l,
  (0 <= m)%Z ->
  shr_fexp m e l =
  let '(m', e', l') := truncate radix2 fexp (m, e, l) in (shr_record_of_loc m' l', e').
Proof.
intros m e l.
now apply shr_truncate.
Qed.

(** Rounding modes *)

Definition binary_overflow m s :=
  SF2FF (binary_overflow prec emax m s).

Lemma eq_binary_overflow_FF2SF :
  forall x m s,
  FF2SF x = BSN.binary_overflow prec emax m s ->
  x = binary_overflow m s.
Proof.
intros x m s H.
unfold binary_overflow.
rewrite <- H.
apply eq_sym, SF2FF_FF2SF.
rewrite <- is_nan_FF2SF, H.
apply is_nan_binary_overflow.
Qed.

Definition binary_round_aux mode sx mx ex lx :=
  SF2FF (binary_round_aux prec emax mode sx mx ex lx).

Theorem binary_round_aux_correct' :
  forall mode x mx ex lx,
  (x <> 0)%R ->
  inbetween_float radix2 mx ex (Rabs x) lx ->
  (ex <= cexp radix2 fexp x)%Z ->
  let z := binary_round_aux mode (Rlt_bool x 0) mx ex lx in
  valid_binary z = true /\
  if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then
    FF2R radix2 z = round radix2 fexp (round_mode mode) x /\
    is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0
  else
    z = binary_overflow mode (Rlt_bool x 0).
Proof.
intros mode x mx ex lx Px Bx Ex.
generalize (binary_round_aux_correct' prec emax _ _ mode x mx ex lx Px Bx Ex).
unfold binary_round_aux.
destruct (Rlt_bool (Rabs _) _).
- now destruct BSN.binary_round_aux as [sz|sz| |sz mz ez].
- intros [_ ->].
  split.
  rewrite valid_binary_SF2FF by apply is_nan_binary_overflow.
  now apply binary_overflow_correct.
  easy.
Qed.

Theorem binary_round_aux_correct :
  forall mode x mx ex lx,
  inbetween_float radix2 (Zpos mx) ex (Rabs x) lx ->
  (ex <= fexp (Zdigits radix2 (Zpos mx) + ex))%Z ->
  let z := binary_round_aux mode (Rlt_bool x 0) (Zpos mx) ex lx in
  valid_binary z = true /\
  if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then
    FF2R radix2 z = round radix2 fexp (round_mode mode) x /\
    is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0
  else
    z = binary_overflow mode (Rlt_bool x 0).
Proof.
intros mode x mx ex lx Bx Ex.
generalize (binary_round_aux_correct prec emax _ _ mode x mx ex lx Bx Ex).
unfold binary_round_aux.
destruct (Rlt_bool (Rabs _) _).
- now destruct BSN.binary_round_aux as [sz|sz| |sz mz ez].
- intros [_ ->].
  split.
  rewrite valid_binary_SF2FF by apply is_nan_binary_overflow.
  now apply binary_overflow_correct.
  easy.
Qed.

(** Multiplication *)

Definition Bmult mult_nan m x y :=
  BSN2B (mult_nan x y) (Bmult m (B2BSN x) (B2BSN y)).

Theorem Bmult_correct :
  forall mult_nan m x y,
  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x * B2R y))) (bpow radix2 emax) then
    B2R (Bmult mult_nan m x y) = round radix2 fexp (round_mode m) (B2R x * B2R y) /\
    is_finite (Bmult mult_nan m x y) = andb (is_finite x) (is_finite y) /\
    (is_nan (Bmult mult_nan m x y) = false ->
      Bsign (Bmult mult_nan m x y) = xorb (Bsign x) (Bsign y))
  else
    B2FF (Bmult mult_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)).
Proof.
intros mult_nan mode x y.
generalize (Bmult_correct prec emax _ _ mode (B2BSN x) (B2BSN y)).
replace (BSN.Bmult _ _ _) with (B2BSN (Bmult mult_nan mode x y)) by apply B2BSN_BSN2B.
intros H.
destruct x as [sx|sx|sx plx Hplx|sx mx ex Hx] ;
  destruct y as [sy|sy|sy ply Hply|sy my ey Hy] ;
  try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ try easy | apply bpow_gt_0 | now auto with typeclass_instances ]).
revert H.
rewrite 2!B2R_B2BSN.
destruct Rlt_bool.
- now destruct Bmult.
- intros H.
  apply eq_binary_overflow_FF2SF.
  now rewrite FF2SF_B2FF, <- B2SF_B2BSN.
Qed.

(** Normalization and rounding *)

Definition shl_align_fexp mx ex :=
  shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex)).

Lemma shl_align_fexp_correct :
  forall mx ex,
  let (mx', ex') := shl_align_fexp mx ex in
  F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex') /\
  (ex' <= fexp (Zdigits radix2 (Zpos mx') + ex'))%Z.
Proof.
intros mx ex.
apply shl_align_fexp_correct.
Qed.

Definition binary_round m sx mx ex :=
  SF2FF (binary_round prec emax m sx mx ex).

Theorem binary_round_correct :
  forall m sx mx ex,
  let z := binary_round m sx mx ex in
  valid_binary z = true /\
  let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then
    FF2R radix2 z = round radix2 fexp (round_mode m) x /\
    is_finite_FF z = true /\
    sign_FF z = sx
  else
    z = binary_overflow m sx.
Proof.
intros mode sx mx ex.
generalize (binary_round_correct prec emax _ _ mode sx mx ex).
simpl.
unfold binary_round.
destruct Rlt_bool.
- now destruct BSN.binary_round.
- intros [H1 ->].
  split.
  rewrite valid_binary_SF2FF by apply is_nan_binary_overflow.
  now apply binary_overflow_correct.
  easy.
Qed.

Definition binary_normalize mode m e szero :=
  BSN2B' _ (is_nan_binary_normalize prec emax _ _ mode m e szero).

Theorem binary_normalize_correct :
  forall m mx ex szero,
  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)))) (bpow radix2 emax) then
    B2R (binary_normalize m mx ex szero) = round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)) /\
    is_finite (binary_normalize m mx ex szero) = true /\
    Bsign (binary_normalize m mx ex szero) =
      match Rcompare (F2R (Float radix2 mx ex)) 0 with
        | Eq => szero
        | Lt => true
        | Gt => false
      end
  else
    B2FF (binary_normalize m mx ex szero) = binary_overflow m (Rlt_bool (F2R (Float radix2 mx ex)) 0).
Proof.
intros mode mx ex szero.
generalize (binary_normalize_correct prec emax _ _ mode mx ex szero).
replace (BSN.binary_normalize _ _ _ _ _ _ _ _) with (B2BSN (binary_normalize mode mx ex szero)) by apply B2BSN_BSN2B'.
simpl.
destruct Rlt_bool.
- now destruct binary_normalize.
- intros H.
  apply eq_binary_overflow_FF2SF.
  now rewrite FF2SF_B2FF, <- B2SF_B2BSN.
Qed.

(** Addition *)

Definition Bplus plus_nan m x y :=
  BSN2B (plus_nan x y) (Bplus m (B2BSN x) (B2BSN y)).

Theorem Bplus_correct :
  forall plus_nan m x y,
  is_finite x = true ->
  is_finite y = true ->
  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x + B2R y))) (bpow radix2 emax) then
    B2R (Bplus plus_nan m x y) = round radix2 fexp (round_mode m) (B2R x + B2R y) /\
    is_finite (Bplus plus_nan m x y) = true /\
    Bsign (Bplus plus_nan m x y) =
      match Rcompare (B2R x + B2R y) 0 with
        | Eq => match m with mode_DN => orb (Bsign x) (Bsign y)
                                 | _ => andb (Bsign x) (Bsign y) end
        | Lt => true
        | Gt => false
      end
  else
    (B2FF (Bplus plus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = Bsign y).
Proof with auto with typeclass_instances.
intros plus_nan mode x y Fx Fy.
rewrite <- is_finite_B2BSN in Fx, Fy.
generalize (Bplus_correct prec emax _ _ mode _ _ Fx Fy).
replace (BSN.Bplus _ _ _) with (B2BSN (Bplus plus_nan mode x y)) by apply B2BSN_BSN2B.
rewrite 2!B2R_B2BSN.
rewrite (Bsign_B2BSN x) by (clear -Fx ; now destruct x).
rewrite (Bsign_B2BSN y) by (clear -Fy ; now destruct y).
destruct Rlt_bool.
- now destruct Bplus.
- intros [H1 H2].
  refine (conj _ H2).
  apply eq_binary_overflow_FF2SF.
  now rewrite FF2SF_B2FF, <- B2SF_B2BSN.
Qed.

(** Subtraction *)

Definition Bminus minus_nan m x y :=
  BSN2B (minus_nan x y) (Bminus m (B2BSN x) (B2BSN y)).

Theorem Bminus_correct :
  forall minus_nan m x y,
  is_finite x = true ->
  is_finite y = true ->
  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x - B2R y))) (bpow radix2 emax) then
    B2R (Bminus minus_nan m x y) = round radix2 fexp (round_mode m) (B2R x - B2R y) /\
    is_finite (Bminus minus_nan m x y) = true /\
    Bsign (Bminus minus_nan m x y) =
      match Rcompare (B2R x - B2R y) 0 with
        | Eq => match m with mode_DN => orb (Bsign x) (negb (Bsign y))
                                 | _ => andb (Bsign x) (negb (Bsign y)) end
        | Lt => true
        | Gt => false
      end
  else
    (B2FF (Bminus minus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = negb (Bsign y)).
Proof with auto with typeclass_instances.
intros minus_nan mode x y Fx Fy.
rewrite <- is_finite_B2BSN in Fx, Fy.
generalize (Bminus_correct prec emax _ _ mode _ _ Fx Fy).
replace (BSN.Bminus _ _ _) with (B2BSN (Bminus minus_nan mode x y)) by apply B2BSN_BSN2B.
rewrite 2!B2R_B2BSN.
rewrite (Bsign_B2BSN x) by (clear -Fx ; now destruct x).
rewrite (Bsign_B2BSN y) by (clear -Fy ; now destruct y).
destruct Rlt_bool.
- now destruct Bminus.
- intros [H1 H2].
  refine (conj _ H2).
  apply eq_binary_overflow_FF2SF.
  now rewrite FF2SF_B2FF, <- B2SF_B2BSN.
Qed.

(** Fused Multiply-Add *)

Definition Bfma_szero m (x y z : binary_float) :=
  Bfma_szero prec emax m (B2BSN x) (B2BSN y) (B2BSN z).

Definition Bfma fma_nan m (x y z: binary_float) :=
  BSN2B (fma_nan x y z) (Bfma m (B2BSN x) (B2BSN y) (B2BSN z)).

Theorem Bfma_correct:
  forall fma_nan m x y z,
  is_finite x = true ->
  is_finite y = true ->
  is_finite z = true ->
  let res := (B2R x * B2R y + B2R z)%R in
  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) res)) (bpow radix2 emax) then
    B2R (Bfma fma_nan m x y z) = round radix2 fexp (round_mode m) res /\
    is_finite (Bfma fma_nan m x y z) = true /\
    Bsign (Bfma fma_nan m x y z) =
      match Rcompare res 0 with
        | Eq => Bfma_szero m x y z
        | Lt => true
        | Gt => false
      end
  else
    B2FF (Bfma fma_nan m x y z) = binary_overflow m (Rlt_bool res 0).
Proof.
intros fma_nan mode x y z Fx Fy Fz.
rewrite <- is_finite_B2BSN in Fx, Fy, Fz.
generalize (Bfma_correct prec emax _ _ mode _ _ _ Fx Fy Fz).
replace (BSN.Bfma _ _ _ _) with (B2BSN (Bfma fma_nan mode x y z)) by apply B2BSN_BSN2B.
rewrite 3!B2R_B2BSN.
cbv zeta.
destruct Rlt_bool.
- now destruct Bfma.
- intros H.
  apply eq_binary_overflow_FF2SF.
  now rewrite FF2SF_B2FF, <- B2SF_B2BSN.
Qed.

(** Division *)

Definition Bdiv div_nan m x y :=
  BSN2B (div_nan x y) (Bdiv m (B2BSN x) (B2BSN y)).

Theorem Bdiv_correct :
  forall div_nan m x y,
  B2R y <> 0%R ->
  if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x / B2R y))) (bpow radix2 emax) then
    B2R (Bdiv div_nan m x y) = round radix2 fexp (round_mode m) (B2R x / B2R y) /\
    is_finite (Bdiv div_nan m x y) = is_finite x /\
    (is_nan (Bdiv div_nan m x y) = false ->
      Bsign (Bdiv div_nan m x y) = xorb (Bsign x) (Bsign y))
  else
    B2FF (Bdiv div_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)).
Proof.
intros div_nan mode x y Zy.
rewrite <- B2R_B2BSN in Zy.
generalize (Bdiv_correct prec emax _ _ mode (B2BSN x) _ Zy).
replace (BSN.Bdiv _ _ _) with (B2BSN (Bdiv div_nan mode x y)) by apply B2BSN_BSN2B.
unfold Rdiv.
destruct y as [sy|sy|sy ply|sy my ey Hy] ; try now elim Zy.
destruct x as [sx|sx|sx plx Hx|sx mx ex Hx] ;
  try ( simpl ; rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | auto with typeclass_instances ] ).
destruct Rlt_bool.
- now destruct Bdiv.
- intros H.
  apply eq_binary_overflow_FF2SF.
  now rewrite FF2SF_B2FF, <- B2SF_B2BSN.
Qed.

(** Square root *)

Definition Bsqrt sqrt_nan m x :=
  BSN2B (sqrt_nan x) (Bsqrt m (B2BSN x)).

Theorem Bsqrt_correct :
  forall sqrt_nan m x,
  B2R (Bsqrt sqrt_nan m x) = round radix2 fexp (round_mode m) (sqrt (B2R x)) /\
  is_finite (Bsqrt sqrt_nan m x) = match x with B754_zero _ => true | B754_finite false _ _ _ => true | _ => false end /\
  (is_nan (Bsqrt sqrt_nan m x) = false -> Bsign (Bsqrt sqrt_nan m x) = Bsign x).
Proof.
intros sqrt_nan mode x.
generalize (Bsqrt_correct prec emax _ _ mode (B2BSN x)).
replace (BSN.Bsqrt _ _) with (B2BSN (Bsqrt sqrt_nan mode x)) by apply B2BSN_BSN2B.
intros H.
destruct x as [sx|[|]|sx plx Hplx|sx mx ex Hx] ; try easy.
now destruct Bsqrt.
Qed.

(** A few values *)

Definition Bone :=
  BSN2B' _ (@is_nan_Bone prec emax _ _).

Theorem Bone_correct : B2R Bone = 1%R.
Proof.
unfold Bone.
rewrite B2R_BSN2B'.
apply Bone_correct.
Qed.

Lemma is_finite_Bone : is_finite Bone = true.
Proof.
unfold Bone.
rewrite is_finite_BSN2B'.
apply is_finite_Bone.
Qed.

Lemma Bsign_Bone : Bsign Bone = false.
Proof.
unfold Bone.
rewrite Bsign_BSN2B'.
apply Bsign_Bone.
Qed.

Definition Bmax_float :=
  BSN2B' Bmax_float eq_refl.

(** Extraction/modification of mantissa/exponent *)

Definition Bnormfr_mantissa x :=
  Bnormfr_mantissa (B2BSN x).

Definition lift x y (Ny : @BSN.is_nan prec emax y = is_nan x) : binary_float.
Proof.
destruct (is_nan x).
exact x.
now apply (BSN2B' y).
Defined.

Lemma B2BSN_lift :
  forall x y Ny,
  B2BSN (lift x y Ny) = y.
Proof.
intros x y Ny.
unfold lift.
destruct x as [sx|sx|sx px Px|sx mx ex Bx] ; simpl ; try apply B2BSN_BSN2B'.
now destruct y.
Qed.

Definition Bldexp (mode : mode) (x : binary_float) (e : Z) : binary_float.
Proof.
apply (lift x (Bldexp mode (B2BSN x) e)).
rewrite <- is_nan_B2BSN.
apply is_nan_Bldexp.
Defined.

Theorem Bldexp_correct :
  forall m (f : binary_float) e,
  if Rlt_bool
       (Rabs (round radix2 fexp (round_mode m) (B2R f * bpow radix2 e)))
       (bpow radix2 emax) then
    (B2R (Bldexp m f e)
     = round radix2 fexp (round_mode m) (B2R f * bpow radix2 e))%R /\
    is_finite (Bldexp m f e) = is_finite f /\
    Bsign (Bldexp m f e) = Bsign f
  else
    B2FF (Bldexp m f e) = binary_overflow m (Bsign f).
Proof.
intros mode x e.
generalize (Bldexp_correct prec emax _ _ mode (B2BSN x) e).
replace (BSN.Bldexp _ _ _) with (B2BSN (Bldexp mode x e)) by apply B2BSN_lift.
rewrite B2R_B2BSN.
destruct Rlt_bool.
- destruct x as [sx|sx|sx px Px|sx mx ex Bx] ; try easy.
  now destruct Bldexp.
- intros H.
  apply eq_binary_overflow_FF2SF.
  rewrite B2SF_B2BSN in H.
  rewrite FF2SF_B2FF, H.
  destruct x as [sx|sx|sx px Px|sx mx ex Bx] ; simpl in H ; try easy.
  contradict H.
  unfold BSN.binary_overflow.
  now destruct overflow_to_inf.
Qed.

Section Bfrexp.

(** This hypothesis is needed to implement [Bfrexp]
    (otherwise, we have emin > - prec
     and [Bfrexp] cannot fit the mantissa in interval #[0.5, 1)#) *)
Hypothesis Hemax : (2 < emax)%Z.

Definition Bfrexp (x : binary_float) : binary_float * Z.
Proof.
set (y := Bfrexp (B2BSN x)).
refine (pair _ (snd y)).
apply (lift x (fst y)).
rewrite <- is_nan_B2BSN.
apply is_nan_Bfrexp.
Defined.

Theorem Bfrexp_correct :
  forall f,
  is_finite_strict f = true ->
  let x := B2R f in
  let z := fst (Bfrexp f) in
  let e := snd (Bfrexp f) in
  (/2 <= Rabs (B2R z) < 1)%R /\
  (x = B2R z * bpow radix2 e)%R /\
  e = mag radix2 x.
Proof.
intros x Fx.
rewrite <- is_finite_strict_B2BSN in Fx.
generalize (Bfrexp_correct prec emax _ (B2BSN x) Fx).
simpl.
rewrite <- B2R_B2BSN.
rewrite B2BSN_lift.
destruct BSN.Bfrexp as [z e].
rewrite B2R_B2BSN.
now intros [H1 [H2 H3]].
Qed.

End Bfrexp.

(** Ulp *)

Definition Bulp (x : binary_float) : binary_float.
Proof.
apply (lift x (Bulp (B2BSN x))).
rewrite <- is_nan_B2BSN.
apply is_nan_Bulp.
Defined.

Theorem Bulp_correct :
  forall x,
  is_finite x = true ->
  B2R (Bulp x) = ulp radix2 fexp (B2R x) /\
  is_finite (Bulp x) = true /\
  Bsign (Bulp x) = false.
Proof.
intros x Fx.
rewrite <- is_finite_B2BSN in Fx.
generalize (Bulp_correct prec emax _ _ _ Fx).
replace (BSN.Bulp (B2BSN x)) with (B2BSN (Bulp x)) by apply B2BSN_lift.
rewrite 2!B2R_B2BSN.
now destruct Bulp.
Qed.

(** Successor (and predecessor) *)

Definition Bsucc (x : binary_float) : binary_float.
Proof.
apply (lift x (Bsucc (B2BSN x))).
rewrite <- is_nan_B2BSN.
apply is_nan_Bsucc.
Defined.

Lemma Bsucc_correct :
  forall x,
  is_finite x = true ->
  if Rlt_bool (succ radix2 fexp (B2R x)) (bpow radix2 emax) then
    B2R (Bsucc x) = succ radix2 fexp (B2R x) /\
    is_finite (Bsucc x) = true /\
    (Bsign (Bsucc x) = Bsign x && is_finite_strict x)%bool
  else
    B2FF (Bsucc x) = F754_infinity false.
Proof.
intros x Fx.
rewrite <- is_finite_B2BSN in Fx.
generalize (Bsucc_correct prec emax _ _ _ Fx).
replace (BSN.Bsucc (B2BSN x)) with (B2BSN (Bsucc x)) by apply B2BSN_lift.
rewrite 2!B2R_B2BSN.
destruct Rlt_bool.
- rewrite (Bsign_B2BSN x) by now destruct x.
  rewrite is_finite_strict_B2BSN.
  now destruct Bsucc.
- now destruct Bsucc as [|[|]| |].
Qed.

Definition Bpred (x : binary_float) : binary_float.
Proof.
apply (lift x (Bpred (B2BSN x))).
rewrite <- is_nan_B2BSN.
apply is_nan_Bpred.
Defined.

Lemma Bpred_correct :
  forall x,
  is_finite x = true ->
  if Rlt_bool (- bpow radix2 emax) (pred radix2 fexp (B2R x)) then
    B2R (Bpred x) = pred radix2 fexp (B2R x) /\
    is_finite (Bpred x) = true /\
    (Bsign (Bpred x) = Bsign x || negb (is_finite_strict x))%bool
  else
    B2FF (Bpred x) = F754_infinity true.
Proof.
intros x Fx.
rewrite <- is_finite_B2BSN in Fx.
generalize (Bpred_correct prec emax _ _ _ Fx).
replace (BSN.Bpred (B2BSN x)) with (B2BSN (Bpred x)) by apply B2BSN_lift.
rewrite 2!B2R_B2BSN.
destruct Rlt_bool.
- rewrite (Bsign_B2BSN x) by now destruct x.
  rewrite is_finite_strict_B2BSN.
  now destruct Bpred.
- now destruct Bpred as [|[|]| |].
Qed.

End Binary.


Require Import Coq.Lists.List.
From TypeClasses Require Export Applicative Foldable.

Lemma fapp_compose :
  forall {F : Type -> Type} `{Applicative F} {A B C : Type}
    (f : A -> B) (h : B -> C),
    fapp (pure (h ∘ f)) = fapp (pure h) ∘ fapp (pure f).
Proof.
  intros. repeat rewrite <- app_fmap_pure.
  apply fmap_compose.
Qed.

Lemma fapp_compose_unfolded :
  forall {F : Type -> Type} `{FA : Applicative F} {A B C : Type}
    (f : A -> B) (h : B -> C) (t : F A),
    fapp (pure (fun a => h (f a))) t = fapp (pure h) ((fapp (pure f)) t).
Proof.
  intros. pose proof fapp_compose f h as H.
  unfold compose in H. rewrite H. reflexivity.
Qed.

(** * The Traversable Type Class *)
Class Traversable (T : Type -> Type) :=
  { Traversable_Applicative :> Applicative T;
    Traversable_Foldable :> Foldable T;
    traverse : forall {F : Type -> Type} `{Applicative F}
                 {A B : Type}, (A -> F B) -> T A -> F (T B);
    (** Laws. *)
    traverse_id : forall {A : Type},
        @traverse (fun X : Type => X) IdentityApplicative _ _
                  (fun a : A => a) = fun t : T A => t;
    traverse_compose :
      forall {Q R : Type -> Type} `{Applicative Q} `{Applicative R}
        {A B C : Type} (f : A -> Q B) (h : B -> R C),
        @traverse (Q ∘ R) _ _ _ (@fmap Q _ B (R C) h ∘ f) =
        @fmap Q _ (T B) (R (T C)) (@traverse R _ B C h) ∘ (@traverse Q _ A B f) }.
(**[]*)

Module Type TraversableSpec.
  (** The Traversable. *)
  Parameter T : Type -> Type.

  (** Applicative Requirement. *)
  Parameter TApplicative : Applicative T.

  (** Foldable Requirement. *)
  Parameter TFoldable : Foldable T.

  Parameter traverse : forall {F : Type -> Type} `{Applicative F}
                         {A B : Type}, (A -> F B) -> T A -> F (T B).
  (**[]*)

  (** Laws. *)

  (** The "identity" traversal. *)
  Parameter traverse_id : forall {A : Type},
      @traverse (fun X => X) IdentityApplicative _ _
                (fun a : A => a) = fun t : T A => t.
  (**[]*)

  (** Traversals compose. *)
  Parameter traverse_compose :
    forall {Q R : Type -> Type} `{Applicative Q} `{Applicative R}
      {A B C : Type} (f : A -> Q B) (h : B -> R C),
      @traverse (Q ∘ R) _ _ _ (@fmap Q _ B (R C) h ∘ f) =
      @fmap Q _ (T B) (R (T C)) (@traverse R _ B C h) ∘ (@traverse Q _ A B f).
  (**[]*)
End TraversableSpec.

Module TraversableFactory (TS : TraversableSpec).
  Instance TApplicative : Applicative TS.T := TS.TApplicative.
  Instance TFoldable : Foldable TS.T := TS.TFoldable.

  Instance TraversableInstance : Traversable TS.T :=
  { traverse := @TS.traverse;
    traverse_id := @TS.traverse_id;
    traverse_compose := @TS.traverse_compose }.
End TraversableFactory.

(** Identity. *)
Module IdentityTraversableSpec <: TraversableSpec.
  Definition T : Type -> Type := (fun X => X).

  Definition TApplicative : Applicative T := IdentityApplicative.

  Definition TFoldable : Foldable T := IdentityFoldable.

  Definition traverse {F : Type -> Type} `{Applicative F}
             {A B : Type} (f : A -> F B) : A -> F B := f.
  (**[]*)

  Lemma traverse_id : forall {A : Type},
      @traverse (fun X => X) IdentityApplicative _ _
                (fun a : A => a) = (fun a : A => a).
  Proof. intros. reflexivity. Qed.
  (**[]*)

  Lemma traverse_compose :
    forall {Q R : Type -> Type} `{Applicative Q} `{Applicative R}
      {A B C : Type} (f : A -> Q B) (h : B -> R C),
      @traverse (Q ∘ R) _ _ _ (@fmap Q _ B (R C) h ∘ f) =
      @fmap Q _ B (R C) (@traverse R _ B C h) ∘ (@traverse Q _ A B f).
    Proof. intros. reflexivity. Qed.
  (**[]*)
End IdentityTraversableSpec.

Module IdentityTraversableFactory := TraversableFactory IdentityTraversableSpec.
Instance IdentityTraversable : Traversable (fun X => X) :=
  IdentityTraversableFactory.TraversableInstance.
(**[]*)

(** Option. *)
Module OptionTraversableSpec <: TraversableSpec.
  Definition T : Type -> Type := option.

  Instance TApplicative : Applicative option := OptionApplicative.

  Instance TFoldable : Foldable option := OptionFoldable.

  Definition traverse {F : Type -> Type} `{Applicative F} {A B : Type}
             (f : A -> F B) (o : option A) : F (option B) :=
    match o with
    | None   => pure None
    | Some a => Some <$> f a
    end.
  (**[]*)

  Lemma traverse_id : forall {A : Type},
      @traverse (fun X => X) IdentityApplicative _ _
                (fun a : A => a) = (fun o : option A => o).
  Proof. intros. extensionality o. destruct o; auto. Qed.

  Lemma traverse_compose :
    forall {Q R : Type -> Type} `{Applicative Q} `{Applicative R}
      {A B C : Type} (f : A -> Q B) (h : B -> R C),
      @traverse (Q ∘ R) _ _ _ (@fmap Q _ B (R C) h ∘ f) =
      @fmap Q _ (option B) (R (option C))
            (@traverse R _ B C h) ∘ (@traverse Q _ A B f).
  Proof.
    intros. extensionality o. destruct o; simpl.
    - unfold fmapc. unfold compose. cbn.
      repeat rewrite app_fmap_pure.
      repeat rewrite app_composition. apply f_2_arg.
      repeat rewrite app_homomorphism. unfold compose.
      unfold traverse. rewrite app_fmap_pure. reflexivity.
    - unfold purec. unfold compose. cbn.
      rewrite app_fmap_pure. rewrite app_homomorphism.
      reflexivity.
  Qed.
End OptionTraversableSpec.

Module OptionTraversableFactory := TraversableFactory OptionTraversableSpec.
Instance OptionTraversable : Traversable option :=
  OptionTraversableFactory.TraversableInstance.
(**[]*)

(** Lists. *)
Module ListTraversableSpec <: TraversableSpec.
  Import Coq.Lists.List.
  Import ListNotations.

  Definition T : Type -> Type := list.

  Definition TApplicative : Applicative list := ListApplicative.

  Definition TFoldable : Foldable list := ListFoldable.

  Fixpoint traverse {F : Type -> Type} `{Applicative F}
           {A B : Type} (f : A -> F B) (l : list A) : F (list B) :=
    match l with
    | []    => pure []
    | a :: l => cons <$> f a <*> traverse f l
    end.
  (**[]*)

  Lemma traverse_id : forall {A : Type},
      @traverse (fun X => X) IdentityApplicative _ _
                (fun a : A => a) = fun t : list A => t.
  Proof.
    intros. extensionality t.
    induction t as [| h t IHt]; simpl; auto.
    rewrite IHt. reflexivity.
  Qed.
  (**[]*)

  (** This is true in my heart of hearts. *)
  Axiom switch_fun_args_app :
    forall {F : Type -> Type} `{Applicative F}
      {A B C : Type} (f : A -> B -> C) (a : F A) (b : F B),
      (fun x y => f x y) <$> a <*> b = (fun y x => f x y) <$> b <*> a.

  (** Traversals compose. *)
  Lemma traverse_compose :
    forall {Q R : Type -> Type} `{QA : Applicative Q} `{RA : Applicative R}
      {A B C : Type} (f : A -> Q B) (h : B -> R C),
      @traverse (Q ∘ R) _ _ _ (@fmap Q _ B (R C) h ∘ f) =
      @fmap Q _ (list B) (R (list C)) (@traverse R _ B C h) ∘ (@traverse Q _ A B f).
  Proof.
    intros. extensionality t.
    induction t as [| a t IHt]; simpl.
    - unfold purec. unfold compose. cbn.
      rewrite app_fmap_pure. rewrite app_homomorphism.
      reflexivity.
    - rewrite IHt; clear IHt.
      unfold fappc, fmapc. unfold compose. cbn.
      repeat rewrite app_fmap_pure.
      rewrite app_composition with (h0 := pure (fapp (pure cons))).
      rewrite app_composition with (h0 := pure (traverse h)).
      rewrite app_composition with (f0 := pure (traverse h)).
      rewrite app_composition with (h0 := pure fapp).
      apply f_2_arg. clear t. repeat rewrite app_homomorphism.
      repeat rewrite app_composition with (a0 := f a).
      repeat rewrite app_homomorphism.
      repeat rewrite fapp_compose. unfold compose.
      rewrite app_composition with (f0 := pure cons).
      rewrite app_composition with (f0 := pure h). rewrite app_composition.
      repeat rewrite app_homomorphism. unfold compose. cbn.
      rewrite app_fmap_pure. rewrite app_composition.
      repeat rewrite app_homomorphism. unfold compose.
      repeat rewrite <- app_fmap_pure.
      pose proof switch_fun_args_app
          (fun x y a1 => cons <$> h x <*> y a1) (f a) (pure (traverse h)) as H.
      simpl in H. rewrite H. rewrite app_fmap_pure.
      rewrite app_homomorphism. rewrite <- app_fmap_pure. reflexivity.
  Qed.
End ListTraversableSpec.

Module ListTraversableFactory := TraversableFactory ListTraversableSpec.
Instance ListTraversable : Traversable list :=
  ListTraversableFactory.TraversableInstance.
(**[]*)


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From libs Require Import edone bcase fset base sltype.
Require Import K_def.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Arguments subsep {T X P}.

Implicit Types (S cls X Y : {fset clause}) (C D : clause).

(** * Demos *)

(** A demo consists of a finite set of clauses that satisfy the demo
conditions. We do not enfoce that that the demo contains only literal
clauses. However, non-literal clauses do not change the support of a
clause and therefore also need not be satisfied by the construced
model (See [supp_eval]). *)

Definition D0 cls := forall C, C \in cls -> lcons C.
Definition D1 cls := forall C, C \in cls -> forall s, fAX s^- \in C -> suppS cls (s^- |` R C).

Record demo := Demo
{
  cls :> {fset clause} ;
  demoD0 : D0 cls ;
  demoD1 : D1 cls
}.

Arguments demoD1 [d C] _ [s] _.

Canonical demo_predType := PredType (fun (S : demo) (C : clause) => nosimpl C \in cls S).

Lemma LCF C : lcons C ->
  ((fF^+ \in C) = false) * (forall p, (fV p^+ \in C) && (fV p^- \in C) = false).
Proof.
  move => /andP [/negbTE-> /allP H]. split => // p.
  case e: (_^+ \in _) => //=. by rewrite (negbTE (H _ e)).
Qed.

(** ** Model Existence *)

Definition rtrans C D := suppC D (R C).

Section ModelExistience.
  Variables (S : demo).

  Definition Mtype := seq_sub S.
  Definition Mtrans : rel Mtype := @restrict _ S rtrans.
  Definition Mlabel (p:var) (C : Mtype) := fV p^+ \in val C.

  Definition model_of := FModel Mtrans Mlabel.

  Implicit Types (x y : model_of).

  Lemma supp_eval s x : val x |> s -> eval (interp s) x.
  Proof.
    case: s x. elim => [|p|s IHs t IHt|s IHs] [|] x.
    - by rewrite /= (LCF (demoD0 (ssvalP x))).
    - by rewrite /=.
    - done.
    - rewrite /= /Mlabel. case: (LCF (demoD0 (ssvalP x))) => [_ /(_ p)].
      by case: (_^+ \in _) => //= ->.
    - rewrite /=. case/orP => [/IHs|/IHt] /=; tauto.
    - rewrite /=. case/andP => [/IHs ? /IHt] /=; tauto.
    - move => inX y xy. apply: (IHs true).
      rewrite -suppC1. apply: suppC_sub xy. by rewrite fsub1 RE.
    - rewrite [_ |> _]/= => H. case/hasP : (demoD1 (ssvalP x) H) => D inS.
      rewrite suppCU suppC1 => /andP [D1 D2] /= /(_ (Sub D inS)) /(_ D2).
      exact: (IHs false).
  Qed.

End ModelExistience.

(** ** Pruning *)

Section Pruning.
  Variables (F : clause).
  Hypothesis sfc_F : sf_closed F.

  Definition U := powerset F.
  Definition S0 := [fset C in U | literalC C && lcons C].

  Definition pcond C S :=
    ~~ [all u in C, if u is fAX s^- then suppS S (s^- |` R C) else true].

  (** Pruning yields a demo *)

  Lemma prune_D0 : D0 (prune pcond S0).
  Proof. move => C. move/(subP (prune_sub _ _)). rewrite inE. bcase. Qed.

  Lemma prune_D1 : D1 (prune pcond S0).
  Proof. move => C /pruneE. rewrite negbK => /allP H s inC. exact: (H _ inC). Qed.

  Definition DD := Demo prune_D0 prune_D1.

  (** Note: in contrast to the mathematical text the pruning function uses [pcond C S]
  as pruning rules rather than [~~ pcond C S] *)

  (** ** Refutation Predicates and corefutability of the pruning demo *)

  Definition coref (ref : clause -> Prop) S :=
    forall C, C \in S0 `\` S -> ref C.

  Inductive ref : clause -> Prop :=
  | R1 S C : C \in U -> coref ref S -> ~~ suppS S C -> ref C
  | R2 C s : ref (s^- |` R C) -> ref (fAX s^- |` C).

  Lemma corefD1 S C : ref C -> coref ref S -> coref ref (S `\` [fset C]).
  Proof.
    move => rC coS D. rewrite !in_fsetD negb_and andb_orr -in_fsetD negbK in_fset1.
    case/orP; first exact: coS. by case/andP => [_ /eqP->].
  Qed.

  Lemma R1inU C s : C \in U -> fAX s^- \in C -> s^- |` R C \in U.
  Proof.
    move => CinU inC. rewrite powersetU RinU // powersetE fsub1 andbT.
    rewrite powersetE in CinU. by move/(subP CinU)/sfc_F : inC.
  Qed.

  (** The pruning demo is corefutable *)

  Lemma coref_DD : coref ref DD.
  Proof.
    apply: prune_myind => [C|C S]; first by rewrite inE andbN.
    - case/allPn. (do 2 case) => // s [//|] inC nS inS corefS subS0.
      apply: corefD1 (corefS).
      rewrite (fset1U inC). apply R2 => //. apply: R1 nS => //.
      move/(subP subS0)/(subP subsep): inS => inU. exact: R1inU.
  Qed.

  Lemma DD_refute C : C \in U -> ~~ suppS DD C -> ref C.
  Proof. move => inU. apply: R1 inU _  => //. exact: coref_DD. Qed.

End Pruning.

(** ** Refutation Completeness *)

Theorem refutation_completeness F (sfc_F : sf_closed F) C :
  C \in U F -> ref F C + exists2 M:fmodel, sat M C & #|{: M}| <= 2 ^ size F.
Proof.
  move => inU. case: (boolP (suppS (DD F) C)) => H; [right|left; exact: DD_refute].
  - exists (model_of (DD F)).
    case/hasP : H => D D1 D2. exists (SeqSub _ D1) => s /(allP D2) ?. exact: supp_eval.
  - rewrite card_seq_sub ?funiq // -powerset_size subset_size // /DD /=.
    exact: sub_trans (prune_sub _ _) (subsep).
Qed.


(** The [consider] tactic recovers some of the ease of reasoning about
 ** decision procedures when they are implemented as functions into bool.
 **
 ** Implementation by Thomas Braibant (thomas.braibant@gmail.com)
 **)
(*Require Setoid. *)

(** This file defines some inductives, type-classes and tactics to
perform reflection on a small scale *)

(** Two inductives to perform case-based reasonning *)
Inductive reflect (P Q : Prop) : bool -> Type :=
| reflect_true : P -> reflect P Q true
| reflect_false : Q -> reflect P Q false.

Inductive semi_reflect (P : Prop) : bool -> Type :=
| semi_reflect_true : P -> semi_reflect P true
| semi_reflect_false : semi_reflect P false.

Lemma iff_to_reflect {A B} (P : A -> B -> Prop) (T : A -> B -> bool)  :
  (forall x y, T x y = true <-> P x y) ->
  (forall x y, reflect (P x y) (~P x y) (T x y)).
Proof.
  intros. case_eq (T x y); intros Hxy; constructor.
  apply H. assumption.
  intros Hf. apply H in Hf. congruence.
Qed.

Lemma impl_to_semireflect {A B} (P : A -> B -> Prop) (T : A -> B -> bool)  :
  (forall x y, T x y = true -> P x y) ->
  (forall x y, semi_reflect (P x y) (T x y)).
Proof.
  intros. case_eq (T x y); intros Hxy; constructor.
  apply H; auto.
Qed.

Lemma reflect_true_inv P Q : reflect P Q true -> P.
Proof.
  exact (fun x => match x in reflect _ _ b
                    return if b then P else ID
                 with | reflect_true _ _ H => H | reflect_false _ _ H => (fun _ x => x) end).
Qed.

Lemma reflect_false_inv P Q : reflect P Q false -> Q.
Proof.
  exact (fun x => match x in reflect _ _ b
                    return if b then ID else Q
                 with | reflect_true _ _ H => fun _ x => x | reflect_false _ _ H => H end).
Qed.

Lemma semi_reflect_true_inv P : semi_reflect P true -> P.
Proof.
  exact (fun x => match x in semi_reflect _ b
                    return if b then P else ID
                 with | semi_reflect_true _ H => H | semi_reflect_false _ => (fun _ x => x) end).
Qed.

Class Reflect (T : bool) (P Q : Prop) := _Reflect : reflect P Q T.
Class SemiReflect (T : bool) (P : Prop) := _SemiReflect : semi_reflect P T.

Section boolean_logic.
  Ltac t :=
    repeat match goal with
           | H: Reflect true ?P ?Q |- _ => apply (reflect_true_inv P Q) in H
           | H: Reflect false ?P ?Q |- _ => apply (reflect_false_inv P Q) in H
           end.

  Context {T1 T2 P1 Q1 P2 Q2} {R1 : Reflect T1 P1 Q1} {R2: Reflect T2 P2 Q2}.

  Global Instance Reflect_andb : Reflect (T1 && T2)%bool (P1 /\ P2) (Q1 \/ Q2).
  Proof.
    destruct T1; destruct T2; t; constructor; tauto.
  Qed.

  Global Instance Reflect_orb : Reflect (T1 || T2)%bool (P1 \/ P2) (Q1 /\ Q2).
  Proof.
    destruct T1; destruct T2; t; constructor; tauto.
  Qed.

  Global Instance Reflect_negb : Reflect (negb T1)%bool Q1 P1.
  Proof.
    destruct T1; t; constructor; tauto.
  Qed.

End boolean_logic.

Require Import ExtLib.Core.RelDec.

Section from_rel_dec.
  Variable T : Type.
  Variable eqt : T -> T -> Prop.
  Variable rd : RelDec eqt.
  Variable rdc : RelDec_Correct rd.

  Global Instance Reflect_RelDecCorrect (a b : T)
  : Reflect (rel_dec a b) (eqt a b) (~(eqt a b)).
  Proof.
    eapply iff_to_reflect.
    eapply rel_dec_correct.
  Qed.
End from_rel_dec.

Hint Extern 10 (@Reflect (?f ?a ?b) _ _) =>
  eapply (@Reflect_RelDecCorrect _ _ (@Build_RelDec _ _ f) _) : typeclass_instances.

(** The main tactic. [consider f] will perform case-analysis (using
[case]) on the function symbol [f] using a reflection-lemma that is
inferred by type-class resolution. *)

Ltac consider f :=
  let rec clean :=
    match goal with
      | |- true = true -> _ => intros _ ; clean
      | |- false = true -> _ => discriminate
      | |- ?P1 -> ?P2 =>
        let H := fresh in intros H ; clean; revert H
      | |- _ => idtac
    end
  in
  (repeat match goal with
            | [ H : context [ f ] |- _ ] =>
              revert H
          end) ;
  match type of f with
    | sumbool _ _ =>
      destruct f
    | _ =>
      match goal with
        | _ =>
          ((let c := constr:(_ : Reflect f _ _) in
            case c)) (*;
            let H := fresh in
            intros H; try rewrite H; revert H)) *)
        | _ =>
          ((let c := constr:(_ : SemiReflect f _) in
            case c)) (*;
            let H := fresh in
            try (intros H; try rewrite H; revert H))) *)
        | _ =>
          (** default to remembering the equality **)
          case_eq f
      end
  end ; clean.