(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md descbrides the contents of each file and
   provides instructions to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* EXAMPLE FOR SECTION 6.2.1                                             *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import ListNotations.
Open Scope list_scope.

Inductive terminal: Type:=
| a
| b
| c.

Inductive non_terminal: Type:=
| X
| Y
| Z.

Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation nlist:= (list non_terminal).

Definition sf1: sf:= [inr a; inl X; inl Y; inr b].
Definition sf2: sf:= [].
Definition sentence1: sentence:= [a; a; b; c].
Definition sentence2: sentence:= [].
Definition nlist1: nlist:= [Z; Z; X].
Definition nlist2: nlist:= [].


From Mtac2 Require Import Datatypes List Mtac2.
Import Mtac2.lib.List.ListNotations.
Import T.

Require Import Bool.Bool.

Ltac induction n := induction n.

Definition qualify s := String.append "" s.

Definition induction {A} (n:A) : tactic := ltac (qualify "induction") [m:Dyn n].

Goal forall n:nat, 0 <= n.
MProof.
  intros n.
  induction n &> [m:apply le_n| apply le_S;; assumption].
Qed.

Goal forall m n:nat, 0 <= n.
MProof.
  intros m n.
  (* m shouldn't be in the list of hypotheses, as it is shared *)
  (\tactic g =>
   r <- induction n g;
   match r with
   | (m:_,AnyMetavar _ _ _) :m: _ => M.ret r
   | _ => M.raise exception
   end) &> [m:apply le_n| apply le_S;; assumption].
Qed.

Ltac myapply H := apply H.
Definition apply' := qualify "myapply".

Ltac remove H := clear H.
Definition remove := qualify "remove".

Goal forall P Q, (P -> Q) -> P -> Q.
MProof.
  intros P Q f x.
  apply f.
  ltac remove [m:Dyn f].
  exact x.
Qed.

Goal forall P Q, (P -> Q) -> P -> Q.
MProof.
  intros P Q f x.
  g <- select (_->_); ltac apply' [m:Dyn g] ;; assumption.
Qed.

Goal forall P Q, (P -> Q) -> P -> Q.
MProof.
  intros P Q.
  cintros f x {-
    ltac apply' [m:Dyn f] ;; ltac apply' [m:Dyn x]
  -}.
Qed.

Ltac injection x := injection x.

Goal forall n m,  S n = S m -> n = m.
MProof.
  intros n m H.
  ltac (qualify "injection") [m:Dyn H].
  trivial.
Qed.

(** Testing that we can chain ltac tactics that modify the context *)
Goal forall n m,  S n = S m -> n = m.
MProof.
  intros n m H.
  induction n &> induction m &> T.try trivial.
Abort.

Goal forall n m,  1 + n = S m -> n = m.
MProof.
  intros n m H.
  Ltac unf H := unfold Nat.add in H.
  ltac "unf" [m: Dyn H] &> (select (_ = _) >>= fun H' => ltac "injection" [m: Dyn H']).
  trivial.
Qed.


Require Import Coq.Strings.String.
Require Import Arith.EqNat.
Require Import ZArith.

Require Import Machine.

Require Import QuickChick EndToEnd SetOfOutcomes.

Require Import Common.
Require Import Printing.
Require Import Shrinking.
Require Import Generation.
Require Import Indist.
Require Import SSNI.

Require Import ssreflect ssrbool eqtype.

Require Import Show.

(* Possible steps according to SSNI_helper*)

(*

L ->  s1'
|     |    final states indistinguishable
L ->  s2'

L ->  s1'
|
L ->  x    no step for the second state

H -> L
|    |     final states indistinguishable
H -> L

H -> L
|        no condition here. Seems a bit strange.
H -> H

H -> H   high to high step. Requires no trace and the states before and
         after to be indistinguishable

*)

Definition propSSNI_prop (t : table) (v : Variation) : Prop :=
  let '(Var lab st1 st2) := v in
  (indist lab st1 st2) ->
  (is_low_state st1 lab /\ (forall tr1 st1' tr2 st2',
                          fstep t st1 = Some (tr1, st1') ->
                          fstep t st2 = Some (tr2, st2') ->
                          observe_comp (observe lab tr1) (observe lab tr2) /\
                          (indist lab st1' st2'))) \/
  (~~ is_low_state st1 lab /\ (forall tr1 st1',
                             fstep t st1 = Some (tr1, st1') ->
                             ((is_low_state st1' lab /\
                               forall tr2 st2',
                                 fstep t st2 = Some (tr2, st2') ->
                                 is_low_state st2' lab ->
                                 observe_comp (observe lab tr1) (observe lab tr2) /\
                                 (indist lab st1' st2')) \/
                              (~~ is_low_state st1' lab /\
                               List.length (observe lab tr1) = 0%nat /\
                               indist lab st1 st1')))).

Definition propSSNI_bool (t : table) (v : Variation) : bool :=
    let '(Var lab st1 st2) := v in
    if indist lab st1 st2 then
      match fstep t st1  with
        | Some (tr1, st1') =>
          if is_low_state st1 lab then
            match fstep t st2 with
              | Some (tr2, st2') =>
                (observe_comp (observe lab tr1) (observe lab tr2)
                              && (indist lab st1' st2'))
              | _ => true
            end
          else (* is_high st1 *)
            if is_low_state st1' lab then
              match fstep t st2 with
                | Some (tr2, st2') =>
                  if is_low_state st2' lab then
                    observe_comp (observe lab tr1) (observe lab tr2)
                                 && (indist lab st1' st2')
                  else true
                | _ => true
              end
            else
              beq_nat (List.length (observe lab tr1)) 0
                      && indist lab st1 st1'
        | _ => true
      end
    else true.

Lemma ssniP:
  forall (t : table) v,
    reflect (propSSNI_prop t v) (propSSNI_bool t v).
Proof.
  move=> t [lab st1 st2]. apply/(@iffP (propSSNI_bool t (Var lab st1 st2))); try (by apply idP);
  rewrite /propSSNI_bool /propSSNI_prop.
  { destruct (indist lab st1 st2) => //.
    destruct (fstep t st1) as [ [tr1' st1'] |].
    - destruct (is_low_state st1 lab).
      + destruct (fstep t st2) as [ [tr2' st2'] |];
        move => H _; left; split => //.
        move=> tr1_ st1'_ st2_ st2'_ [eq1 eq2] [eq3 eq4]; subst.
        by apply/andP.
      + move => H _. right. split => //.
        move=> tr1_ st1'_ [eq1 eq2]; subst.
        destruct (fstep t st2) as [[tr2' st2'] |].
        * destruct (is_low_state st1'_ lab).
          left. split => //. move => tr2_ st2'_ [eq1 eq2] H'; subst.
          destruct (is_low_state st2'_ lab); try congruence.
          by apply/andP.
          right. split=> //. move : H => /andP [H1 H2]. split => //.
          by apply beq_nat_eq.
        * destruct (is_low_state st1'_ lab). left. by split => //.
          right. split => //. move : H => /andP [H1 H2]. split => //.
          by apply beq_nat_eq.
    - move=> _ _. destruct (is_low_state st1 lab).
      + left. split => //.
      + right. split => //. }
  { destruct (indist lab st1 st2) => //. move => /(_ is_true_true) H.
    move: H => [[H1 H2] | [H1 H2]].
    - rewrite H1. destruct (fstep t st1) as [ [tr1' st1'] |] => //.
      destruct (fstep t st2) as [ [tr2' st2'] |] => //.
      apply/andP. by auto.
    - apply Bool.negb_true_iff  in H1. rewrite H1.
      destruct (fstep t st1) as [ [tr1' st1'] |] => //.
      move : H2 => /(_ _ _ Logic.eq_refl) [[H2 H3] | [H2 [H3 H4]]].
      + rewrite H2. destruct (fstep t st2) as [ [tr2' st2'] |] => //.
        move: H3 => /(_ _ _ Logic.eq_refl) H3.
        destruct (is_low_state st2' lab) => //. apply/andP; by auto.
      + apply Bool.negb_true_iff in H2. rewrite H2.
        apply/andP. split => //. by apply beq_nat_true_iff in H3. }
Qed.

Lemma propSSNI_helper_equiv:
  forall (t : table) v,
    semProperty (@propSSNI_helper Pred _ t v) <-> propSSNI_prop t v.
Proof.
  move=> t [lab st1 st2]. split; [move => H; apply/ssniP| move=> /ssniP H];
  rewrite /propSSNI_helper /propSSNI_bool /semTestable semCollect_id in H *.
  - move=> /semPredQProp H. destruct (indist lab st1 st2) => //.
    { destruct (fstep t st1) as [ [tr1' st1'] |] => //.
      destruct (is_low_state st1 lab).
      - destruct (fstep t st2) as [ [tr2' st2'] |] => //.
          by move/semCollect_id(*/semPredQProp
                 /semWhenFail_id*)/semBool : H => H.
      - destruct (is_low_state st1').
        + destruct (fstep t st2) as [[tr2 st2'] |] => //.
          destruct (is_low_state st2' lab).
            by move/semCollect_id(*/semPredQProp/semWhenFail_id*)/semBool : H.
            by move/semCollect_id/semPredQProp/semBool : H.
        + by move/semCollect_id(*/semPredQProp/semWhenFail_id*)/semBool : H. }
  -  move=> H.
     destruct (indist lab st1 st2);
       try by apply/semPredQProp/semCollect_id/semPredQProp/semBool.
    { destruct (fstep t st1) as [ [tr1' st1'] |].
      destruct (is_low_state st1 lab).
      - destruct (fstep t st2) as [ [tr2' st2'] |].
        by apply/semPredQProp/semCollect_id(*/semPredQProp/semWhenFail_id*)/semBool.
        by apply/semPredQProp/semCollect_id/semPredQProp/semBool.
      - destruct (is_low_state st1').
        + destruct (fstep t st2) as [[tr2 st2'] |].
          * destruct (is_low_state st2' lab).
            by apply/semPredQProp/semCollect_id(*/semPredQProp/semWhenFail_id*)/semBool.
            by apply/semPredQProp/semCollect_id/semPredQProp/semBool.
          * by apply/semPredQProp/semCollect_id/semPredQProp/semBool.
        + by apply/semPredQProp/semCollect_id(*/semPredQProp/semWhenFail_id*)/semBool.
      - by apply/semPredQProp/semCollect_id/semPredQProp/semBool. }
Qed.


Require Import Setoid Arith List Omega Coq.Program.Tactics decision types.
Require Import mlattice id_and_loc mmemory language LibTactics tactics.

Module TypeDefinitions (L: Lattice) (M: Memory L).
  Module MemProp := MemoryProperties L M.
  Import MemProp M T L Lang LatProp.

  Definition tenv  := id -> option sectype.

  Definition emptyTenv : tenv := fun _ => None.

  Inductive wf_type: level_proj1 -> sectype -> Prop :=
  | wf_type_int:
      forall ℓ l,
        wf_type ℓ (SecType Int l)
  | wf_type_array:
      forall ℓ l_p l_ref τ,
        wf_type l_p τ ->
        ℓ ⊑ l_p ->
        l_ref ⊑ l_p ->
        wf_type ℓ (SecType (Array τ l_p) (l_ref, ∘)).
  Hint Constructors wf_type.

  Ltac invert_wf_type :=
    match goal with
      [H: wf_type _ _ |- _] =>
      inverts H
    end.

  Definition wf_tenv (env : tenv) (m: Memory) :=
    (forall x lev v, memory_lookup m x = Some v ->
                env x = Some (SecType Int lev) ->
                exists n, v = ValNum n)
    /\
    (forall x lev t v l, memory_lookup m x = Some v ->
                    env x = Some (SecType (Array t l) lev) ->
                    exists loc, v = ValLoc loc) /\
    (forall τ x, env x = Some τ -> wf_type bot τ) /\
    (forall x v, memory_lookup m x = Some v ->
            exists t, env x = Some t).

  Lemma wf_tenv_proj1:
    forall Γ m x v lev,
      wf_tenv Γ m ->
      memory_lookup m x = Some v ->
      Γ x = Some (SecType Int lev) ->
      exists n, v = ValNum n.
  Proof.
    intros.
    edestruct H; eauto.
  Qed.
  Hint Resolve wf_tenv_proj1.

  Lemma wf_tenv_proj2:
    forall Γ m x lev t v l,
      wf_tenv Γ m ->
      memory_lookup m x = Some v ->
      Γ x = Some (SecType (Array t l) lev) ->
      exists loc, v = ValLoc loc.
  Proof.
    intros.
    edestruct H.
    super_destruct; eauto.
  Qed.
  Hint Resolve wf_tenv_proj2.

  Lemma wf_tenv_proj3:
    forall Γ m τ x,
      wf_tenv Γ m ->
      Γ x = Some τ ->
      wf_type bot τ.
  Proof.
    intros.
    edestruct H; eauto.
    super_destruct.
    eauto.
  Qed.
  Hint Resolve wf_tenv_proj3.

  Lemma wf_tenv_proj4:
    forall Γ m x v,
      wf_tenv Γ m ->
      memory_lookup m x = Some v ->
      exists t, Γ x = Some t.
  Proof.
    intros.
    edestruct H; eauto.
    super_destruct.
    eauto.
  Qed.
  Hint Resolve wf_tenv_proj4.

Definition wf_stenv (env : stenv) (h: Heap) :=
  (forall loc level' n v μ ℓ,
      env loc = Some (SecType Int level') ->
      heap_lookup loc h = Some (ℓ, μ) ->
      lookup μ n = Some v ->
      exists n', v = ValNum n') /\
  (forall loc t level' l n v ℓ μ,
      env loc = Some (SecType (Array t l) level') ->
      heap_lookup loc h = Some (ℓ, μ) ->
      lookup μ n = Some v ->
      exists loc', v = ValLoc loc') /\
  (forall loc τ, env loc = Some τ -> wf_type bot τ) /\
  (forall loc l μ,
      heap_lookup loc h = Some (l, μ) ->
      exists τ, env loc = Some τ).

Lemma wf_stenv_proj1:
  forall Σ loc level' v n h ℓ μ,
    wf_stenv Σ h ->
    Σ loc = Some (SecType Int level') ->
    heap_lookup loc h = Some (ℓ, μ) ->
    lookup μ n = Some v ->
    exists n', v = ValNum n'.
Proof.
  intros.
  edestruct H.
  super_destruct; subst.
  eauto.
Qed.
Hint Resolve wf_stenv_proj1.

Lemma wf_stenv_proj2:
  forall Σ loc t level' l n v h ℓ μ,
    wf_stenv Σ h ->
    Σ loc = Some (SecType (Array t l) level') ->
    heap_lookup loc h = Some (ℓ, μ) ->
    lookup μ n = Some v ->
    exists loc', v = ValLoc loc'.
Proof.
  intros.
  edestruct H.
  super_destruct; subst.
  eauto.
Qed.
Hint Resolve wf_stenv_proj2.

Lemma wf_stenv_proj3:
    forall Σ h τ loc,
      wf_stenv Σ h ->
      Σ loc = Some τ ->
      wf_type bot τ.
  Proof.
    intros.
    edestruct H.
    super_destruct.
    eauto.
  Qed.
  Hint Resolve wf_stenv_proj3.

Lemma wf_stenv_proj4:
    forall Σ h μ l loc,
      wf_stenv Σ h ->
      heap_lookup loc h = Some (l, μ) ->
      exists τ, Σ loc = Some τ.
  Proof.
    intros.
    edestruct H.
    super_destruct.
    eauto.
  Qed.
  Hint Resolve wf_stenv_proj4.

Definition extend_stenv (loc: loc) (t: sectype) (stenv: stenv) :=
  fun loc' => if decide (loc' = loc) then Some t else stenv loc'.

Lemma extend_stenv_lookup_neq:
  forall loc1 loc2 τ Σ,
    loc1 <> loc2 ->
    extend_stenv loc1 τ Σ loc2 = Σ loc2.
Proof.
  intros.
  unfold extend_stenv in *.
  rewrite -> neq_loc in * by solve[eauto].
  reflexivity.
Qed.
Hint Resolve extend_stenv_lookup_neq.

Lemma extend_stenv_lookup_eq:
  forall loc τ Σ,
    extend_stenv loc τ Σ loc = Some τ.
Proof.
  intros.
  unfold extend_stenv in *.
  rewrite -> eq_loc in *.
  reflexivity.
Qed.
Hint Resolve extend_stenv_lookup_eq.

Inductive expr_has_type: tenv -> expr -> sectype -> Prop :=
| type_int:
    forall tenv n l,
      expr_has_type tenv (Const n) (SecType Int l)
| type_var:
    forall tenv x t,
      tenv x = Some t ->
      expr_has_type tenv (Var x) t
| type_op:
    forall tenv op e1 e2 l1 l2,
      expr_has_type tenv e1 (SecType Int l1) ->
      expr_has_type tenv e2 (SecType Int l2) ->
      expr_has_type tenv (BinOp op e1 e2) (SecType Int (ProdL.join l1 l2)).

Notation "'{{' Γ '⊢' e ':' τ '}}' " := (expr_has_type Γ e τ) (at level 0, Γ at level 50,
                                                              e at level 99).

Ltac invert_wt_expr :=
  match goal with [H: context[expr_has_type _ _ _] |- _ ] => inverts H end.

Lemma expr_type_is_wf:
  forall Γ m e τ,
    wf_tenv Γ m ->
    expr_has_type Γ e τ ->
    wf_type bot τ.
Proof.
  intros.
  revert τ H0.
  induction e; intros; inverts H0; eauto.
Qed.
Hint Resolve expr_type_is_wf.

Inductive typeflowsto: sectype -> sectype -> Prop :=
| TypeFlowsTo:
    forall t l1 l2,
      l1 ≼ l2 ->
      typeflowsto (SecType t l1) (SecType t l2).

Notation "τ1 '<:' τ2" := (typeflowsto τ1 τ2)  (at level 20).

Inductive lifted: sectype -> level -> sectype -> Prop :=
| Lifted:
    forall t1 l1 l2,
      lifted (SecType t1 l1) l2 (SecType t1 (l1 ⋎ l2)).

Definition raiseto τ ℓ :=
  match τ with
      (SecType base ℓ') => (SecType base (ℓ ⋎ ℓ'))
  end.

Notation " τ '^^' ℓ":= (raiseto τ ℓ) (at level 20).

Inductive contains_backat: cmd -> Prop :=
| ContainsBackAt:
    forall l n,
      contains_backat (BackAt l n)
| ContainsBackAtSeq_left:
    forall c1 c2,
      contains_backat c1 -> contains_backat (c1;; c2)
| ContainsBackAtSeq_right:
    forall c1 c2,
      contains_backat c2 -> contains_backat (c1;; c2)
| ContainsBackAtIf_1:
    forall e c1 c2,
      contains_backat c1 -> contains_backat (If e c1 c2)
| ContainsBackAtIf_2:
    forall e c1 c2,
      contains_backat c2 -> contains_backat (If e c1 c2)
| ContainsBackAtWhile:
    forall e c,
      contains_backat c -> contains_backat (While e c)
| ContainsBackAtAt:
    forall ℓ e c,
      contains_backat c -> contains_backat (At ℓ e c).
Hint Constructors contains_backat.

Inductive wt: tenv -> level_proj1 -> cmd -> Prop :=
| wt_skip:
    forall tenv pc,
      wt tenv pc Skip
| wt_assign:
    forall tenv pc x e ε σ tx,
      tenv x = Some tx ->
      expr_has_type tenv e (SecType σ ε) ->
      SecType σ (ε ⋎ (pc, ∘)) <: tx ->
      wt tenv pc (Assign x e)
| wt_if:
    forall tenv pc e c1 c2 ℓ,
      expr_has_type tenv e (SecType Int (ℓ, ∘)) ->
      ℓ ⊑ pc ->
      wt tenv pc c1 ->
      wt tenv pc c2 ->
      wt tenv pc (If e c1 c2)
| wt_while:
    forall tenv pc e c ℓ,
      expr_has_type tenv e (SecType Int (ℓ, ∘)) ->
      ℓ ⊑ pc ->
      wt tenv pc c ->
      wt tenv pc (While e c)
| wt_seq:
    forall tenv pc c1 c2,
      wt tenv pc c1 ->
      wt tenv pc c2 ->
      wt tenv pc (Seq c1 c2)
| wt_new:
    forall tenv pc x e_size e_init ℓ ℓ_x τ ℓ_size,
      expr_has_type tenv e_size (SecType Int (ℓ_size, ∘)) ->
      expr_has_type tenv e_init τ ->
      tenv x = Some (SecType (Array τ ℓ) (ℓ_x, ∘)) ->
      pc ⊔ ℓ_size ⊑ ℓ_x ->
      wt tenv pc (NewArr x ℓ e_size e_init)
| wt_set:
    forall tenv pc x e e_idx ε_x ε σ τ ε_idx ℓ,
      expr_has_type tenv e_idx (SecType Int ε_idx) ->
      expr_has_type tenv e (SecType σ ε) ->
      tenv x = Some (SecType (Array τ ℓ) ε_x) ->
      ε_idx ⋎ (pc, ∘) ≼ ε_x ->
      SecType σ (ε_x ⋎ ε) <: τ ->
      wt tenv pc (SetArr x e_idx e)
| wt_get:
    forall tenv pc x y e_idx σ ε ε_y tx ℓ ε_idx,
      expr_has_type tenv e_idx (SecType Int ε_idx) ->
      (pc, ∘) ⋎ ε_idx ≼ ε_y ->
      tenv x = Some tx ->
      tenv y = Some (SecType (Array (SecType σ ε) ℓ) ε_y) ->
      SecType σ (ε ⋎ ε_y) <: tx ->
      wt tenv pc (GetArr x y e_idx)
| wt_time:
    forall tenv pc x ℓ,
      tenv x = Some (SecType Int (ℓ, •)) ->
      pc ⊑ ℓ ->
      wt tenv pc (Time x)
| wt_at:
    forall tenv pc ℓ' ℓ e c,
      pc ⊑ ℓ ->
      ℓ' ⊑ pc ->
      expr_has_type tenv e (SecType Int (ℓ', ∘)) ->
      wt tenv ℓ c ->
      wt tenv pc (At ℓ e c).
Hint Constructors wt.

Inductive wt_aux : tenv -> level_proj1 -> cmd -> level_proj1 -> Prop :=
  | wt_aux_skip:
    forall tenv pc,
      wt_aux tenv pc Skip pc
| wt_aux_assign:
    forall tenv pc x e ε σ tx,
      tenv x = Some tx ->
      expr_has_type tenv e (SecType σ ε) ->
      SecType σ (ε ⋎ (pc, ∘)) <: tx ->
      wt_aux tenv pc (Assign x e) pc
| wt_aux_if:
    forall tenv pc pc' e c1 c2 ℓ,
      expr_has_type tenv e (SecType Int (ℓ, ∘)) ->
      ~ contains_backat c1 ->
      ~ contains_backat c2 ->
      ℓ ⊑ pc ->
      wt_aux tenv pc c1 pc' ->
      wt_aux tenv pc c2 pc' ->
      wt_aux tenv pc (If e c1 c2) pc'
| wt_aux_while:
    forall tenv pc e c ℓ,
      expr_has_type tenv e (SecType Int (ℓ, ∘)) ->
      ~ contains_backat c ->
      ℓ ⊑ pc ->
      wt_aux tenv pc c pc ->
      wt_aux tenv pc (While e c) pc
| wt_aux_seq:
    forall tenv pc1 pc2 pc' c1 c2,
      wt_aux tenv pc1 c1 pc' ->
      wt_aux tenv pc' c2 pc2 ->
      wt_aux tenv pc1 (Seq c1 c2) pc2
| wt_aux_new:
    forall tenv pc x e_size e_init ℓ ℓ_x τ ℓ_size,
      expr_has_type tenv e_size (SecType Int (ℓ_size, ∘)) ->
      expr_has_type tenv e_init τ ->
      tenv x = Some (SecType (Array τ ℓ) (ℓ_x, ∘)) ->
      pc ⊔ ℓ_size ⊑ ℓ_x ->
      wt_aux tenv pc (NewArr x ℓ e_size e_init) pc
| wt_aux_set:
    forall tenv pc x e e_idx ε_x ε σ τ ε_idx ℓ,
      expr_has_type tenv e_idx (SecType Int ε_idx) ->
      expr_has_type tenv e (SecType σ ε) ->
      tenv x = Some (SecType (Array τ ℓ) ε_x) ->
      ε_idx ⋎ (pc, ∘) ≼ ε_x ->
      SecType σ (ε_x ⋎ ε) <: τ ->
      wt_aux tenv pc (SetArr x e_idx e) pc
| wt_aux_get:
    forall tenv pc x y e_idx σ ε ε_y tx ℓ ε_idx,
      expr_has_type tenv e_idx (SecType Int ε_idx) ->
      (pc, ∘) ⋎ ε_idx ≼ ε_y ->
      tenv x = Some tx ->
      tenv y = Some (SecType (Array (SecType σ ε) ℓ) ε_y) ->
      SecType σ (ε ⋎ ε_y) <: tx ->
      wt_aux tenv pc (GetArr x y e_idx) pc
| wt_aux_time:
    forall tenv pc x ℓ,
      tenv x = Some (SecType Int (ℓ, •)) ->
      pc ⊑ ℓ ->
      wt_aux tenv pc (Time x) pc
| wt_aux_at:
    forall tenv pc ℓ ℓ' ℓ'' e c,
      pc ⊑ ℓ ->
      ℓ' ⊑ pc ->
      expr_has_type tenv e (SecType Int (ℓ', ∘)) ->
      ~ contains_backat c ->
      wt_aux tenv ℓ c ℓ'' ->
      wt_aux tenv pc (At ℓ e c) pc
| wt_aux_backat:
    forall tenv pc ℓ n,
      ℓ ⊑ pc ->
      wt_aux tenv pc (BackAt ℓ n) ℓ.
Hint Constructors wt_aux.

Notation "'-{' Γ ',' pc '⊢' c ':' pc' '}-'" := (wt_aux Γ pc c pc') (at level 40).

Notation "X ⊑ᵀ Y" := (typeflowsto X Y) (at level 70, no associativity).

Ltac invert_wt_cmd :=
  match goal with [H: context[wt_aux] |- _] => inverts H
  end.

Ltac invert_lifted :=
  repeat match goal with
         | [H: context[lifted] |- _] => inverts H
         | [H: context[_ ⊑ᵀ _] |- _] => inverts H
         end.

Fixpoint eval memory e :=
  match e with
  | Const n => Some (ValNum n)
  | Var var => memory_lookup memory var
  | BinOp op e1 e2 =>
    let v1 := eval memory e1 in
    let v2 := eval memory e2 in
    match (v1, v2) with
    | (Some (ValNum n1), Some (ValNum n2)) =>
      match op with
      | Plus => Some (ValNum (n1 + n2))
      | Mult => Some (ValNum (n1 * n2))
      end
    | (_, _) => None
    end
  end.

Ltac invert_eval := match goal with
                    | [H: context[eval] |- _] => inverts H
                    end.

Lemma about_eval_var:
  forall m x v,
    memory_lookup m x = Some v -> eval m (Var x) = Some v.
Proof. eauto. Qed.
Hint Resolve about_eval_var.

Lemma about_type_var:
  forall Γ x τ,
    Γ x = Some τ -> {{ Γ ⊢ (Var x) : τ }}.
Proof.
  intros.
  apply type_var.
  assumption.
Qed.
Hint Resolve about_type_var.

Lemma unfold_eval_binop:
  forall m o e1 e2 v,
    eval m (BinOp o e1 e2) = Some v ->
    exists v1 v2,
      eval m e1 = Some v1 /\
      eval m e2 = Some v2.
Proof.
  intros.
  inversion H; subst.
  destruct (eval m e1); subst.
  destruct (eval m e2); subst.
  destruct v0; subst.
  destruct v1; subst.
  destruct o; subst.

  exists (ValNum n).
  exists (ValNum n0).
  split; reflexivity.

  exists (ValNum n).
  exists (ValNum n0).
  split; reflexivity.

  discriminate H1.
  discriminate H1.

  destruct v0; subst; discriminate H1.

  discriminate H1.
Qed.

Lemma about_eval:
  forall m o e1 e2,
    eval m (BinOp o e1 e2) =
    match eval m e1 with
    | None => None
    | Some v1 =>
      match v1 with
      | ValNum n1 =>
        match eval m e2 with
        | None => None
        | Some v2 =>
          match v2 with
          | ValNum n2 =>
            match o with
            | Plus => Some (ValNum (n1 + n2))
            | Mult => Some (ValNum (n1 * n2))
            end
          | ValLoc _ => None
          end
        end
      | ValLoc _ => None
      end
    end.
Proof.
  reflexivity.
Qed.

Lemma eval_binop_is_num:
  forall m o e1 e2 e,
    eval m (BinOp o e1 e2) = Some e ->
    exists n, e = ValNum n.
Proof.
  intros.
  rewrite -> about_eval in *.
  destruct (eval m e1) eqn:H_e1.
  - destruct (eval m e2) eqn:H_e2.
    + destruct v; destruct v0; destruct o; try (discriminate || (injects; eauto)).
    + destruct v; discriminate.
  - discriminate.
Qed.
Hint Resolve eval_binop_is_num.

Lemma wt_int_e_is_num:
  forall tenv m e v level,
    wf_tenv tenv m ->
    expr_has_type tenv e (SecType Int level) ->
    eval m e = Some v ->
    exists n, v = ValNum n.
Proof.
  intros tenv m e v level H_wf_tenv.
  revert v level.
  induction e; intros; eauto.
  - inversion H0; subst.
    eauto.
  - inversion H; subst.
    eauto.
Qed.
Hint Resolve wt_int_e_is_num.

Lemma wt_array_e_is_loc:
  forall tenv m e t ε ℓ v,
    wf_tenv tenv m ->
    expr_has_type tenv e (SecType (Array t ℓ) ε) ->
    eval m e = Some v ->
    exists loc, v = ValLoc loc.
Proof.
  intros.
  induction e; intros; inverts H0; eauto 2.
Qed.
Hint Resolve wt_array_e_is_loc.

Lemma wf_tenv_extend:
  forall tenv m x v t ε,
    wf_tenv tenv m ->
    tenv x = Some (SecType t ε) ->
    (t = Int -> exists n, v = ValNum n) ->
    (forall t' ε', t = Array t' ε' -> exists loc, v = ValLoc loc) ->
    wf_tenv tenv (extend_memory x v m).
Proof.
  intros.
  unfold wf_tenv in H.
  unfold wf_tenv.
  intros.
  splits; intros.

  (* Show: Wellformed wrt. numbers *)
  destruct (decide (x = x0)); subst.

  (*   x = x0 *)
  rewrite -> extend_memory_lookup_eq in *.
  rewrite_inj.
  eauto.

  (*   x <> x0 *)
  rewrite -> extend_memory_lookup_neq in * by solve[eauto].
  eauto.

  (* Show: Wellformed wrt. locations *)
  destruct (decide (x = x0)); subst.

  (*   x = x0 *)
  rewrite -> extend_memory_lookup_eq in *.
  rewrite_inj.
  eauto.

  (*   x <> x0 *)
  rewrite -> extend_memory_lookup_neq in * by solve[eauto].
  eauto.

  eauto.

  destruct (decide (x = x0)); subst.

  (* x = x0 *)
  rewrite -> extend_memory_lookup_eq in *.
  eauto.

  (* x <> x0 *)
  rewrite -> extend_memory_lookup_neq in * by solve[eauto 2].
  eauto.
Qed.

Ltac apply_heap_lookup_extend_eq :=
  match goal with
    [H: heap_lookup ?loc (extend_heap ?v ?loc ?l ?n ?h ?H1 ?H2) = Some (_, _) |- _] =>
    let H' := fresh in
    remember_simple (heap_lookup_extend_eq loc l n v h H1 H2) as H';
    decompose_ex H'; destruct H'
  end.

Lemma wf_stenv_extend:
  forall stenv loc ε ℓ n v h t H1 H2,
    wf_stenv stenv h ->
    (t = Int -> exists n0, v = ValNum n0) ->
    (forall t' ε', t = Array t' ε' -> exists loc', v = ValLoc loc') ->
    wf_type bot (SecType t ε) ->
    wf_stenv (extend_stenv loc (SecType t ε) stenv) (h [loc → (n × v, ℓ), H1, H2]).
Proof.
  intros.
  unfold wf_stenv.
  intros.

  (* Wellformedness for integers *)
  splits.

  intros.
  unfold extend_stenv in *.
  destruct (decide (loc0 = loc)); subst.

  (* loc1 = loc0 *)
  rewrite_inj.
  specialize_gen.
  destruct_exists.
  apply_heap_lookup_extend_eq.
  rewrite_inj.
  specialize (H5 n0).
  rewrite_inj.
  eauto.

  (* loc1 <> loc0 *)
  rewrite -> heap_lookup_extend_neq in * by solve[eauto 2].
   match goal with
    [H: wf_stenv _ _ |- _] =>
    eapply H; eauto 2
  end.

  (* Wellformedness for locations *)
  intros.
  destruct (decide (loc0 = loc)); subst.

  (* loc1 = loc0 *)
  rewrite_inj.
  apply_heap_lookup_extend_eq.
  rewrite -> extend_stenv_lookup_eq in * by eauto.
  rewrite_inj.
  specialize (H9 n0).
  rewrite_inj.
  eauto.

  (* loc1 <> loc0 *)
  rewrite -> heap_lookup_extend_neq in * by solve[eauto 2].
  rewrite -> extend_stenv_lookup_neq in * by solve[eauto].
  eauto.

  intros.
  destruct (decide (loc = loc0)); subst.
  rewrite -> extend_stenv_lookup_eq in *.
  congruence.

  rewrite -> extend_stenv_lookup_neq in * by solve[eauto].
  eauto.

  intros.
  destruct (decide (loc = loc0)); subst.
  rewrite -> extend_stenv_lookup_eq in *.
  eauto.

  (* loc1 <> loc0 *)
  rewrite -> extend_stenv_lookup_neq in * by solve[eauto].
  rewrite -> heap_lookup_extend_neq in * by solve[eauto 2].
  eauto.
Qed.

Lemma deterministic_typing:
  forall Γ pc c pc1 pc2,
    wt_aux Γ pc c pc1 ->
    wt_aux Γ pc c pc2 ->
    pc1 = pc2.
Proof.
  intros Γ pc c.
  revert pc.
  induction c; intros; subst;
    repeat match goal with
           | [H: wt_aux Γ ?pc (?c1;;?c2) _ |- _] => inverts H
           | [H1: wt_aux _ ?pc ?c ?pc1, H2: wt_aux _ ?pc ?c ?pc2 |- _] =>
             try (erewrite -> (IHc1 pc pc1 pc2 H1 H2) in *; eauto);
               inverts H1; inverts H2; eauto
           end.
Qed.
Hint Resolve deterministic_typing.
End TypeDefinitions.


(** * System MALL for propositional multiplicative and additive linear logic

This file encodes the inference rules of the system MALL (two sided)
of propositional multiplicative additive linear logic.
 *)

Require Import LL.SL.FLL.Reasoning.
Require Import LL.SL.FLL.Specifications.Intuitionistic.OLCut.
Require Import LL.SL.FLL.Specifications.Intuitionistic.LJ.Bipoles.
Require Import LL.SL.FLL.InvPositivePhase.
Set Implicit Arguments.

(** ** Well-formedness conditions *)

(** *** Constants *)
Lemma wellBipoleLJC : wellFormedC'.
Proof with sauto.
  unfold wellFormedC';intros.
  destruct lab;destruct s.
 * exists Requirement1.BCFail.
    do 2 intro.
    apply FocusingClause in H...
   - inversion H3...
     solvePolarity.
   - inversion H3...
     solvePolarity.
 * exists Requirement1.BCAxiom.
    do 3 intro.
    apply FocusingClause in H...
   - left. exists x0... simpl. solveLL.
     intros.
      TFocus ((makeRRuleC TT )).
     inversion H1.
     FLLsplit [⌈ t_ccon TT ⌉] Delta1.
    simpl. solveLL.
   - right. split... simpl. solveLL.
     intros.
      TFocus ((makeRRuleC TT )).
     inversion H2.
     FLLsplit (@nil oo) Delta1.
    simpl. solveLL.
 * exists Requirement1.BCAxiom.
    do 3 intro.
    apply FocusingClause in H...
   - left. exists x0... simpl. solveLL.
     intros.
      TFocus ((makeLRuleC FF )).
     inversion H1.
     FLLsplit [⌊ t_ccon FF ⌋] Delta1.
    simpl. solveLL.
   - right. split... simpl. solveLL.
     intros.
      TFocus ((makeLRuleC FF )).
     inversion H2.
     FLLsplit (@nil oo) Delta1.
    simpl. solveLL.
 * exists Requirement1.BCFail.
    do 2 intro.
    apply FocusingClause in H...
   - inversion H3...
     solvePolarity.
   - inversion H3...
     solvePolarity.
Qed.

(** *** Unary connectives *)

Lemma wellBipoleLJU : wellFormedU'.
Proof with sauto.
  unfold wellFormedU';intros.
  destruct lab.
Qed.

Ltac solveTF :=
   match goal with
| [H: IsPositiveAtom (makeLRuleB _ _ _) |- _ ] => inversion H
| [H: IsPositiveAtom (makeRRuleB _ _ _) |- _ ] => inversion H
end.

(** *** Binary connectives *)
Lemma wellBipoleLJB : wellFormedB'.
Proof with sauto.
  unfold wellFormedB';intros.
  destruct lab;destruct s.
 + exists Requirement1.BTwoPA.
     do 3 intro. intros.
     apply FocusingClause in H...
    - apply FocusingWith in H4...
      exists x0, [⌊ Fo1 ⌋],  [⌊ Go1 ⌋], x1, 4.
      split... do 2 constructor...
      inversion H0...  inversion H...
      do 2 constructor...
      inversion H0...  inversion H...
      left. split... simpl. solveLL.
      apply seqNtoSeq in H2...
      apply seqNtoSeq in H5...
      LLExact H2.
      LLExact H5.
      lia. intros.
      TFocus (makeLRuleB OR Fo1 Go1).
      solveTF.
      FLLsplit [⌊ t_bcon OR Fo1 Go1 ⌋ ] Delta12.
      simpl. solveLL. LLExact H1. LLExact H4.
    - apply FocusingWith in H4...
      exists Delta, [⌊ Fo1 ⌋],  [⌊ Go1 ⌋], x0, 4.
      split... do 2 constructor...
      inversion H0...  inversion H...
      do 2 constructor...
      inversion H0...  inversion H...
      right. split... simpl. solveLL.
      apply seqNtoSeq in H2...
      apply seqNtoSeq in H5...
      LLExact H2.
      LLExact H5.
      lia. intros.
      simpl; solveLL.
      LLExact H. LLExact H1.
  + exists Requirement1.BOneP.
     do 3 intro. intros.
     apply FocusingClause in H...
    - apply FocusingPlusPos in H4...
      exists [!⌈ Fo1 ⌉], (S (S (S x1))), 1%nat.
      split... do 2 constructor...
      inversion H0...  inversion H...
      left. exists []...
      FLLleft. solveLL.
      apply seqNtoSeq in H5...
      LFocus.
      lia. intros.
      LLPerm ([⌈ t_bcon OR Fo1 Go1 ⌉] ++ Delta1++[]).
      eapply InvTensorT'. exact H. solveLL.
      simpl... solveLL.
      eapply InvPlus... solveLL. LLExact H1.
exists [!⌈ Go1 ⌉], (S (S (S x1))), 1%nat.
      split... do 2 constructor...
      inversion H0...  inversion H...
      left. exists []...
      FLLright. solveLL.
      apply seqNtoSeq in H5...
      LFocus.
      lia. intros.
  LLPerm ([⌈ t_bcon OR Fo1 Go1 ⌉] ++ Delta1++[]).
      eapply InvTensorT'. exact H. solveLL.
      simpl... solveLL.
      eapply InvPlusComm... solveLL. LLExact H1.

    - apply FocusingPlusPos in H4...
      exists [!⌈ Fo1 ⌉], (S (S (S x0))), 1%nat.
      split... do 2 constructor...
      inversion H0...  inversion H...
      right...
      FLLleft. solveLL.
      apply seqNtoSeq in H5...
      LFocus.
      lia. intros.
      simpl;solveLL...
      eapply InvPlus... solveLL. LLExact H.

      exists [!⌈ Go1 ⌉], (S (S (S x0))), 1%nat.
      split... do 2 constructor...
      inversion H0...  inversion H...
      right...
      FLLright. solveLL.
      apply seqNtoSeq in H5...
       LFocus.
      lia. intros.
      simpl... solveLL.
      eapply InvPlusComm... solveLL. LLExact H.

  + exists Requirement1.BOneP.
     do 3 intro. intros.
     apply FocusingClause in H...
    - apply FocusingPlus in H4...
      exists [⌊ Fo1 ⌋], x1, 4.
      split... do 2 constructor...
      inversion H0...  inversion H...
      left. exists x0...
      FLLleft. solveLL.
      apply seqNtoSeq in H2...
      LLExact H2.
      lia. intros.
      TFocus (makeLRuleB AND Fo1 Go1).
      solveTF.
      FLLsplit [⌊ t_bcon AND Fo1 Go1 ⌋] Delta1.
      FLLleft. solveLL. LLExact H1.
      exists [⌊ Go1 ⌋], x1, 4.
      split... do 2 constructor...
      inversion H0...  inversion H...
      left. exists x0...
      FLLright. solveLL.
      apply seqNtoSeq in H2...
      LLExact H2.
      lia. intros.
      TFocus (makeLRuleB AND Fo1 Go1).
      solveTF.
      FLLsplit [⌊ t_bcon AND Fo1 Go1 ⌋] Delta1.
      FLLright. solveLL. LLExact H1.
    - apply FocusingPlus in H4...
      exists [⌊ Fo1 ⌋], x0, 4.
      split... do 2 constructor...
      inversion H0...  inversion H...
      right...
      FLLleft. solveLL.
      apply seqNtoSeq in H2...
      LLExact H2.
      lia. intros. simpl. solveLL.
     apply InvPlus... solveLL.
     LLExact H.
      exists [⌊ Go1 ⌋], x0, 4.
      split... do 2 constructor...
      inversion H0...  inversion H...
      right...
 simpl.
      FLLright. solveLL.
      apply seqNtoSeq in H2...
      LLExact H2.
      lia. intros.
 simpl. solveLL.
     apply InvPlusComm... solveLL.
     LLExact H.
 + exists Requirement1.BTwoPA.
     do 3 intro. intros.
     apply FocusingClause in H...
    - apply FocusingWithPos in H4...
      exists x0, [!⌈ Fo1 ⌉],  [!⌈ Go1 ⌉], x1, 4.
      split... do 2 constructor...
      inversion H0...  inversion H...
      do 2 constructor...
      inversion H0...  inversion H...
      left. split... simpl. solveLL.
      apply seqNtoSeq in H2...
      apply seqNtoSeq in H5...
(*       apply BangConN in H2... *)
      LLExact H2.
(*       apply BangConN in H5... *)
      LLExact H5.
      lia. intros.
      TFocus (makeRRuleB AND Fo1 Go1).
      solveTF.
      FLLsplit [⌈ t_bcon AND Fo1 Go1 ⌉ ] Delta12.
     simpl. solveLL. LLExact H1. LLExact H4.
    - apply FocusingWithPos in H4...
      exists Delta, [!⌈ Fo1 ⌉],  [!⌈ Go1 ⌉], x0, 4.
      split... do 2 constructor...
      inversion H0...  inversion H...
      do 2 constructor...
      inversion H0...  inversion H...
      right. split... simpl. solveLL.
      apply seqNtoSeq in H2...
      apply seqNtoSeq in H5...
(*      apply BangConN in H2... *)
      LLExact H2.
(*       apply BangConN in H5... *)
      LLExact H5.
      lia. intros.
     simpl; solveLL. LLExact H. LLExact H1.
 + exists Requirement1.BTwoPM.
     do 3 intro. intros.
     apply FocusingClause in H...
    - apply FocusingTensorPos in H4...
      exists  x0, [⌈ Fo1 ⌉],  [⌊ Go1 ⌋], x1, 4.
      split... do 2 constructor...
      inversion H0...  inversion H...
      do 2 constructor...
      inversion H0...  inversion H...
      left. split... simpl.
      FLLsplit (@nil oo) x0; solveLL.
      apply seqNtoSeq in H2...
      apply seqNtoSeq in H5...
      LLExact H5.
      lia. intros.
      TFocus (makeLRuleB IMP Fo1 Go1).
      solveTF.
      FLLsplit [⌊ t_bcon IMP Fo1 Go1 ⌋ ] (Delta0).
      simpl. FLLsplit (@nil oo) (Delta0); solveLL.  LLExact H4.
    - apply FocusingTensorPos in H4...
      exists Delta, [⌈ Fo1 ⌉],  [⌊ Go1 ⌋], x0, 4.
      split... do 2 constructor...
      inversion H0...  inversion H...
      do 2 constructor...
      inversion H0...  inversion H...
      right. split... simpl. solveLL.
      FLLsplit (@nil oo) Delta; solveLL.
      apply seqNtoSeq in H2...
      apply seqNtoSeq in H5...
      LLExact H5.
      lia. intros.
      simpl; solveLL.
     LLPerm ((! ⌈ Fo1 ⌉) ⊗ ⌊ Go1 ⌋ :: []++Delta0).
     apply InvTensor';solveLL... LFocus.   LLExact H1.
  + exists Requirement1.BOneP.
     do 3 intro. intros.
     apply FocusingClause in H...
    - apply FocusingParPos in H4...
      exists [!⌈ Go1 ⌉ ; ⌊ Fo1 ⌋], x1, 5.
      split... constructor... constructor...
      inversion H0...  inversion H...
      constructor... constructor...
      inversion H0...  inversion H...

      left. exists x0...
      simpl.  solveLL.
      apply seqNtoSeq in H1...
      LLExact H1.
      lia. intros.
      TFocus (makeRRuleB IMP Fo1 Go1).
      solveTF.
      FLLsplit [⌈ t_bcon IMP Fo1 Go1 ⌉] Delta1.
      simpl. solveLL.  LLExact H2.
    - apply FocusingParPos in H4...
      exists [!⌈ Go1 ⌉ ; ⌊ Fo1 ⌋], x0, 5.
      split... constructor... constructor...
      inversion H0...  inversion H...
      constructor... constructor...
      inversion H0...  inversion H...

      right...
      simpl.  solveLL.
      apply seqNtoSeq in H1...
      LLExact H1.
      lia. intros.
      simpl; solveLL. LLExact H.
Qed.

Lemma wellBipoleLJQ : wellFormedQ'.
Proof with sauto.
  unfold wellFormedQ';intros.
  destruct lab.
Qed.

Lemma wellFormedT : wellFormedTheory'.
Proof.
  split.
  apply wellBipoleLJC.
  split.
 apply wellBipoleLJU.
  split.
apply wellBipoleLJB.
 apply wellBipoleLJQ.
Qed.

Lemma checkEncodeCasesD'
     : forall (L : list uexp) (x : list oo) (F G : uexp),
  Permutation (atom (up G) :: ⌞ L ⌟ ) (⌊ F ⌋ :: x) ->
       exists x1 : list uexp,
         Permutation (⌞ L ⌟) (⌊ F ⌋ :: ⌞ x1 ⌟) /\
         Permutation (atom (up G) :: ⌞ x1 ⌟ ) x.
Proof with sauto.
   intros.
   assert(Permutation (⌈ G ⌉ :: ⌞ L ⌟) ( LEncode L ++ REncode [G]))...
   rewrite H0 in H.
   apply checkEncodeCasesD in H...
   exists x0... rewrite <- H2...
Qed.

Lemma wellBipoleLJCI : wellFormedCI.
Proof with sauto.
  unfold wellFormedCI;intros.
  destruct lab.
 * exists Requirement1.BCFail.
    do 2 intro.
    apply FocusingClause in H...
   - inversion H3...
     solvePolarity.
   - inversion H3...
     solvePolarity.
 * exists Requirement1.BCAxiom.
    do 3 intro.
    apply FocusingClause in H...
   - left. apply checkEncodeCasesD' in H3...
     exists x1... simpl. solveLL.
     intros.
      TFocus ((makeLRuleC FF )).
     inversion H3.
     FLLsplit [⌊ t_ccon FF ⌋] Delta1.
    simpl. solveLL.
   - right. split... simpl. solveLL.
     intros.
      TFocus ((makeLRuleC FF )).
     inversion H2.
     FLLsplit (@nil oo) Delta1.
    simpl. solveLL.
Qed.

Lemma wellBipoleLJUI : wellFormedUI.
Proof with sauto.
  unfold wellFormedUI;intros.
  destruct lab.
Qed.

Lemma wellBipoleLJQI : wellFormedQI.
Proof with sauto.
  unfold wellFormedQI. intros.
  destruct lab.
Qed.

 Lemma wellBipoleLJBI : wellFormedBI.
Proof with sauto.
  unfold wellFormedBI;intros.
  destruct lab.
 + exists Requirement1.BTwoPA.
     do 3 intro. intros.
     apply FocusingClause in H...
    - apply FocusingWith in H4...
     apply checkEncodeCasesD' in H3...
      exists x, [ Fo1 ],  [ Go1 ], x1, 4.
      split...  constructor...
      inversion H0...  inversion H3...
      constructor...
      inversion H0...  inversion H3...
      left. split... rewrite H1... simpl. solveLL.
      apply seqNtoSeq in H2...
      apply seqNtoSeq in H5...
      LLExact H2.  rewrite <- H1... rewrite LEncodeApp...
      LLExact H5.  rewrite <- H1... rewrite LEncodeApp...
      lia. intros.
      TFocus (makeLRuleB OR Fo1 Go1).
      solveTF.
      FLLsplit [⌊ t_bcon OR Fo1 Go1 ⌋ ]  Delta12.
      simpl. solveLL. LLExact H4. LLExact H6.
    - apply FocusingWith in H4...
      exists Delta, [ Fo1 ],  [ Go1], x0, 4.
      split... constructor...
      inversion H0...  inversion H...
      constructor...
      inversion H0...  inversion H...
      right. split... simpl. solveLL.
      apply seqNtoSeq in H2...
      apply seqNtoSeq in H5...
      LLExact H2. simpl...
      LLExact H5. simpl...
      lia. intros.
    (*   TFocus (makeLRuleBin OR Fo1 Go1).
      solveTF.
   FLLsplit (@nil oo) (⌈ F ⌉ :: ⌞ Delta12 ⌟).       *)
      simpl. solveLL.
      LLExact H. LLExact H1.
  + exists Requirement1.BOneP.
     do 3 intro. intros.
     apply FocusingClause in H...
    - apply FocusingPlus in H4...
       apply checkEncodeCasesD' in H3...
       exists   [Fo1 ], x1, 4.
      split...
     constructor...
      inversion H0...  inversion H3...
     left. exists x. split...
      rewrite H1...
      FLLleft. solveLL.
      apply seqNtoSeq in H2...
      LLExact H2. rewrite <- H1 ... rewrite LEncodeApp...
      lia. intros.
      TFocus (makeLRuleB AND Fo1 Go1).
      solveTF.
      FLLsplit [⌊ t_bcon AND Fo1 Go1 ⌋ ] Delta1.
      FLLleft. solveLL. LLExact H4.

       apply checkEncodeCasesD' in H3...
       exists  [Go1 ], x1, 4.
      split...
     constructor...
      inversion H0...  inversion H3...
     left. exists x. split...
      rewrite H1...
      FLLright. solveLL.
      apply seqNtoSeq in H2...
      LLExact H2.   rewrite <- H1 ... rewrite LEncodeApp...
      lia. intros.
      TFocus (makeLRuleB AND Fo1 Go1).
      solveTF.
      FLLsplit [⌊ t_bcon AND Fo1 Go1 ⌋ ] Delta1.
      FLLright. solveLL. LLExact H4.
     - apply FocusingPlus in H4...
       exists  [Fo1 ], x0, 4.
      split...
     constructor...
      inversion H0...  inversion H...
     right. split...
      FLLleft. solveLL.
      apply seqNtoSeq in H2...
      LLExact H2.
      lia. intros.
  FLLleft. solveLL. LLExact H.
exists  [Go1 ], x0, 4.
      split...
     constructor...
      inversion H0...  inversion H...
     right. split...
      FLLright. solveLL.
      apply seqNtoSeq in H2...
      LLExact H2.
      lia. intros.
  FLLright. solveLL. LLExact H.
 + exists Requirement1.BTwoPM.
     do 3 intro. intros.
     apply FocusingClause in H...
    - apply FocusingTensorPos in H4...
       apply checkEncodeCasesD' in H3...
       exists x. exists [Go1], [⌈ Fo1 ⌉], x1, 4.
      split... 1-2: constructor...  inversion H0... inversion H3...
 constructor...  inversion H0... inversion H3...
      left. split... simpl.
      FLLsplit (@nil oo)  (⌞ x ⌟ ++ [⌈ F ⌉]) ; solveLL.
      apply seqNtoSeq in H2...
      apply seqNtoSeq in H5...
      LLExact H5.   rewrite <- H1...
LLExact H5.   rewrite <- H1... rewrite LEncodeApp...
      lia. intros.
      LLPerm ([⌊ t_bcon IMP Fo1 Go1 ⌋] ++ (Delta0)).
     eapply InvTensorT'. exact H3. solveLL.  simpl.  solveLL.
      LLPerm ((! ⌈ Fo1 ⌉) ⊗ ⌊ Go1 ⌋ :: [ ] ++  Delta0).
       eapply InvTensor';solveLL. LFocus.
 LLExact H4.
    - apply FocusingTensorPos in H4...
     exists Delta, [Go1 ]. exists [⌈ Fo1 ⌉], x0, 4.
    split...
    1-2: constructor...
    inversion H0...
    inversion H...
constructor...
    inversion H0...
    inversion H...
right.
      split...
      FLLsplit (@nil oo)  (⌞Delta⌟ ++ [⌈ F ⌉]) ; solveLL.
      apply seqNtoSeq in H2...
      apply seqNtoSeq in H5...
      LLExact H5. LLExact H5. rewrite LEncodeApp...
      lia. intros. simpl;solveLL.
        FLLsplit (@nil oo)  Delta0; solveLL.
 LLExact H.
Qed.

Lemma wellFormedI : wellFormedTheoryI.
Proof.
  split.
  apply wellBipoleLJCI.
  split.
 apply wellBipoleLJUI.
  split.
apply wellBipoleLJBI.
 apply wellBipoleLJQI.
Qed.

(** ** Cut-coherency properties *)

(** *** Binary Connectives *)
Lemma CutCoherenceOR: CutCoherenceBin cutR2 (rulesB OR).
Proof with sauto; try solveLL.
  unfold CutCoherenceBin;intros.
  simpl...
  apply InvPlus...
  apply InvPlusComm...
Qed.

Lemma CutCoherenceAND: CutCoherenceBin cutR2 (rulesB AND).
Proof with sauto; try solveLL.
  unfold CutCoherenceBin;intros.
  simpl...
  LLPerm  [(? ⌈ F ⌉^) ⊕ (? ⌈ G ⌉^); ⌊ F ⌋^].
  apply InvPlus...
  LLPerm  [(? ⌈ F ⌉^) ⊕ (? ⌈ G ⌉^); ⌊ G ⌋^].
  apply InvPlusComm...
Qed.

Lemma CutCoherenceIMP: CutCoherenceBin cutR2 (rulesB IMP).
Proof with sauto; try solveLL.
  unfold CutCoherenceBin;intros.
  simpl...
  LLPerm  ((⌊ F ⌋^ ⊗ (? ⌈ G ⌉^)):: ([]++[⌊G ⌋^])).
  apply InvTensor'...
  simpl...
  apply weakening...
Qed.

Lemma CutCoherenceLJ : CutCoherence cutR2.
Proof.
 split;intros.
  destruct lab...
  split;intros; try destruct lab.
  simpl. auto. simpl. solveLL.
  split;intros; try destruct lab.
  simpl. auto. simpl. solveLL.
  split;intros; try destruct lab.
  split;intros; try destruct lab.
  apply CutCoherenceOR.
   apply CutCoherenceAND.
  apply CutCoherenceIMP.
Qed.

Check OLCutElimination  wellFormedT CutCoherenceLJ wellFormedI .


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

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

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

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

(** * Floating-point format with gradual underflow *)
Require Import Raux Defs Round_pred Generic_fmt Float_prop.
Require Import FLX FIX Ulp Round_NE.
Require Import Psatz.

Section RND_FLT.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.

Context { prec_gt_0_ : Prec_gt_0 prec }.

Inductive FLT_format (x : R) : Prop :=
  FLT_spec (f : float beta) :
    x = F2R f -> (Z.abs (Fnum f) < Zpower beta prec)%Z ->
    (emin <= Fexp f)%Z -> FLT_format x.

Definition FLT_exp e := Z.max (e - prec) emin.

(** Properties of the FLT format *)
Global Instance FLT_exp_valid : Valid_exp FLT_exp.
Proof.
intros k.
unfold FLT_exp.
generalize (prec_gt_0 prec).
repeat split ;
  intros ; zify ; lia.
Qed.

Theorem generic_format_FLT :
  forall x, FLT_format x -> generic_format beta FLT_exp x.
Proof.
clear prec_gt_0_.
intros x [[mx ex] H1 H2 H3].
simpl in H2, H3.
rewrite H1.
apply generic_format_F2R.
intros Zmx.
unfold cexp, FLT_exp.
rewrite mag_F2R with (1 := Zmx).
apply Z.max_lub with (2 := H3).
apply Zplus_le_reg_r with (prec - ex)%Z.
ring_simplify.
now apply mag_le_Zpower.
Qed.

Theorem FLT_format_generic :
  forall x, generic_format beta FLT_exp x -> FLT_format x.
Proof.
intros x.
unfold generic_format.
set (ex := cexp beta FLT_exp x).
set (mx := Ztrunc (scaled_mantissa beta FLT_exp x)).
intros Hx.
rewrite Hx.
eexists ; repeat split ; simpl.
apply lt_IZR.
rewrite IZR_Zpower. 2: now apply Zlt_le_weak.
apply Rmult_lt_reg_r with (bpow ex).
apply bpow_gt_0.
rewrite <- bpow_plus.
change (F2R (Float beta (Z.abs mx) ex) < bpow (prec + ex))%R.
rewrite F2R_Zabs.
rewrite <- Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
unfold cexp in ex.
destruct (mag beta x) as (ex', He).
simpl in ex.
specialize (He Hx0).
apply Rlt_le_trans with (1 := proj2 He).
apply bpow_le.
cut (ex' - prec <= ex)%Z. lia.
unfold ex, FLT_exp.
apply Z.le_max_l.
apply Z.le_max_r.
Qed.

Theorem generic_format_FLT_bpow :
  forall e, (emin <= e)%Z -> generic_format beta FLT_exp (bpow e).
Proof.
intros e He.
apply generic_format_bpow; unfold FLT_exp.
apply Z.max_case; try assumption.
unfold Prec_gt_0 in prec_gt_0_; lia.
Qed.

Theorem FLT_format_bpow :
  forall e, (emin <= e)%Z -> FLT_format (bpow e).
Proof.
intros e He.
apply FLT_format_generic.
now apply generic_format_FLT_bpow.
Qed.

Theorem FLT_format_satisfies_any :
  satisfies_any FLT_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLT_exp)).
intros x.
split.
apply FLT_format_generic.
apply generic_format_FLT.
Qed.

Theorem cexp_FLT_FLX :
  forall x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  cexp beta FLT_exp x = cexp beta (FLX_exp prec) x.
Proof.
intros x Hx.
assert (Hx0: x <> 0%R).
intros H1; rewrite H1, Rabs_R0 in Hx.
contradict Hx; apply Rlt_not_le, bpow_gt_0.
unfold cexp.
apply Zmax_left.
destruct (mag beta x) as (ex, He).
unfold FLX_exp. simpl.
specialize (He Hx0).
cut (emin + prec - 1 < ex)%Z. lia.
apply (lt_bpow beta).
apply Rle_lt_trans with (1 := Hx).
apply He.
Qed.

(** FLT is a nice format: it has a monotone exponent... *)
Global Instance FLT_exp_monotone : Monotone_exp FLT_exp.
Proof.
intros ex ey.
unfold FLT_exp.
zify ; lia.
Qed.

(** and it allows a rounding to nearest, ties to even. *)
Global Instance exists_NE_FLT :
  (Z.even beta = false \/ (1 < prec)%Z) ->
  Exists_NE beta FLT_exp.
Proof.
intros [H|H].
now left.
right.
intros e.
unfold FLT_exp.
destruct (Zmax_spec (e - prec) emin) as [(H1,H2)|(H1,H2)] ;
  rewrite H2 ; clear H2.
generalize (Zmax_spec (e + 1 - prec) emin).
generalize (Zmax_spec (e - prec + 1 - prec) emin).
lia.
generalize (Zmax_spec (e + 1 - prec) emin).
generalize (Zmax_spec (emin + 1 - prec) emin).
lia.
Qed.

(** Links between FLT and FLX *)
Theorem generic_format_FLT_FLX :
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  generic_format beta (FLX_exp prec) x ->
  generic_format beta FLT_exp x.
Proof.
intros x Hx H.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0.
apply generic_format_0.
unfold generic_format, scaled_mantissa.
now rewrite cexp_FLT_FLX.
Qed.

Theorem generic_format_FLX_FLT :
  forall x : R,
  generic_format beta FLT_exp x -> generic_format beta (FLX_exp prec) x.
Proof.
clear prec_gt_0_.
intros x Hx.
unfold generic_format in Hx; rewrite Hx.
apply generic_format_F2R.
intros _.
rewrite <- Hx.
unfold cexp, FLX_exp, FLT_exp.
apply Z.le_max_l.
Qed.

Theorem round_FLT_FLX : forall rnd x,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  round beta FLT_exp rnd x = round beta (FLX_exp prec) rnd x.
Proof.
intros rnd x Hx.
unfold round, scaled_mantissa.
rewrite cexp_FLT_FLX ; trivial.
Qed.

(** Links between FLT and FIX (underflow) *)
Theorem cexp_FLT_FIX :
  forall x, x <> 0%R ->
  (Rabs x < bpow (emin + prec))%R ->
  cexp beta FLT_exp x = cexp beta (FIX_exp emin) x.
Proof.
intros x Hx0 Hx.
unfold cexp.
apply Zmax_right.
unfold FIX_exp.
destruct (mag beta x) as (ex, Hex).
simpl.
cut (ex - 1 < emin + prec)%Z. lia.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := Hx).
now apply Hex.
Qed.

Theorem generic_format_FIX_FLT :
  forall x : R,
  generic_format beta FLT_exp x ->
  generic_format beta (FIX_exp emin) x.
Proof.
clear prec_gt_0_.
intros x Hx.
rewrite Hx.
apply generic_format_F2R.
intros _.
rewrite <- Hx.
apply Z.le_max_r.
Qed.

Theorem generic_format_FLT_FIX :
  forall x : R,
  (Rabs x <= bpow (emin + prec))%R ->
  generic_format beta (FIX_exp emin) x ->
  generic_format beta FLT_exp x.
Proof with auto with typeclass_instances.
apply generic_inclusion_le...
intros e He.
unfold FIX_exp.
apply Z.max_lub.
lia.
apply Z.le_refl.
Qed.

Lemma negligible_exp_FLT :
  exists n, negligible_exp FLT_exp = Some n /\ (n <= emin)%Z.
Proof.
case (negligible_exp_spec FLT_exp).
{ intro H; exfalso; specialize (H emin); revert H.
  apply Zle_not_lt, Z.le_max_r. }
intros n Hn; exists n; split; [now simpl|].
destruct (Z.max_spec (n - prec) emin) as [(Hm, Hm')|(Hm, Hm')].
{ now revert Hn; unfold FLT_exp; rewrite Hm'. }
revert Hn prec_gt_0_; unfold FLT_exp, Prec_gt_0; rewrite Hm'; lia.
Qed.

Theorem generic_format_FLT_1 :
  (emin <= 0)%Z ->
  generic_format beta FLT_exp 1.
Proof.
intros Hemin.
now apply (generic_format_FLT_bpow 0).
Qed.

Theorem ulp_FLT_0 :
  ulp beta FLT_exp 0 = bpow emin.
Proof.
unfold ulp.
rewrite Req_bool_true by easy.
case negligible_exp_spec.
- intros T.
  elim Zle_not_lt with (2 := T emin).
  apply Z.le_max_r.
- intros n Hn.
  apply f_equal.
  assert (H: FLT_exp emin = emin).
    apply Z.max_r.
    generalize (prec_gt_0 prec).
    clear ; lia.
  rewrite <- H.
  apply fexp_negligible_exp_eq.
  apply FLT_exp_valid.
  exact Hn.
  rewrite H.
  apply Z.le_refl.
Qed.

Theorem ulp_FLT_small :
  forall x, (Rabs x < bpow (emin + prec))%R ->
  ulp beta FLT_exp x = bpow emin.
Proof.
intros x Hx.
destruct (Req_dec x 0%R) as [Zx|Zx].
{ rewrite Zx.
  apply ulp_FLT_0. }
rewrite ulp_neq_0 by easy.
apply f_equal.
apply Z.max_r.
destruct (mag beta x) as [e He].
simpl.
cut (e - 1 < emin + prec)%Z. lia.
apply lt_bpow with beta.
apply Rle_lt_trans with (2 := Hx).
now apply He.
Qed.

Theorem ulp_FLT_le :
  forall x, (bpow (emin + prec - 1) <= Rabs x)%R ->
  (ulp beta FLT_exp x <= Rabs x * bpow (1 - prec))%R.
Proof.
intros x Hx.
assert (Zx : (x <> 0)%R).
  intros Z; contradict Hx; apply Rgt_not_le, Rlt_gt.
  rewrite Z, Rabs_R0; apply bpow_gt_0.
rewrite ulp_neq_0 with (1 := Zx).
unfold cexp, FLT_exp.
destruct (mag beta x) as (e,He).
apply Rle_trans with (bpow (e-1)*bpow (1-prec))%R.
rewrite <- bpow_plus.
right; apply f_equal.
replace (e - 1 + (1 - prec))%Z with (e - prec)%Z by ring.
apply Z.max_l; simpl.
assert (emin+prec-1 < e)%Z; try lia.
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=Hx).
now apply He.
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply He.
Qed.

Theorem ulp_FLT_gt :
  forall x, (Rabs x * bpow (-prec) < ulp beta FLT_exp x)%R.
Proof.
intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLT_small, Rabs_R0, Rmult_0_l; try apply bpow_gt_0.
rewrite Rabs_R0; apply bpow_gt_0.
rewrite ulp_neq_0; try exact Hx.
unfold cexp, FLT_exp.
apply Rlt_le_trans with (bpow (mag beta x)*bpow (-prec))%R.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
now apply bpow_mag_gt.
rewrite <- bpow_plus.
apply bpow_le.
apply Z.le_max_l.
Qed.

Lemma ulp_FLT_exact_shift :
  forall x e,
  (x <> 0)%R ->
  (emin + prec <= mag beta x)%Z ->
  (emin + prec - mag beta x <= e)%Z ->
  (ulp beta FLT_exp (x * bpow e) = ulp beta FLT_exp x * bpow e)%R.
Proof.
intros x e Nzx Hmx He.
unfold ulp; rewrite Req_bool_false;
  [|now intro H; apply Nzx, (Rmult_eq_reg_r (bpow e));
    [rewrite Rmult_0_l|apply Rgt_not_eq, Rlt_gt, bpow_gt_0]].
rewrite (Req_bool_false _ _ Nzx), <- bpow_plus; f_equal; unfold cexp, FLT_exp.
rewrite (mag_mult_bpow _ _ _ Nzx), !Z.max_l; lia.
Qed.

Lemma succ_FLT_exact_shift_pos :
  forall x e,
  (0 < x)%R ->
  (emin + prec <= mag beta x)%Z ->
  (emin + prec - mag beta x <= e)%Z ->
  (succ beta FLT_exp (x * bpow e) = succ beta FLT_exp x * bpow e)%R.
Proof.
intros x e Px Hmx He.
rewrite succ_eq_pos; [|now apply Rlt_le, Rmult_lt_0_compat, bpow_gt_0].
rewrite (succ_eq_pos _ _ _ (Rlt_le _ _ Px)).
now rewrite Rmult_plus_distr_r; f_equal; apply ulp_FLT_exact_shift; [lra| |].
Qed.

Lemma succ_FLT_exact_shift :
  forall x e,
  (x <> 0)%R ->
  (emin + prec + 1 <= mag beta x)%Z ->
  (emin + prec - mag beta x + 1 <= e)%Z ->
  (succ beta FLT_exp (x * bpow e) = succ beta FLT_exp x * bpow e)%R.
Proof.
intros x e Nzx Hmx He.
destruct (Rle_or_lt 0 x) as [Px|Nx].
{ now apply succ_FLT_exact_shift_pos; [lra|lia|lia]. }
unfold succ.
rewrite Rle_bool_false; [|assert (H := bpow_gt_0 beta e); nra].
rewrite Rle_bool_false; [|now simpl].
rewrite Ropp_mult_distr_l_reverse, <-Ropp_mult_distr_l_reverse; f_equal.
unfold pred_pos.
rewrite mag_mult_bpow; [|lra].
replace (_ - 1)%Z with (mag beta (- x) - 1 + e)%Z; [|ring]; rewrite bpow_plus.
unfold Req_bool; rewrite Rcompare_mult_r; [|now apply bpow_gt_0].
fold (Req_bool (-x) (bpow (mag beta (-x) - 1))); case Req_bool.
{ rewrite mag_opp; unfold FLT_exp; do 2 (rewrite Z.max_l; [|lia]).
  replace (_ - _)%Z with (mag beta x - 1 - prec + e)%Z; [|ring].
  rewrite bpow_plus; ring. }
rewrite ulp_FLT_exact_shift; [ring|lra| |]; rewrite mag_opp; lia.
Qed.

Theorem ulp_FLT_pred_pos :
  forall x,
  generic_format beta FLT_exp x ->
  (0 <= x)%R ->
  ulp beta FLT_exp (pred beta FLT_exp x) = ulp beta FLT_exp x \/
  (x = bpow (mag beta x - 1) /\ ulp beta FLT_exp (pred beta FLT_exp x) = (ulp beta FLT_exp x / IZR beta)%R).
Proof.
intros x Fx [Hx|Hx] ; cycle 1.
{ rewrite <- Hx.
  rewrite pred_0.
  rewrite ulp_opp.
  left.
  apply ulp_ulp_0.
  apply FLT_exp_valid.
  typeclasses eauto. }
assert (Hp: (0 <= pred beta FLT_exp x)%R).
{ apply pred_ge_gt ; try easy.
  apply FLT_exp_valid.
  apply generic_format_0. }
destruct (Rle_or_lt (bpow (emin + prec)) x) as [Hs|Hs].
- unfold ulp.
  rewrite Req_bool_false ; cycle 1.
  { intros Zp.
    apply Rle_not_lt with (1 := Hs).
    generalize (f_equal (succ beta FLT_exp) Zp).
    rewrite succ_pred.
    rewrite succ_0, ulp_FLT_0.
    intros H.
    rewrite H.
    apply bpow_lt.
    generalize (prec_gt_0 prec).
    lia.
    apply FLT_exp_valid.
    exact Fx. }
  rewrite Req_bool_false by now apply Rgt_not_eq.
  unfold cexp.
  destruct (mag beta x) as [e He].
  simpl.
  specialize (He (Rgt_not_eq _ _ Hx)).
  rewrite Rabs_pos_eq in He by now apply Rlt_le.
  destruct (proj1 He) as [Hb|Hb].
  + left.
    apply (f_equal (fun v => bpow (FLT_exp v))).
    apply mag_unique.
    rewrite Rabs_pos_eq by easy.
    split.
    * apply pred_ge_gt ; try easy.
      apply FLT_exp_valid.
      apply generic_format_FLT_bpow.
      apply Z.lt_le_pred.
      apply lt_bpow with beta.
      apply Rle_lt_trans with (2 := proj2 He).
      apply Rle_trans with (2 := Hs).
      apply bpow_le.
      generalize (prec_gt_0 prec).
      lia.
    * apply pred_lt_le.
      now apply Rgt_not_eq.
      now apply Rlt_le.
  + right.
    split.
    easy.
    replace (FLT_exp _) with (FLT_exp e + -1)%Z.
    rewrite bpow_plus.
    now rewrite <- (Zmult_1_r beta).
    rewrite <- Hb.
    unfold FLT_exp at 1 2.
    replace (mag_val _ _ (mag _ _)) with (e - 1)%Z.
    rewrite <- Hb in Hs.
    apply le_bpow in Hs.
    zify ; lia.
    apply eq_sym, mag_unique.
    rewrite Hb.
    rewrite Rabs_pos_eq by easy.
    split ; cycle 1.
    { apply pred_lt_id.
      now apply Rgt_not_eq. }
    apply pred_ge_gt.
    apply FLT_exp_valid.
    apply generic_format_FLT_bpow.
    cut (emin + 1 < e)%Z. lia.
    apply lt_bpow with beta.
    apply Rle_lt_trans with (2 := proj2 He).
    apply Rle_trans with (2 := Hs).
    apply bpow_le.
    generalize (prec_gt_0 prec).
    lia.
    exact Fx.
    apply Rlt_le_trans with (2 := proj1 He).
    apply bpow_lt.
    apply Z.lt_pred_l.
- left.
  rewrite (ulp_FLT_small x).
  apply ulp_FLT_small.
  rewrite Rabs_pos_eq by easy.
  apply pred_lt_le.
  now apply Rgt_not_eq.
  now apply Rlt_le.
  rewrite Rabs_pos_eq by now apply Rlt_le.
  exact Hs.
Qed.

End RND_FLT.