(** Some general prerequisities in homotopy type theory. *)
Require Import HoTT.

Definition squash (A : Type) `{Decidable A} : Type :=
  match dec A with
  | inl _ => Unit
  | inr _ => Empty
  end.

Definition from_squash (A : Type) `{Decidable A} {x : squash A} : A.
Proof.
  unfold squash in *.
  destruct (dec A).
  - apply a.
  - contradiction.
Defined.

Lemma ap_inl_path_sum_inl {A B} (x y : A) (p : inl x = inl y) :
  ap inl (path_sum_inl B p) = p.
Proof.
  transitivity (@path_sum _ B (inl x) (inl y) (path_sum_inl B p));
    [ | apply (eisretr_path_sum _) ].
  destruct (path_sum_inl B p).
  reflexivity.
Defined.

Lemma ap_equiv {A B} (f : A <~> B) {x y : A} (p : x = y) :
  ap (f^-1 o f) p = eissect f x @ p @ (eissect f y)^.
Proof.
  destruct p.
  hott_simpl.
Defined.

Global Instance hprop_lem `{Univalence} (T : Type) (Ttrunc : IsHProp T) : IsHProp (T + ~T).
Proof.
  apply (equiv_hprop_allpath _)^-1.
  intros [x | nx] [y | ny] ; try f_ap ; try (apply Ttrunc) ; try contradiction.
  - apply equiv_hprop_allpath. apply _.
Defined.

Global Instance inl_embedding (A B : Type) : IsEmbedding (@inl A B).
Proof.
  - intros [x1 | x2].
    * apply ishprop_hfiber_inl.
    * intros [z p].
      contradiction (inl_ne_inr _ _ p).
Defined.

Global Instance inr_embedding (A B : Type) : IsEmbedding (@inr A B).
Proof.
  - intros [x1 | x2].
    * intros [z p].
      contradiction (inr_ne_inl _ _ p).
    * apply ishprop_hfiber_inr.
Defined.

Class MerelyDecidablePaths A :=
  m_dec_path : forall (a b : A), Decidable(Trunc (-1) (a = b)).

Definition S1_merely_decidable_equality `{Univalence} : MerelyDecidablePaths S1.
Proof.
  simple refine (S1_ind _ _ _) ; simpl.
  - simple refine (S1_ind _ _ _) ; simpl.
    * apply (inl (tr idpath)).
    * apply path_ishprop.
  - apply path_forall.
    intro z.
    rewrite transport_forall, transport_sum.
    destruct
      (transportD (fun _ : S1 => S1)
                  (fun x y : S1 => Decidable (Trunc (-1) (x = y)))
                  loop
                  (transport (fun _ : S1 => S1) loop^ z)
                  (S1_ind
                     (fun x : S1 => Decidable (Trunc (-1) (base = x)))
                     (inl (tr 1%path))
                     (transport_sum loop (inl (tr 1))
                                    @
                                    ap inl
                                    (path_ishprop
                                       (transport
                                          (fun a : S1 => Trunc (-1) (base = a))
                                          loop
                                          (tr 1))
                                       (tr 1)
                                    )
                     )
                     (transport (fun _ : S1 => S1) loop^ z)
                  )
      )
      as [t | n].
    ** revert t.
       revert z.
       simple refine (S1_ind (fun _ => _) _ _) ; simpl.
       *** intros.
           apply path_ishprop.
       *** apply path_forall.
           intro z.
           rewrite transport_forall, transport_paths_FlFr, ap_const.
           hott_simpl.
           apply set_path2.
    ** contradiction n.
       rewrite ?transport_const.
       simple refine (S1_ind (fun q => Trunc (-1) (base = q)) _ _ z) ; simpl.
       *** apply (tr idpath).
       *** apply path_ishprop.
Defined.

Global Instance DecidableToMerely A (H : DecidablePaths A) : MerelyDecidablePaths A.
Proof.
  intros x y.
  destruct (dec (x = y)).
  - apply (inl(tr p)).
  - refine (inr(fun p => _)).
    strip_truncations.
    apply (n p).
Defined.

Section merely_decidable_operations.
  Variable (A B : Type).
  Context `{MerelyDecidablePaths A} `{MerelyDecidablePaths B}.

  Global Instance merely_decidable_paths_prod : MerelyDecidablePaths(A * B).
  Proof.
    intros x y.
    destruct (m_dec_path (fst x) (fst y)) as [p1 | n1],
             (m_dec_path (snd x) (snd y)) as [p2 | n2].
    - apply inl.
      strip_truncations.
      apply tr.
      apply path_prod ; assumption.
    - apply inr.
      intros pp.
      strip_truncations.
      apply (n2 (tr (ap snd pp))).
    - apply inr.
      intros pp.
      strip_truncations.
      apply (n1 (tr (ap fst pp))).
    - apply inr.
      intros pp.
      strip_truncations.
      apply (n1 (tr (ap fst pp))).
  Defined.

  Global Instance merely_decidable_sum : MerelyDecidablePaths (A + B).
  Proof.
    intros [x1 | x2] [y1 | y2].
    - destruct (m_dec_path x1 y1) as [t | n].
      * apply inl.
        strip_truncations.
        apply (tr(ap inl t)).
      * refine (inr(fun p => _)).
        strip_truncations.
        refine (n(tr _)).
        refine (path_sum_inl _ p).
    - refine (inr(fun p => _)).
      strip_truncations.
      refine (inl_ne_inr x1 y2 p).
    - refine (inr(fun p => _)).
      strip_truncations.
      refine (inr_ne_inl x2 y1 p).
    - destruct (m_dec_path x2 y2) as [t | n].
      * apply inl.
        strip_truncations.
        apply (tr(ap inr t)).
      * refine (inr(fun p => _)).
        strip_truncations.
        refine (n(tr _)).
        refine (path_sum_inr _ p).
  Defined.
End merely_decidable_operations.


From FourCerty Require Import Utility.

Import Utility.

Module StackLang.

Inductive ins_val : Type :=
  | V_Int (i : Z)
  | V_Bool (b : bool).

Inductive ins_cmp : Type :=
  | C_Eq
  | C_Ne
  | C_Lt
  | C_Le
  | C_Gt
  | C_Ge.

Definition do_cmp (c : ins_cmp) (i1 : Z) (i2 : Z) :=
  match c with
  | C_Eq => Z.eqb i1 i2
  | C_Ne => negb (Z.eqb i1 i2)
  | C_Lt => Z.ltb i1 i2
  | C_Le => Z.leb i1 i2
  | C_Gt => Z.ltb i2 i1
  | C_Ge => Z.leb i2 i1
  end.

Inductive ins_uop : Type :=
  | U_Add1
  | U_Sub1
  | U_Not.

Definition do_uop (u : ins_uop) (v : ins_val) : result ins_val :=
  match u with
  | U_Add1 =>
    match v with
    | V_Int i => Ok (V_Int (i + 1))
    | _ => Err Error
    end
  | U_Sub1 =>
    match v with
    | V_Int i => Ok (V_Int (i - 1))
    | _ => Err Error
    end
  | U_Not =>
    match v with
    | V_Bool false => Ok (V_Bool true)
    | _ => Ok (V_Bool false)
    end
  end.

Inductive ins_bop : Type :=
  | B_Add
  | B_Sub
  | B_And
  | B_Or.

Definition do_bop (b : ins_bop) (v1 v2 : ins_val) : result ins_val :=
  match b with
  | B_Add =>
    match v1, v2 with
    | V_Int i1, V_Int i2 => Ok (V_Int (i1 + i2))
    | _, _ => Err Error
    end
  | B_Sub =>
    match v1, v2 with
    | V_Int i1, V_Int i2 => Ok (V_Int (i1 - i2))
    | _, _ => Err Error
    end
  | B_And =>
    match v1, v2 with
    | V_Bool b1, V_Bool b2 => Ok (V_Bool (andb b1 b2))
    | _, _ => Err Error
    end
  | B_Or =>
    match v1, v2 with
    | V_Bool b1, V_Bool b2 => Ok (V_Bool (orb b1 b2))
    | _, _ => Err Error
    end
  end.

Inductive stk_ins : Type :=
  | StkErr
  | Call (l : string) (n : nat)
  | Push (v : ins_val)
  | Pop
  | Swap
  | StkRef (n : nat)
  | Uop (u : ins_uop)
  | Bop (b : ins_bop)
  | Cmp (c : ins_cmp).

Inductive stk_tm : Type :=
  | End
  | Ins (ins : stk_ins) (rst : stk_tm)
  | If (thn : stk_tm) (els : stk_tm) (rst : stk_tm).

Inductive stk_fun : Type :=
  Fun (l : string) (n : nat) (ins : stk_tm).

Inductive stk_prg : Type :=
  Prg (funs : list stk_fun) (inss : stk_tm).

Fixpoint extract_funs (funs : list stk_fun) :=
  match funs with
  | nil => empty
  | Fun l n inss :: rst => update (extract_funs rst) l (n, inss)
  end.

Definition eval' (funs : partial_map (nat * stk_tm)) :=
  fix eval_fuel (f : nat) :=
    fix eval_tm (inss : stk_tm) (val_stack : list ins_val) : result (list ins_val) :=
      match inss with
      | End => Ok val_stack
      | Ins ins inss' =>
          match ins with
          | StkErr => Err Error
          | Call l n =>
              let args := firstn n val_stack in
              let rst := skipn n val_stack in
              if List.length args <? n
              then Err Error
              else '(m, inss'') <- lookup funs l;;
                   if m =? n
                   then match f with
                        | O => Err OOF
                        | S f' =>
                            vs <- eval_fuel f' inss'' args;;
                            eval_tm inss' (vs ++ rst)
                        end
                   else Err Error
          | Push v => eval_tm inss' (v :: val_stack)
          | Pop =>
              match val_stack with
              | [] => Err Error
              | v :: rst => eval_tm inss' rst
              end
          | Swap =>
              match val_stack with
              | v1 :: v2 :: rst =>
                  eval_tm inss' (v2 :: v1 :: rst)
              | _ => Err Error
              end
          | StkRef n =>
              match nth_error val_stack n with
              | None => Err Error
              | Some v => eval_tm inss' (v :: val_stack)
              end
          | Uop u =>
              match val_stack with
              | [] => Err Error
              | v :: rst =>
                  v <- do_uop u v;;
                  eval_tm inss' (v :: rst)
              end
          | Bop b =>
              match val_stack with
              | v2 :: v1 :: rst =>
                  v <- do_bop b v1 v2;;
                  eval_tm inss' (v :: rst)
              | _ => Err (ErrorMsg "not enough values on stack")
              end
          | Cmp c =>
              match val_stack with
              | V_Int i2 :: V_Int i1 :: rst =>
                  eval_tm inss' (V_Bool (do_cmp c i1 i2) :: rst)
              | _ => Err Error
              end
          end
      | If thn els nxt =>
          match val_stack with
          | V_Bool false :: rst =>
              vs <- eval_tm els rst;;
              eval_tm nxt vs
          | _ :: rst =>
              vs <- eval_tm thn rst;;
              eval_tm nxt vs
          | _ => Err Error
          end
      end.

Definition eval (f : nat) (prg : stk_prg) :=
  match prg with
  | Prg funs inss => eval' (extract_funs funs) f inss nil
  end.

End StackLang.


(***************************************************************************
 * Tracing sharing in an imperative pure calculus: evaluation
 *
 ***************************************************************************)

Require Import List.

Require Import TypedLanguageSimpl.
Require Import Metatheory.
Require Import Connected.
Require Import Coq.Bool.Bool.

(* Values *)

(** [value exp] holds if [exp] is a value,
           val::= x | n | tr | fls | new C(xs) | {X dvs x}
   [ev_dec dvs] holds
   if the declarations in [dvs] are all evaluated
          dv::= C x=new C(xs)
 *)
Inductive is_var: exp -> Prop :=
   | var_x : forall x, is_var (EVar x).

Inductive value : exp -> Prop :=
   | val_x   : forall x, value (EVar x)
   | val_num : forall n, value (ENum n)
   | val_tr  : value ETrue
   | val_fls : value EFalse
   | val_new : forall C xs,
               (value (ENew C xs))
   | val_blk : forall ann dv dvs x,
               (Forall ev_dec (dv::dvs)) ->
               (is_var x) ->
               (noGarbage (EBlk ann (dv::dvs)  x))->
               (value (EBlk ann (dv::dvs)  x))

with
ev_dec : dec -> Prop :=
   |val_dec : forall C x xs,
               ev_dec   (Dec (DTCl C None) x (ENew C xs)).

Definition Value : Type := { v : exp | value v }.

(** Substitution of one variable with another: alpha rename and alpha congruence *)

Definition rename := (list (var * var)).

Fixpoint rename_var (rn:rename) (x:var)  : var :=
  match rn with
  | nil        => x
  | (z,y)::tlr => ( if (z==x) then y else (rename_var tlr x) )
  end.

Fixpoint rename_vars (rn:rename) (xs:list var)  : list var :=
  match xs with
  | nil    => nil
  | x::tlx => (rename_var rn x)::(rename_vars rn tlx)
  end.

Definition rename_ann (rn:rename) (ann:blAnnotation): blAnnotation := (rename_vars rn ann).

Fixpoint rename_exp (rn:rename) (e:exp) {struct e}: exp :=
  match e with
  | (EVar x)        => (EVar (rename_var rn x))
  | (ENew C xs)     => (ENew C (rename_vars rn xs))
  | (EFld x f)     => (EFld (rename_var rn x) f)
  | (EUpd x1 f x2)  => (EUpd (rename_var rn x1) f (rename_var rn x2))
  | (EBlk a ds e)   => (EBlk (rename_ann rn a)
                        ((fix rename_ds (ds:list dec) : (list dec):=
                          match ds with
                          | nil => nil
                          | (Dec dt z ez)::tl => (Dec dt z (rename_exp rn ez))::(rename_ds tl)
                          end
                         ) ds)
                         (rename_exp rn e))
  | ek              => ek
  end.

Fixpoint rename_ds (rn:rename) (ds:list dec) : (list dec):=
  match ds with
  | nil              => nil
  | (Dec dt z e)::tl => (Dec dt z (rename_exp rn e))::(rename_ds rn tl)
  end.

Fixpoint alpha_rename_ds (x:var) (y:var) (ds:list dec) : list dec :=
  match ds with
  | nil                 => nil
  | (Dec dt z ez)::tlds =>
        if (z==x)  then
          (Dec dt y (rename_exp ((x,y)::nil) ez))::(alpha_rename_ds x y tlds)
        else  (Dec dt z ez)::(alpha_rename_ds x y tlds)
end.

Inductive alpha_cong: exp -> exp -> Prop:=
 | cong_id  : forall e:exp,  alpha_cong e e
 | cong_blk : forall ann ds e dt x ds1 ds2 ds3 ex y,
               (split_dec x ds)=(ds1,ds2) ->
               ds2 = (Dec dt x ex)::ds3 ->
               (not (In y (dec_vars ds))) ->
               alpha_cong (EBlk ann ds  e)
                 (EBlk (rename_ann ((x,y)::nil) ann)
                       (alpha_rename_ds x y ds)
                       (rename_exp ((x,y)::nil) e))
  | cong_trans : forall e1 e2 e3,
                 (alpha_cong e1 e2) ->
                 (alpha_cong e2 e3) ->
                 (alpha_cong e1 e3)
  | cong_sym : forall e1 e2,
               (alpha_cong e1 e2) ->
               (alpha_cong e2 e1)

with alpha_cong_es: (list exp) -> (list exp) -> Prop:=
  | cong_nil  : alpha_cong_es nil nil
  | cong_cons : forall e e' es es',
                alpha_cong e e' ->
                alpha_cong_es es es' ->
                alpha_cong_es (e::es) (e'::es').

(** [fresh_vars n ys], returns a list of n different fresh variables such that none
  of them is in [ys] *)

Definition fresh_var (xs:list var) : var :=(proj1_sig (atom_fresh_for_list xs)).

Fixpoint fresh_vars (n:nat)  (ys:list var) : list var :=
  match n with
  | 0     => nil
  | (S m) => (let z:=(proj1_sig (atom_fresh_for_list ys)) in
                z::(fresh_vars m (z::ys)))
end.

Definition zip : list var -> list var -> list (var * var) := @combine var var.

Fixpoint alpha_renames_ds (rn:rename) (ds:list dec): list dec :=
  match rn with
  | nil        => ds
  | (x,y)::tlr => alpha_renames_ds tlr (alpha_rename_ds x y ds)
  end.

Definition mk_block_with_def (x:var) (C:cname) (v:Value) (body:exp) :=
     (EBlk (x::nil) ((Dec (DTCl C None) x (proj1_sig v))::nil)  body).

(** Substitution [subst x C e e'] returns e' in which free occurrences of x are substituted
   with e, where [C] is the class of [e]. We assume that [e] is a value associated with an
   affine variable, so it is a closed value (no free variable can be captured). *)

Fixpoint subst (x:var) C (e:Value) (e':exp) {struct e'} : exp :=
  match e' with
  | (EVar y)         => if (y==x) then (proj1_sig e) else e'
  | (ENew C xs)      => if (is_in x xs) then  (mk_block_with_def x C e (ENew C xs))
                       else e'
  | (EFld y f)      => if (y==x) then (mk_block_with_def x C e (EFld y f))
                       else e'
  | (EUpd y1 f y2)   => if (is_in x (y1::y2::nil)) then (mk_block_with_def x C e (EUpd y1 f y2))

                        else e'
  | (EBlk ann ds eb) =>
       EBlk ann ((fix subst_ds (ds: list dec) {struct ds}: (list dec) :=
                    match ds with
                    | nil                 => nil
                    | (Dec dt z ez)::tlds => (Dec dt z  (subst C x e ez) )::(subst_ds tlds)
                    end
                  ) ds)
                (subst C x e  eb)
  | _ => e'
end.

(** Evaluation contexts *)

Inductive ev_ctx : Type :=
   | Hole    : ev_ctx
   | ECBlDec   : blAnnotation -> (list dec) -> ev_dec_ctx -> (list dec) -> exp ->  ev_ctx
   | ECBlBody  : blAnnotation -> (list dec) -> ev_ctx -> ev_ctx

with ev_dec_ctx : Type :=
   ECDec : decTy -> var -> ev_ctx -> ev_dec_ctx.

(** Evaluation contexts to be used in the evalution: specify the evaluation order *)

Inductive  ok_ev_ctx : ev_ctx ->Prop :=
   | ok_hole   : ok_ev_ctx Hole
   | ok_Dec    : forall ann dvs ds eb eC dty x,
                             (Forall ev_dec dvs)->
                             (Forall (fun d => ~ ev_dec d) ds)->
                             (ok_ev_ctx eC)->
                             ok_ev_ctx (ECBlDec ann dvs (ECDec dty x eC) ds  eb)
   | ok_Body   : forall ann dvs eC,
                             (Forall ev_dec dvs) ->
                             (ok_ev_ctx eC) ->
                             ok_ev_ctx (ECBlBody ann dvs eC).

Fixpoint vars2exps vs:list exp :=
match  vs with
| nil => nil
| x::tl =>(EVar x)::(vars2exps tl)
end.

(** Returns the expression evCtx[e] *)

Fixpoint apply_ev_ctx eC e  {struct eC}: exp :=
match eC with
| Hole  => e
| (ECBlDec ann dvs (ECDec dt x ebC) ds eb) =>
         (EBlk ann (dvs++((Dec dt x (apply_ev_ctx ebC e))::nil)++ds) eb)
| (ECBlBody ann dvs eCB) =>  (EBlk ann dvs (apply_ev_ctx eCB e))
end.

(** Returns true if x is declared in the evaluated declarations of eC false otherwise *)
Fixpoint is_dec_ctx eC x  {struct eC}: bool :=
match eC with
| Hole  => false
| (ECBlDec ann dvs (ECDec dt y ebC) ds eb) =>
    if (dec_in_ds x dvs) then
      true
    else
      (is_dec_ctx ebC x)
| (ECBlBody ann dvs eCx) =>
    if (dec_in_ds x dvs) then
      true
    else
      (is_dec_ctx eCx x)
end.

(** Returns the innermost declaration of x if x is declared in the evaluated declarations of eC  *)
Fixpoint dec_ctx eC x  {struct eC}: option dec :=
match eC with
| Hole  => None
| (ECBlDec ann dvs (ECDec dt y ebC) ds eb) =>
    if ((dec_in_ds x dvs) && (negb(is_dec_ctx ebC x))) then
      (get_dec_in_ds x dvs)
    else
      (dec_ctx ebC x)
| (ECBlBody ann dvs eCx) =>
    if ((dec_in_ds x dvs) && (negb(is_dec_ctx eCx x))) then
      (get_dec_in_ds x dvs)
    else
      (dec_ctx eCx x)
end.

Definition dec_ctx_P eC x d: Prop := dec_ctx eC x=Some d.

(** Given an evaluation context, eC, and a variable, x, declared inside one of its blocks
   returns a pair of evaluation contexts (eCx,eCr) such that eC=eCx[eCr] and eCx={dvs []}
   or eCx={dvs T y=[] ds2 eb} and x is declared in dvs **)

Fixpoint ev_ctx_dec_x eC x  {struct eC}: (ev_ctx * ev_ctx) :=
match eC with
| Hole  => (Hole,Hole)
| (ECBlDec ann dvs (ECDec dt y eCx) ds eb) =>
    if ((dec_in_ds x dvs) && (negb(is_dec_ctx eCx x))) then
      ((ECBlDec ann dvs (ECDec dt y Hole) ds eb),eCx)
    else
      let (eC1,eC2):=(ev_ctx_dec_x  eCx x) in
        ((ECBlDec ann dvs (ECDec dt y eC1) ds eb),eC2)
| (ECBlBody ann dvs eCx) =>
    if ((dec_in_ds x dvs) && (negb(is_dec_ctx eCx x))) then
      ((ECBlBody ann dvs Hole),eCx)
    else
      let (eC1,eC2):=(ev_ctx_dec_x  eCx x) in
        ((ECBlBody ann dvs eC1),eC2)
end.

(**  Redexes:  x.f | x.f=y | {X dvs C^a x=v ds e} | {X dvs C x=(y | tr | fls | n) ds e}
             |

*)
(**
  Decomposition: given [e] not a value returns eC and e' such that e=eC[e']
  and e' is either [x.f] or  [x.f=y] or [{X dvs C^Affine x=v ds e}]
  or [{X dvs C^_ x=y ds e}] or ..............
*)

(*

Inductive eval : ev_ctx -> exp -> exp -> Prop :=
| eval_fld : forall  eC x t C es f fs fes e,
    dec_ctx_P eC x (Dec t x (ENew C es)) ->
    fields C fs ->
    env_zip fs es fes ->
    binds f e fes ->
    eval eC (EFld x f)
|eval_udp:

    eval eC (EUpd (EVar x) f (EVar y)) eC' e (EVar y).

*)


From Undecidability.StackMachines Require Import BSM BSM.bsm_defs.
From Undecidability.TM Require Import SBTM Util.SBTM_facts.
From Undecidability.Shared.Libs.DLW Require Import vec subcode sss.

Require Import List Lia.
Import Vector.VectorNotations ListNotations SBTMNotations.
#[local] Open Scope list_scope.

Require Import ssreflect ssrbool ssrfun.

Set Default Proof Using "Type".
Set Default Goal Selector "!".

#[local] Notation "P // s -[ k ]-> t" := (sss_steps (@bsm_sss _) P k s t).
#[local] Notation "P // s ->> t" := (sss_compute (@bsm_sss _) P s t).
#[local] Notation CURR := (@Fin.FS 3 (@Fin.F1 2)).
#[local] Notation LEFT := (@Fin.F1 3).
#[local] Notation RIGHT := (@Fin.FS 3 (@Fin.FS 2 (@Fin.F1 1))).
#[local] Notation ZERO := (@Fin.FS 3 (@Fin.FS 2 (@Fin.FS 1 (@Fin.F1 0)))).

(* induction principle wrt. a decreasing measure f *)
(* example: elim /(measure_ind length) : l. *)
Lemma measure_ind {X : Type} (f : X -> nat) (P : X -> Prop) :
(forall x, (forall y, f y < f x -> P y) -> P x) -> forall (x : X), P x.
Proof.
  exact: (well_founded_ind (Wf_nat.well_founded_lt_compat X f _ (fun _ _ => id)) P).
Qed.

Section Construction.

  Context (M : SBTM) (q0 : state M).

  #[local] Notation δ := (trans' M).

  Definition c := 13.

  #[local] Arguments Vector.cons {A} _ {n}.

  Definition encode_tape (t : tape) : Vector.t (list bool) 4 :=
    match t with
    | (ls, a, rs) => [ ls ; [a]%list ; rs ; []%list ]%vector
    end.

  Definition encode_state (q : state M) := (2 + sval (Fin.to_nat q) * c).

  #[local] Arguments encode_state : simpl never.
  #[local] Notation "! p" := (encode_state p) (at level 1).

  Definition encode_config '(q, t) : bsm_state 4 := (!q, encode_tape t).

  #[local] Notation JMP i := (POP ZERO i i).

  Definition box '(q, a) (f : (state M * bool * direction) -> bsm_instr 4) : bsm_instr 4 :=
    match δ (q, a) with
    | None => JMP 0
    | Some t => f t
    end.

  Definition CURR' := CURR. (* to distinguish duplicate operations for subcode_tac *)

  Definition PROG (q : state M) :=
    let off := !q in
  (*      off *) POP CURR (7 + off) (7 + off) ::

  (*  1 + off *) box (q, true) (fun '(q', a', d) => PUSH (match d with go_left => RIGHT | go_right => LEFT end) a') ::
  (*  2 + off *) box (q, true) (fun '(q', a', d) => POP (match d with go_left => LEFT | go_right => RIGHT end) (5+off) (5+off)) ::
  (*  3 + off *) PUSH CURR true ::
  (*  4 + off *) JMP (6 + off) ::
  (*  5 + off *) PUSH CURR false ::
  (*  6 + off *) box (q, true) (fun '(q', a', d) => JMP (!q')) ::

  (*  7 + off *) box (q, false) (fun '(q', a', d) => PUSH (match d with go_left => RIGHT | go_right => LEFT end) a') ::
  (*  8 + off *) box (q, false) (fun '(q', a', d) => POP (match d with go_left => LEFT | go_right => RIGHT end) (11+off) (11+off)) ::
  (*  9 + off *) PUSH CURR' true ::
  (* 10 + off *) JMP (12 + off) ::
  (* 11 + off *) PUSH CURR' false ::
  (* 12 + off *) box (q, false) (fun '(q', a', d) => JMP (!q')) :: [].

  Lemma PROG_length q : length (PROG q) = c.
  Proof. reflexivity. Qed.

  Opaque c.

  Fixpoint all_fins (n : nat) : list (Fin.t n) :=
    if n is S n' then Fin.F1 :: map Fin.FS (all_fins n') else nil.

  (* constructed BSM *)
  Definition P : list (bsm_instr 4) :=
    JMP (!q0) :: flat_map PROG (all_fins (num_states M)).

  Lemma P_length : length P = 1 + num_states M * c.
  Proof.
    rewrite /P /=. congr S. have := PROG_length.
    elim: (num_states M) (PROG); first done.
    move=> n IH PROG' H. have ->: S n * c = n * c + c by lia.
    rewrite /= app_length flat_map_concat_map map_map -flat_map_concat_map H.
    by rewrite IH; [|lia].
  Qed.

  Definition Q_step (Q : list (bsm_instr 4)) offset i v : option (bsm_state 4) :=
    match nth_error Q i with
    | None => None
    | Some (bsm_pop x p' q') => Some (
        match vec_pos v x with
        | [] => (q', v)
        | false :: l => (p', vec_change v x l)
        | true :: l => ((S i) + offset, vec_change v x l)
        end)
    | Some (bsm_push x b) => Some ((S i) + offset, vec_change v x (b :: vec_pos v x))
    end.

  Arguments Q_step : simpl never.

  Lemma Q_step_spec (Q : list (bsm_instr 4)) offset i v j w :
    Q_step Q offset i v = Some (j, w) ->
    sss_step (bsm_sss (n:=4)) (offset, Q) (i + offset, v) (j, w).
  Proof.
    rewrite /Q_step. case E: (nth_error Q i) => [t|]; last done.
    move: E => /(@nth_error_split (bsm_instr 4)) => - [l] [r] [-> <-].
    move=> Ht. exists offset, l, t, r, v. split; [|split]; [done|congr pair; lia|].
    move: t Ht => [].
    - move=> x p' q' [<-].
      move Ex: (vec_pos v x) => [|[] ?]; by auto using bsm_sss.
    - move=> x b [<-] <-. by auto using bsm_sss.
  Qed.

  Arguments nth_error : simpl never.

  Lemma PROG_spec_Some q t q' t' : step M (q, t) = Some (q', t') ->
    exists k, (!q, PROG q) // (encode_config (q, t)) -[S k]-> (encode_config (q', t')).
  Proof.
    move: t => [[ls a] rs] /=. rewrite /step.
    case E: (δ (q, a)) => [[[??]d]|]; last done.
    move=> [<- <-]. have ->: !q = 0 + !q by done.
    move: d a ls rs E => [] [] [|[] ls] [|[] rs] E.
    all: eexists; rewrite /PROG /box E.
    all: do ? ((by apply: in_sss_steps_0) || (apply: in_sss_steps_S; [by apply: Q_step_spec|])).
  Qed.

  Lemma PROG_spec_None q t : step M (q, t) = None ->
    exists v, (!q, PROG q) // (encode_config (q, t)) ->> (0, v).
  Proof.
    move: t => [[ls a] rs] /=. rewrite /step.
    case E: (δ (q, a)) => [[[??]d]|]; first done.
    move=> _. have ->: !q = 0 + !q by done.
    move: a E => [] E.
    all: exists [ ls ; []%list ; rs ; []%list ]%vector.
    all: eexists; rewrite /PROG /box E.
    all: do ? ((by apply: in_sss_steps_0) || (apply: in_sss_steps_S; [by apply: Q_step_spec|])).
  Qed.

  Lemma PROG_sc (q : state M) : (!q, PROG q) <sc (1, P).
  Proof.
    apply: subcode_cons. rewrite /P /encode_state [1+1]/=.
    suff: forall n, (n + sval (Fin.to_nat q) * c, PROG q) <sc
      (n, flat_map PROG (all_fins (num_states M))) by done.
    have := PROG_length. move: (num_states M) q (PROG) => ?.
    elim. { move=> /= *. by eexists [], _. }
    move=> m q IH PROG' H' n.
    have := IH (fun q => PROG' (Fin.FS q)) => /(_ ltac:(done) (n+c)).
    rewrite /= !flat_map_concat_map map_map -!flat_map_concat_map.
    move=> [l] [r] [{}IH {}IH']. exists (PROG' Fin.F1 ++ l), r. split.
    - by rewrite IH -app_assoc.
    - move: (Fin.to_nat q) IH' => [? ?] /=. rewrite app_length H'. lia.
  Qed.

  Opaque P.

  Lemma simulation_step_Some q t q' t' : step M (q, t) = Some (q', t') ->
    exists k, (1, P) // (encode_config (q, t)) -[S k]-> (encode_config (q', t')).
  Proof.
    move=> /PROG_spec_Some [k] H. exists k.
    apply: subcode_sss_steps; [|by eassumption].
    by apply: PROG_sc.
  Qed.

  Lemma simulation_step_None q t : step M (q, t) = None ->
    exists v, (1, P) // (encode_config (q, t)) ->> (0, v).
  Proof.
    move=> /PROG_spec_None [v Hv]. exists v.
    by apply: subcode_sss_compute; [apply: PROG_sc|].
  Qed.

  Lemma simulation q t k :
    steps M k (q, t) = None ->
    exists v, (1, P) // (encode_config (q, t)) ->> (0, v).
  Proof.
    elim: k q t; first done.
    move=> k IH q t. rewrite (steps_plus 1) /=.
    case E: (step M (q, t)) => [[q' t']|].
    - move=> /IH [v] Hv. exists v.
      move: E => /simulation_step_Some [?] /sss_steps_compute /sss_compute_trans.
      by apply.
    - by move: E => /simulation_step_None.
  Qed.

  Lemma inverse_simulation q t n i v :
    (1, P) // (encode_config (q, t)) -[n]-> (i, v) ->
    out_code i (1, P) ->
    exists k, steps M k (q, t) = None.
  Proof.
    elim /(@measure_ind nat id) : n q t => - [|n] IH q t.
    { move=> /sss_steps_0_inv [] /= <- _.
      rewrite /encode_state P_length (ltac:(done) : c = (S (c-1))).
      have := svalP (Fin.to_nat q). nia. }
    case E: (step M (q, t)) => [[q' t']|]; last by (move=> _; exists 1).
    move: (E) => /simulation_step_Some [m].
    move=> Hn Hm Hi. have := (IH (n - m) ltac:(lia) q' t' _ Hi).
    case.
    { move: Hn Hm Hi => /subcode_sss_subcode_inv /[apply] /[apply].
      case.
      - by exact: bsm_sss_fun.
      - by apply: subcode_refl.
      - move=> n' [?]. by have ->: n' = n - m by lia. }
    move=> k Hk. exists (1+k). by rewrite (steps_plus 1) /= E.
  Qed.

End Construction.

Require Import Undecidability.Synthetic.Definitions.

Theorem reduction :
  SBTM_HALT ⪯ BSM_HALTING.
Proof.
  exists (fun '(existT _ M (q, t)) =>
    existT _ 4 (existT _ 1 (existT _ (@P M q) (encode_tape t)))).
  move=> [M [q [[ls a] rs]]]. split.
  - move=> [k] /simulation => /(_ q) [v Hv] /=.
    exists (0, v). split => /=; [|lia].
    rewrite /P.
    bsm sss POP empty with ZERO (encode_state M q) (encode_state M q).
  - move=> [] [i v] [] [?] H /= ?.
    rewrite /P in H.
    bsm inv POP empty with H ZERO (encode_state M q) (encode_state M q).
    + move: H => [?] [?] /inverse_simulation. by apply.
    + move=> []. lia.
Qed.


Require Import term.

Definition value (t:Term) : Prop :=
    match t with
    | VarTerm _     => False
    | AbsTerm _ _   => True
    | AppTerm _ _   => False
    | TAbsTerm _ _  => True
    | TAppTerm _ _  => False
    end.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Class ClassicalPropositionalLogic (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} := {
  excluded_middle: forall x, |-- x || ~~ x
}.

Class ClassicalPropositionalSequentCalculus (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} (Gamma: ProofTheory L) {bSC: BasicSequentCalculus L Gamma} {minSC: MinimunSequentCalculus L Gamma} {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma} := {
  derivable_excluded_middle: forall Phi x, Phi |-- x || ~~ x
}.

Section Axiomatization2SequentCalculus.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: ProofTheory L}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {cpGamma: ClassicalPropositionalLogic L Gamma}
        {SC: NormalSequentCalculus L Gamma}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimunSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}.

Lemma Axiomatization2SequentCalculus_cpSC: ClassicalPropositionalSequentCalculus L Gamma.
Proof.
  intros.
  constructor.
  intros.
  apply deduction_weaken0.
  apply excluded_middle.
Qed.

End Axiomatization2SequentCalculus.

Section AddSequentCalculus.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: ProofTheory L}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {cpGamma: ClassicalPropositionalLogic L Gamma}
        {minAX': MinimunAxiomatization L (Build_AxiomaticProofTheory (@provable L Gamma))}
        {ipGamma': IntuitionisticPropositionalLogic L (Build_AxiomaticProofTheory (@provable L Gamma))}
        {SC: NormalSequentCalculus L (Build_AxiomaticProofTheory (@provable L Gamma))}
        {bSC: BasicSequentCalculus L (Build_AxiomaticProofTheory (@provable L Gamma))}
        {minSC: MinimunSequentCalculus L (Build_AxiomaticProofTheory (@provable L Gamma))}
        {ipSC: IntuitionisticPropositionalSequentCalculus L (Build_AxiomaticProofTheory (@provable L Gamma))}.

Lemma MakeSequentCalculus_ClassicalPropositionalLogic:
  Typeclass_Rewrite (exist (fun X: Prop => X) (IntuitionisticPropositionalLogic L (Build_AxiomaticProofTheory (@provable L Gamma))) ipGamma' :: exist (fun X: Prop => X) (IntuitionisticPropositionalSequentCalculus L (Build_AxiomaticProofTheory (@provable L Gamma))) ipSC :: exist (fun X: Prop => X) (BasicSequentCalculus L (Build_AxiomaticProofTheory (@provable L Gamma))) bSC :: exist (fun X: Prop => X) (MinimunSequentCalculus L (Build_AxiomaticProofTheory (@provable L Gamma))) minSC :: nil) ->
  forall (G: Prop) (l: list (sig (fun X: Prop => X))),
  (forall
     (cpSC: ClassicalPropositionalSequentCalculus L (Build_AxiomaticProofTheory (@provable L Gamma)))
     (cpGamma: ClassicalPropositionalLogic L (Build_AxiomaticProofTheory (@provable L Gamma))),
     OpaqueProp (Typeclass_Rewrite l -> G)) <->
  OpaqueProp (Typeclass_Rewrite ((exist (fun X: Prop => X) (ClassicalPropositionalLogic L Gamma) cpGamma) :: l) -> G).
Proof.
  unfold OpaqueProp.
  intros _.
  intros.
  split; intros.
  + clear H0.
    assert (ClassicalPropositionalLogic L (Build_AxiomaticProofTheory provable))
      by (destruct cpGamma; constructor; auto).
    apply H; auto.
    - apply Axiomatization2SequentCalculus_cpSC.
    - apply Typeclass_Rewrite_I.
  + apply H; auto.
    apply Typeclass_Rewrite_I.
Qed.

End AddSequentCalculus.

Hint Rewrite <- @MakeSequentCalculus_ClassicalPropositionalLogic using first [typeclasses eauto | instantiate (1 := _); instantiate (1 := _); instantiate (1 := _); instantiate_must_succeed; apply Typeclass_Rewrite_I]: AddSC.

Section SequentCalculus2Axiomatization.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: ProofTheory L}
        {SC: NormalSequentCalculus L Gamma}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimunSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}
        {cpSC: ClassicalPropositionalSequentCalculus L Gamma}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}.

Lemma SequentCalculus2Axiomatization_cpGamma: ClassicalPropositionalLogic L Gamma.
Proof.
  intros.
  constructor.
  intros.
  rewrite provable_derivable.
  apply derivable_excluded_middle.
Qed.

End SequentCalculus2Axiomatization.

Section AddAxiomatization.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: ProofTheory L}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimunSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}
        {cpSC: ClassicalPropositionalSequentCalculus L Gamma}
        {minAX: MinimunAxiomatization L (Build_SequentCalculus (@derivable L Gamma))}
        {ipGamma: IntuitionisticPropositionalLogic L (Build_SequentCalculus (@derivable L Gamma))}
        {SC': NormalSequentCalculus L (Build_SequentCalculus (@derivable L Gamma))}
        {bSC': BasicSequentCalculus L (Build_SequentCalculus (@derivable L Gamma))}
        {minSC': MinimunSequentCalculus L (Build_SequentCalculus (@derivable L Gamma))}
        {ipSC': IntuitionisticPropositionalSequentCalculus L (Build_SequentCalculus (@derivable L Gamma))}.

Lemma MakeAxiomatization_ClassicalPropositionalSequentCalculus:
  Typeclass_Rewrite (exist (fun X: Prop => X) (IntuitionisticPropositionalLogic L (Build_SequentCalculus (@derivable L Gamma))) ipGamma :: exist (fun X: Prop => X) (IntuitionisticPropositionalSequentCalculus L (Build_SequentCalculus (@derivable L Gamma))) ipSC' :: exist (fun X: Prop => X) (BasicSequentCalculus L (Build_SequentCalculus (@derivable L Gamma))) bSC' :: exist (fun X: Prop => X) (MinimunSequentCalculus L (Build_SequentCalculus (@derivable L Gamma))) minSC' :: nil) ->
  forall (G: Prop) (l: list (sig (fun X: Prop => X))),
  (forall
     (cpSC: ClassicalPropositionalSequentCalculus L (Build_SequentCalculus (@derivable L Gamma)))
     (cpGamma: ClassicalPropositionalLogic L (Build_SequentCalculus (@derivable L Gamma))),
     OpaqueProp (Typeclass_Rewrite l -> G)) <->
  OpaqueProp (Typeclass_Rewrite ((exist (fun X: Prop => X) (ClassicalPropositionalSequentCalculus L Gamma) cpSC) :: l) -> G).
Proof.
  unfold OpaqueProp.
  intros _.
  intros.
  split; intros.
  + clear H0.
    assert (ClassicalPropositionalSequentCalculus L (Build_SequentCalculus (@derivable L Gamma)))
      by (destruct cpSC; constructor; auto).
    apply H; auto.
    - apply SequentCalculus2Axiomatization_cpGamma.
    - apply Typeclass_Rewrite_I.
  + apply H; auto.
    apply Typeclass_Rewrite_I.
Qed.

End AddAxiomatization.

Hint Rewrite <- @MakeAxiomatization_ClassicalPropositionalSequentCalculus using first [typeclasses eauto | instantiate (1 := _); instantiate (1 := _); instantiate (1 := _); instantiate_must_succeed; apply Typeclass_Rewrite_I]: AddAX.

Section DerivableRulesFromAxiomatization1.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: ProofTheory L}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {cpGamma: ClassicalPropositionalLogic L Gamma}.

Lemma double_negp_elim: forall (x: expr),
  |-- ~~ (~~ x) --> x.
Proof.
  AddSequentCalculus Gamma.
  intros.
  unfold negp.
  pose proof orp_elim x (x --> FF) (((x --> FF) --> FF) --> x).
  pose proof axiom1 x ((x --> FF) --> FF).
  pose proof modus_ponens _ _ H H0.
  clear H H0.

  pose proof derivable_contradiction_elim empty_context (x --> FF) x.
  rewrite <- provable_derivable in H.
  pose proof modus_ponens _ _ H1 H.
  clear H H1.

  pose proof excluded_middle x.
  pose proof modus_ponens _ _ H0 H.
  auto.
Qed.

Lemma double_negp: forall (x: expr),
  |-- ~~ (~~ x) <--> x.
Proof.
  AddSequentCalculus Gamma.
  intros.
  rewrite provable_derivable.
  apply deduction_andp_intros;
  rewrite <- provable_derivable.
  + apply double_negp_elim.
  + apply double_negp_intros.
Qed.

Instance Classical2GodelDummett: GodelDummettPropositionalLogic L Gamma.
Proof.
  constructor.
  AddSequentCalculus Gamma.
  intros.
  rewrite provable_derivable.
  set (Phi := empty_context).
  clearbody Phi.
  pose proof excluded_middle x.
  apply deduction_weaken0 with (Phi0 := Phi) in H.
  eapply deduction_modus_ponens; [exact H |].
  apply deduction_orp_elim'.
  + rewrite <- deduction_theorem.
    apply deduction_orp_intros2.
    rewrite deduction_theorem.
    apply derivable_axiom1.
  + rewrite <- deduction_theorem.
    apply deduction_orp_intros1.
    rewrite deduction_theorem.
    apply deduction_impp_arg_switch.
    apply derivable_contradiction_elim.
Qed.

Lemma contrapositiveNN: forall (x y: expr),
  |-- (~~ y --> ~~ x) --> (x --> y).
Proof.
  AddSequentCalculus Gamma.
  intros.
  rewrite <- (double_negp_elim y) at 2.
  rewrite provable_derivable.
  rewrite <- deduction_theorem.
  apply deduction_contrapositivePN.
  solve_assum.
Qed.

Lemma contrapositiveNP: forall (x y: expr),
  |-- (~~ y --> x) --> (~~ x --> y).
Proof.
  AddSequentCalculus Gamma.
  intros.
  rewrite <- (contrapositiveNN (~~ x) y).
  rewrite <- (double_negp_intros x).
  apply provable_impp_refl.
Qed.

End DerivableRulesFromAxiomatization1.

Section DerivableRulesFromSequentCalculus.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: ProofTheory L}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimunSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}
        {cpSC: ClassicalPropositionalSequentCalculus L Gamma}.

Lemma deduction_contrapositiveNN: forall Phi (x y: expr),
  Phi |-- ~~ y --> ~~ x ->
  Phi |-- x --> y.
Proof.
  AddAxiomatization Gamma.
  intros.
  rewrite <- contrapositiveNN.
  auto.
Qed.

Lemma deduction_contrapositiveNP: forall Phi (x y: expr),
  Phi |-- ~~ y --> x ->
  Phi |-- ~~ x --> y.
Proof.
  AddAxiomatization Gamma.
  intros.
  rewrite <- contrapositiveNP.
  auto.
Qed.

End DerivableRulesFromSequentCalculus.

Section DerivableRulesFromAxiomatization2.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: ProofTheory L}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {cpGamma: ClassicalPropositionalLogic L Gamma}.

Lemma impp2orp: forall (x y: expr),
  |-- (x --> y) <--> (~~ x || y).
Proof.
  AddSequentCalculus Gamma.
  intros.
  rewrite provable_derivable.
  apply deduction_andp_intros.
  + rewrite <- deduction_theorem.
    apply (deduction_modus_ponens _ (x || ~~ x)); [apply derivable_excluded_middle |].
    apply deduction_orp_elim'.
    - rewrite <- deduction_theorem.
      apply deduction_orp_intros2.
      rewrite -> deduction_theorem.
      apply derivable_assum1.
    - rewrite <- deduction_theorem.
      apply deduction_orp_intros1.
      apply derivable_assum1.
  + apply deduction_orp_elim'.
    - rewrite <- deduction_theorem.
      rewrite <- deduction_theorem.
      apply deduction_falsep_elim.
      rewrite -> deduction_theorem.
      apply derivable_assum1.
    - apply derivable_axiom1.
Qed.

End DerivableRulesFromAxiomatization2.


From isla Require Import opsem.

Definition a1c : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  Assume (AExp_Binop (Eq) (AExp_Unop (Extract 1%N 1%N) (AExp_Val (AVal_Var "x1" []) Mk_annot) Mk_annot) (AExp_Val (AVal_Bits (BV 1%N 0x0%Z)) Mk_annot) Mk_annot) Mk_annot :t:
  Smt (DeclareConst 1%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
  Smt (DefineConst 2%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 1%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  ReadReg "x1" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 7%Z (Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 64%N 0xfffffffffffffffe%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 8%Z (Unop (Extract 0%N 0%N) (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 7%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x1%Z)) Mk_annot) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "PC" [] (RegVal_Base (Val_Symbolic 7%Z)) Mk_annot :t:
  tnil
.


(* First-Order Formulas *)

(* arity check based on vectors *)

From Coq Require Vector.
From Quantifiers Require Export foterms_vec.

Set Implicit Arguments.

Notation vec := Vector.t.

(** * First-Order Formulas *)

Section Formulas.

Context {vatom : DecType} {tatom : Type} {tarity : tatom -> nat}.
Notation term := (@term vatom tatom tarity).
Arguments evar _ _ _ {T}.
Notation evar := (evar vatom tatom tarity).

Notation "r ;; s" := (fecomp r s) (at level 20, format "r  ;;  s").
Notation closed t := (tvars t = nil).
Notation "⇑" := fup.
Notation "⇑[ u ] r" := (felift u r) (at level 25, format "⇑[ u ] r").

Hint Rewrite (@tesubs_evar vatom tatom) : term_db.
Hint Rewrite (@tesubs_comp vatom tatom) : term_db.
Hint Rewrite (@tsubs_tsubs_eq vatom tatom) : term_db.
Hint Rewrite (@tsubs_tsubs vatom tatom)
                        using try (intuition; fail);
                             (try apply closed_notvars); intuition; fail : term_db.
Hint Rewrite (@tvars_tesubs_closed vatom tatom) using intuition; fail : term_db.
Hint Rewrite (@tvars_tsubs_closed vatom tatom) using intuition; fail : term_db.
Hint Rewrite (@notin_tsubs vatom tatom)
                         using try easy;
                              (try (intuition; fail));
                              (try apply closed_notvars); intuition; fail : term_db.
Hint Rewrite (@notin_tsubs_bivar vatom tatom)
                               using try easy;
                                    (try (intuition; fail));
                                    (try apply closed_notvars); intuition; fail : term_db.
Hint Rewrite (@tsubs_tesubs vatom tatom) using try (intuition; fail) : term_db.

Hint Resolve tesubs_ext : term_db.
Hint Resolve closed_notvars : term_db.

Context {fatom : Type}.  (* relation symbols for [formula] *)
Context {farity : fatom -> nat}.  (* arity of relation symbols *)
(* Generic sets of connectives *)
Context {NCon : Type}. (* nullary connectives *)
Context {UCon : Type}. (* unary connectives *)
Context {BCon : Type}. (* binary connectives *)
Context {QCon : Type}. (* quantifiers *)

(** formulas *)
(** first-order formulas *)
Inductive formula T :=
| fvar R : vec (term T) (farity R) -> formula T
| fnul : NCon -> formula T
| funa : UCon -> formula T -> formula T
| fbin : BCon -> formula T -> formula T -> formula T
| fqtf : QCon -> vatom -> formula T -> formula T.
Arguments fvar {T} R _.
Arguments fnul {T} _.
(* Nullary connectives in [NCon] and [fnul] are mostly redundant with [fvar f nil] *)

Ltac formula_induction A :=
  (try intros until A) ;
  let XX := fresh "X" in
  let xx := fresh "x" in
  let ncon := fresh "ncon" in
  let ucon := fresh "ucon" in
  let bcon := fresh "bcon" in
  let qcon := fresh "qcon" in
  let A1 := fresh A in
  let A2 := fresh A in
  let ll := fresh "l" in
  let lll := fresh "l" in
  let tt := fresh "t" in
  let kk := fresh "k" in
  let IHll := fresh "IHl" in
  induction A as [ XX ll | ncon | ucon A ? | bcon A1 ? A2 ? | qcon xx A ]; simpl; intros;
  [ rewrite ? flat_map_concat_map;
    try (apply (f_equal (fvar _)));
    try (induction ll as [ | tt kk lll IHll ]; simpl; intuition;
         rewrite IHll; f_equal; intuition)
  | try ((try f_equal); intuition; fail)
  | try (apply (f_equal (funa _))); intuition
  | try (apply (f_equal2 (fbin _))); intuition
  | (try apply (f_equal (fqtf _ _))); repeat case_analysis; try (intuition; fail);
     try (now rcauto) ];
  try (now rcauto).

(** * Size of [formula] *)

Fixpoint fsize T (A : formula T) :=
match A with
| fvar _ _ => 1
| fnul _ => 1
| funa _ B => S (fsize B)
| fbin _ B C => S (fsize B + fsize C)
| fqtf _ _ B => S (fsize B)
end.

(** * Substitution of eigen variables in [formula] *)

(** substitutes the [term] [r n] for index [n] in [formula] [A] *)
(* capture is not avoided *)
Fixpoint esubs T1 T2 (r : T1 -> term T2) (A : formula T1) :=
match A with
| fvar X l => fvar X (Vector.map (tesubs r) l)
| fnul ncon => fnul ncon
| funa ucon B => funa ucon (esubs r B)
| fbin bcon B C => fbin bcon (esubs r B) (esubs r C)
| fqtf qcon x B => fqtf qcon x (esubs r B)
end.
Notation "A ⟦ r ⟧" := (esubs r A) (at level 8, left associativity, format "A ⟦ r ⟧").

Lemma fsize_esubs T1 T2 : forall (r : T1 -> term T2) A, fsize A⟦r⟧ = fsize A.
Proof. formula_induction A. Qed.
Hint Rewrite fsize_esubs : term_db.

Lemma esubs_evar T : forall (A : formula T),
  A⟦evar⟧ = A.
Proof. formula_induction A. Qed.
Hint Rewrite esubs_evar : term_db.

Lemma esubs_comp T1 T2 T3 (r : T1 -> term T2) (s : T2 -> term T3) :
  forall A, A⟦r⟧⟦s⟧ = A⟦r ;; s⟧.
Proof. formula_induction A. Qed.
Hint Rewrite esubs_comp : term_db.

(* the result of substitution depends extensionnaly on the substituting function *)
Lemma esubs_ext T1 T2 (r1 r2 : T1 -> term T2) : r1 ~ r2 -> forall A, A⟦r1⟧ = A⟦r2⟧.
Proof. formula_induction A. Qed.

(** * Formula substitution *)

(** substitutes [term] [u] for variable [x] in [formula] [A] *)
(* capture is not avoided *)
Fixpoint subs T x u (A : formula T) :=
match A with
| fvar X l => fvar X (Vector.map (tsubs x u) l)
| fnul ncon => fnul ncon
| funa ucon B => funa ucon (subs x u B)
| fbin bcon B C => fbin bcon (subs x u B) (subs x u C)
| fqtf qcon y B => fqtf qcon y (if eq_dt_dec y x then B else subs x u B)
end.
Notation "A [ u // x ]" := (subs x u A) (at level 8, format "A [ u // x ]").

Lemma fsize_subs T : forall u x (A : formula T), fsize A[u//x] = fsize A.
Proof. formula_induction A. Qed.
Hint Rewrite fsize_subs : term_db.

(** * Additional results with variable eigen type *)

Lemma subs_esubs T1 T2 (r : T1 -> term T2): forall x u A, (forall n, closed (r n)) ->
  A[u//x]⟦r⟧ = A⟦r⟧[tesubs r u//x].
Proof. formula_induction A; simpl in H; rcauto. Qed.
Hint Rewrite subs_esubs using intuition; fail : term_db.

(* We restrict to [formula nat] *)
(** * Eigen variables *)

Notation "A ↑" := (A⟦⇑⟧) (at level 8, format "A ↑").
Notation "v ⇓" := (fesubs v) (at level 18, format "v ⇓").

Lemma esubs_fup v A : A↑⟦v⇓⟧ = A.
Proof. rcauto. Qed.
Hint Rewrite esubs_fup : term_db.

Lemma felift_esubs u r A : A↑⟦⇑[u]r⟧ = A⟦r⟧↑.
Proof. rcauto. Qed.
Hint Rewrite felift_esubs : term_db.

End Formulas.

(* Some sets of connectives *)
Inductive Nocon := .
Inductive Icon := imp_con.
Inductive Qcon := frl_con | exs_con.

Notation imp := (fbin imp_con).
Notation frl := (fqtf frl_con).
Notation exs := (fqtf exs_con).

Ltac formula_induction A :=
  (try intros until A) ;
  let XX := fresh "X" in
  let xx := fresh "x" in
  let ncon := fresh "ncon" in
  let ucon := fresh "ucon" in
  let bcon := fresh "bcon" in
  let qcon := fresh "qcon" in
  let A1 := fresh A in
  let A2 := fresh A in
  let ll := fresh "l" in
  let lll := fresh "l" in
  let tt := fresh "t" in
  let kk := fresh "k" in
  let IHll := fresh "IHl" in
  induction A as [ XX ll | ncon | ucon A ? | bcon A1 ? A2 ? | qcon xx A ]; simpl; intros;
  [ rewrite ? flat_map_concat_map;
    try (apply (f_equal (fvar _)));
    try (induction ll as [ | tt kk lll IHll ]; simpl; intuition;
         rewrite IHll; f_equal; intuition)
  | try ((try f_equal); intuition; fail)
  | try (apply (f_equal (funa _))); intuition
  | try (apply (f_equal2 (fbin _))); intuition
  | (try apply (f_equal (fqtf _ _))); repeat case_analysis; try (intuition; fail);
     try (now rcauto) ];
  try (now rcauto).


(**
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.
*)

(** * Error of the rounded-to-nearest addition is representable. *)

From Coq Require Import ZArith Reals Psatz.

Require Import Core Operations Relative.

Section Fprop_plus_error.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.

Section round_repr_same_exp.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Lemma round_repr_same_exp :
  forall m e,
  exists m',
  round beta fexp rnd (F2R (Float beta m e)) = F2R (Float beta m' e).
Proof with auto with typeclass_instances.
intros m e.
set (e' := cexp beta fexp (F2R (Float beta m e))).
unfold round, scaled_mantissa. fold e'.
destruct (Zle_or_lt e' e) as [He|He].
exists m.
unfold F2R at 2. simpl.
rewrite Rmult_assoc, <- bpow_plus.
rewrite <- IZR_Zpower by lia.
rewrite <- mult_IZR, Zrnd_IZR...
unfold F2R. simpl.
rewrite mult_IZR.
rewrite Rmult_assoc.
rewrite IZR_Zpower by lia.
rewrite <- bpow_plus.
apply (f_equal (fun v => IZR m * bpow v)%R).
ring.
exists ((rnd (IZR m * bpow (e - e'))) * Zpower beta (e' - e))%Z.
unfold F2R. simpl.
rewrite mult_IZR.
rewrite IZR_Zpower by lia.
rewrite 2!Rmult_assoc.
rewrite <- 2!bpow_plus.
apply (f_equal (fun v => _ * bpow v)%R).
ring.
Qed.

End round_repr_same_exp.

Context { monotone_exp : Monotone_exp fexp }.
Notation format := (generic_format beta fexp).

Variable choice : Z -> bool.

Lemma plus_error_aux :
  forall x y,
  (cexp beta fexp x <= cexp beta fexp y)%Z ->
  format x -> format y ->
  format (round beta fexp (Znearest choice) (x + y) - (x + y))%R.
Proof.
intros x y.
set (ex := cexp beta fexp x).
set (ey := cexp beta fexp y).
intros He Hx Hy.
destruct (Req_dec (round beta fexp (Znearest choice) (x + y) - (x + y)) R0) as [H0|H0].
rewrite H0.
apply generic_format_0.
set (mx := Ztrunc (scaled_mantissa beta fexp x)).
set (my := Ztrunc (scaled_mantissa beta fexp y)).
(* *)
assert (Hxy: (x + y)%R = F2R (Float beta (mx + my * beta ^ (ey - ex)) ex)).
rewrite Hx, Hy.
fold mx my ex ey.
rewrite <- F2R_plus.
unfold Fplus. simpl.
now rewrite Zle_imp_le_bool with (1 := He).
(* *)
rewrite Hxy.
destruct (round_repr_same_exp (Znearest choice) (mx + my * beta ^ (ey - ex)) ex) as (mxy, Hxy').
rewrite Hxy'.
assert (H: (F2R (Float beta mxy ex) - F2R (Float beta (mx + my * beta ^ (ey - ex)) ex))%R =
  F2R (Float beta (mxy - (mx + my * beta ^ (ey - ex))) ex)).
now rewrite <- F2R_minus, Fminus_same_exp.
rewrite H.
apply generic_format_F2R.
intros _.
apply monotone_exp.
rewrite <- H, <- Hxy', <- Hxy.
apply mag_le_abs.
exact H0.
pattern x at 3 ; replace x with (-(y - (x + y)))%R by ring.
rewrite Rabs_Ropp.
now apply (round_N_pt beta _ choice (x + y)).
Qed.

(** Error of the addition *)
Theorem plus_error :
  forall x y,
  format x -> format y ->
  format (round beta fexp (Znearest choice) (x + y) - (x + y))%R.
Proof.
intros x y Hx Hy.
destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)).
now apply plus_error_aux.
rewrite Rplus_comm.
apply plus_error_aux ; try easy.
now apply Zlt_le_weak.
Qed.

End Fprop_plus_error.

Section Fprop_plus_zero.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { exp_not_FTZ : Exp_not_FTZ fexp }.
Notation format := (generic_format beta fexp).

Section round_plus_eq_zero_aux.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Lemma round_plus_neq_0_aux :
  forall x y,
  (cexp beta fexp x <= cexp beta fexp y)%Z ->
  format x -> format y ->
  (0 < x + y)%R ->
  round beta fexp rnd (x + y) <> 0%R.
Proof with auto with typeclass_instances.
intros x y He Hx Hy Hxy.
destruct (mag beta (x + y)) as (exy, Hexy).
simpl.
specialize (Hexy (Rgt_not_eq _ _ Hxy)).
destruct (Zle_or_lt exy (fexp exy)) as [He'|He'].
(* . *)
assert (H: (x + y)%R = F2R (Float beta (Ztrunc (x * bpow (- fexp exy)) +
  Ztrunc (y * bpow (- fexp exy))) (fexp exy))).
rewrite (subnormal_exponent beta fexp exy x He' Hx) at 1.
rewrite (subnormal_exponent beta fexp exy y He' Hy) at 1.
now rewrite <- F2R_plus, Fplus_same_exp.
rewrite H.
rewrite round_generic...
rewrite <- H.
now apply Rgt_not_eq.
apply generic_format_F2R.
intros _.
rewrite <- H.
unfold cexp.
rewrite mag_unique with (1 := Hexy).
apply Z.le_refl.
(* . *)
intros H.
elim Rle_not_lt with (1 := round_le beta _ rnd _ _ (proj1 Hexy)).
rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hxy)).
rewrite H.
rewrite round_generic...
apply bpow_gt_0.
apply generic_format_bpow.
apply Zlt_succ_le.
now rewrite (Zsucc_pred exy) in He'.
Qed.

End round_plus_eq_zero_aux.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

(** rnd(x+y)=0 -> x+y = 0 provided this is not a FTZ format *)
Theorem round_plus_neq_0 :
  forall x y,
  format x -> format y ->
  (x + y <> 0)%R ->
  round beta fexp rnd (x + y) <> 0%R.
Proof with auto with typeclass_instances.
intros x y Hx Hy Hxy.
destruct (Rle_or_lt 0 (x + y)) as [H1|H1].
(* . *)
destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)) as [H2|H2].
apply round_plus_neq_0_aux...
lra.
rewrite Rplus_comm.
apply round_plus_neq_0_aux ; try easy.
now apply Zlt_le_weak.
lra.
(* . *)
rewrite <- (Ropp_involutive (x + y)), Ropp_plus_distr.
rewrite round_opp.
apply Ropp_neq_0_compat.
destruct (Zle_or_lt (cexp beta fexp (-x)) (cexp beta fexp (-y))) as [H2|H2].
apply round_plus_neq_0_aux; try apply generic_format_opp...
lra.
rewrite Rplus_comm.
apply round_plus_neq_0_aux; try apply generic_format_opp...
now apply Zlt_le_weak.
lra.
Qed.

Theorem round_plus_eq_0 :
  forall x y,
  format x -> format y ->
  round beta fexp rnd (x + y) = 0%R ->
  (x + y = 0)%R.
Proof with auto with typeclass_instances.
intros x y Fx Fy H.
destruct (Req_dec (x + y) 0) as [H'|H'].
exact H'.
contradict H.
now apply round_plus_neq_0.
Qed.

End Fprop_plus_zero.

Section Fprop_plus_FLT.
Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.

Theorem FLT_format_plus_small: forall x y,
  generic_format beta (FLT_exp emin prec) x ->
  generic_format beta (FLT_exp emin prec) y ->
   (Rabs (x+y) <= bpow (prec+emin))%R ->
    generic_format beta (FLT_exp emin prec) (x+y).
Proof with auto with typeclass_instances.
intros x y Fx Fy H.
apply generic_format_FLT_FIX...
rewrite Zplus_comm; assumption.
apply generic_format_FIX_FLT, FIX_format_generic in Fx.
apply generic_format_FIX_FLT, FIX_format_generic in Fy.
destruct Fx as [nx H1x H2x].
destruct Fy as [ny H1y H2y].
apply generic_format_FIX.
exists (Float beta (Fnum nx+Fnum ny)%Z emin).
rewrite H1x,H1y; unfold F2R; simpl.
rewrite H2x, H2y.
rewrite plus_IZR; ring.
easy.
Qed.

Variable choice : Z -> bool.

Lemma FLT_plus_error_N_ex : forall x y,
  generic_format beta (FLT_exp emin prec) x ->
  generic_format beta (FLT_exp emin prec) y ->
  exists eps,
  (Rabs eps <= u_ro beta prec / (1 + u_ro beta prec))%R /\
  round beta (FLT_exp emin prec) (Znearest choice) (x + y)
  = ((x + y) * (1 + eps))%R.
Proof.
intros x y Fx Fy.
assert (Pb := u_rod1pu_ro_pos beta prec).
destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs (x + y))) as [M|M].
{ destruct (relative_error_N_FLX'_ex beta prec prec_gt_0_ choice (x + y))
    as (d, (Bd, Hd)).
  now exists d; split; [exact Bd|]; rewrite <- Hd; apply round_FLT_FLX. }
exists 0%R; rewrite Rabs_R0; split; [exact Pb|]; rewrite Rplus_0_r, Rmult_1_r.
apply round_generic; [apply valid_rnd_N|].
apply FLT_format_plus_small; [exact Fx|exact Fy|].
apply Rlt_le, (Rlt_le_trans _ _ _ M), bpow_le; lia.
Qed.

Lemma FLT_plus_error_N_round_ex : forall x y,
  generic_format beta (FLT_exp emin prec) x ->
  generic_format beta (FLT_exp emin prec) y ->
  exists eps,
  (Rabs eps <= u_ro beta prec)%R /\
  (x + y
   = round beta (FLT_exp emin prec) (Znearest choice) (x + y) * (1 + eps))%R.
Proof.
intros x y Fx Fy.
now apply relative_error_N_round_ex_derive, FLT_plus_error_N_ex.
Qed.

End Fprop_plus_FLT.

Section Fprop_plus_mult_ulp.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { monotone_exp : Monotone_exp fexp }.
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

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

Lemma ex_shift :
  forall x e, format x -> (e <= cexp x)%Z ->
  exists m, (x = IZR m * bpow e)%R.
Proof with auto with typeclass_instances.
intros x e Fx He.
exists (Ztrunc (scaled_mantissa beta fexp x)*Zpower beta (cexp x -e))%Z.
rewrite Fx at 1; unfold F2R; simpl.
rewrite mult_IZR, Rmult_assoc.
f_equal.
rewrite IZR_Zpower by lia.
rewrite <- bpow_plus; f_equal; ring.
Qed.

Lemma mag_minus1 :
  forall z, z <> 0%R ->
  (mag beta z - 1)%Z = mag beta (z / IZR beta).
Proof.
intros z Hz.
unfold Zminus.
rewrite <- mag_mult_bpow by easy.
now rewrite bpow_opp, bpow_1.
Qed.

Theorem round_plus_F2R :
  forall x y, format x -> format y -> (x <> 0)%R ->
  exists m,
  round beta fexp rnd (x+y) = F2R (Float beta m (cexp (x / IZR beta))).
Proof with auto with typeclass_instances.
intros x y Fx Fy Zx.
case (Zle_or_lt (mag beta (x/IZR beta)) (mag beta y)); intros H1.
pose (e:=cexp (x / IZR beta)).
destruct (ex_shift x e) as (nx, Hnx); try exact Fx.
apply monotone_exp.
rewrite <- (mag_minus1 x Zx); lia.
destruct (ex_shift y e) as (ny, Hny); try assumption.
apply monotone_exp...
destruct (round_repr_same_exp beta fexp rnd (nx+ny) e) as (n,Hn).
exists n.
fold e.
rewrite <- Hn; f_equal.
rewrite Hnx, Hny; unfold F2R; simpl; rewrite plus_IZR; ring.
unfold F2R; simpl.
(* *)
destruct (ex_shift (round beta fexp rnd (x + y)) (cexp (x/IZR beta))) as (n,Hn).
apply generic_format_round...
apply Z.le_trans with (cexp (x+y)).
apply monotone_exp.
rewrite <- mag_minus1 by easy.
rewrite <- (mag_abs beta (x+y)).
(* . *)
assert (U: (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R).
assert (V: forall x y, (Rabs y <= Rabs x)%R ->
   (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R).
clear; intros x y.
case (Rle_or_lt 0 y); intros Hy.
case Hy; intros Hy'.
case (Rle_or_lt 0 x); intros Hx.
intros _; rewrite (Rabs_pos_eq y) by easy.
rewrite (Rabs_pos_eq x) by easy.
left; apply Rabs_pos_eq.
now apply Rplus_le_le_0_compat.
rewrite (Rabs_pos_eq y) by easy.
rewrite (Rabs_left x) by easy.
intros H; right; split.
now apply Rgt_not_eq.
rewrite Rabs_left1.
ring.
apply Rplus_le_reg_l with (-x)%R; ring_simplify; assumption.
intros _; left.
now rewrite <- Hy', Rabs_R0, 2!Rplus_0_r.
case (Rle_or_lt 0 x); intros Hx.
rewrite (Rabs_left y) by easy.
rewrite (Rabs_pos_eq x) by easy.
intros H; right; split.
now apply Rlt_not_eq.
rewrite Rabs_pos_eq.
ring.
apply Rplus_le_reg_l with (-y)%R; ring_simplify; assumption.
intros _; left.
rewrite (Rabs_left y) by easy.
rewrite (Rabs_left x) by easy.
rewrite Rabs_left1.
ring.
lra.
apply V; left.
apply lt_mag with beta.
now apply Rabs_pos_lt.
rewrite <- mag_minus1 in H1; try assumption.
rewrite 2!mag_abs; lia.
(* . *)
destruct U as [U|U].
rewrite U; apply Z.le_trans with (mag beta x).
lia.
rewrite <- mag_abs.
apply mag_le.
now apply Rabs_pos_lt.
apply Rplus_le_reg_l with (-Rabs x)%R; ring_simplify.
apply Rabs_pos.
destruct U as (U',U); rewrite U.
rewrite <- mag_abs.
apply mag_minus_lb.
now apply Rabs_pos_lt.
now apply Rabs_pos_lt.
rewrite 2!mag_abs.
assert (mag beta y < mag beta x - 1)%Z.
now rewrite (mag_minus1 x Zx).
lia.
apply cexp_round_ge...
apply round_plus_neq_0...
contradict H1; apply Zle_not_lt.
rewrite <- (mag_minus1 x Zx).
replace y with (-x)%R.
rewrite mag_opp; lia.
lra.
now exists n.
Qed.

Context {exp_not_FTZ : Exp_not_FTZ fexp}.

Theorem round_plus_ge_ulp :
  forall x y, format x -> format y ->
  round beta fexp rnd (x+y) <> 0%R ->
  (ulp beta fexp (x/IZR beta) <= Rabs (round beta fexp rnd (x+y)))%R.
Proof with auto with typeclass_instances.
intros x y Fx Fy KK.
case (Req_dec x 0); intros Zx.
(* *)
rewrite Zx, Rplus_0_l.
rewrite round_generic...
unfold Rdiv; rewrite Rmult_0_l.
rewrite Fy.
unfold F2R; simpl; rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow _)) by apply bpow_ge_0.
case (Z.eq_dec (Ztrunc (scaled_mantissa beta fexp y)) 0); intros Hm.
contradict KK.
rewrite Zx, Fy, Hm; unfold F2R; simpl.
rewrite Rplus_0_l, Rmult_0_l.
apply round_0...
apply Rle_trans with (1*bpow (cexp y))%R.
rewrite Rmult_1_l.
rewrite <- ulp_neq_0.
apply ulp_ge_ulp_0...
intros K; apply Hm.
rewrite K, scaled_mantissa_0.
apply Ztrunc_IZR.
apply Rmult_le_compat_r.
apply bpow_ge_0.
rewrite <- abs_IZR.
apply IZR_le.
apply (Zlt_le_succ 0).
now apply Z.abs_pos.
(* *)
destruct (round_plus_F2R x y Fx Fy Zx) as (m,Hm).
case (Z.eq_dec m 0); intros Zm.
contradict KK.
rewrite Hm, Zm.
apply F2R_0.
rewrite Hm, <- F2R_Zabs.
rewrite ulp_neq_0.
rewrite <- (Rmult_1_l (bpow _)).
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply IZR_le.
apply (Zlt_le_succ 0).
now apply Z.abs_pos.
apply Rmult_integral_contrapositive_currified with (1 := Zx).
apply Rinv_neq_0_compat.
apply Rgt_not_eq, radix_pos.
Qed.

End Fprop_plus_mult_ulp.

Section Fprop_plus_ge_ulp.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.

Theorem round_FLT_plus_ge :
  forall x y e,
  generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y ->
  (bpow (e + prec) <= Rabs x)%R ->
  round beta (FLT_exp emin prec) rnd (x + y) <> 0%R ->
  (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x + y)))%R.
Proof with auto with typeclass_instances.
intros x y e Fx Fy He KK.
assert (Zx: x <> 0%R).
  contradict He.
  apply Rlt_not_le; rewrite He, Rabs_R0.
  apply bpow_gt_0.
apply Rle_trans with (ulp beta (FLT_exp emin prec) (x/IZR beta)).
2: apply round_plus_ge_ulp...
rewrite ulp_neq_0.
unfold cexp.
rewrite <- mag_minus1; try assumption.
unfold FLT_exp; apply bpow_le.
apply Z.le_trans with (2:=Z.le_max_l _ _).
destruct (mag beta x) as (n,Hn); simpl.
cut (e + prec < n)%Z. lia.
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=He).
now apply Hn.
apply Rmult_integral_contrapositive_currified; try assumption.
apply Rinv_neq_0_compat.
apply Rgt_not_eq.
apply radix_pos.
Qed.

Lemma round_FLT_plus_ge' :
  forall x y e,
  generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y ->
  (x <> 0%R -> (bpow (e+prec) <= Rabs x)%R) ->
  (x = 0%R -> y <> 0%R -> (bpow e <= Rabs y)%R) ->
  round beta (FLT_exp emin prec) rnd (x+y) <> 0%R ->
  (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x+y)))%R.
Proof with auto with typeclass_instances.
intros x y e Fx Fy H1 H2 H3.
case (Req_dec x 0); intros H4.
case (Req_dec y 0); intros H5.
contradict H3.
rewrite H4, H5, Rplus_0_l; apply round_0...
rewrite H4, Rplus_0_l.
rewrite round_generic...
apply round_FLT_plus_ge; try easy.
now apply H1.
Qed.

Theorem round_FLX_plus_ge :
  forall x y e,
  generic_format beta (FLX_exp prec) x -> generic_format beta (FLX_exp prec) y ->
  (bpow (e+prec) <= Rabs x)%R ->
  (round beta (FLX_exp prec) rnd (x+y) <> 0)%R ->
  (bpow e <= Rabs (round beta (FLX_exp prec) rnd (x+y)))%R.
Proof with auto with typeclass_instances.
intros x y e Fx Fy He KK.
assert (Zx: x <> 0%R).
  contradict He.
  apply Rlt_not_le; rewrite He, Rabs_R0.
  apply bpow_gt_0.
apply Rle_trans with (ulp beta (FLX_exp prec) (x/IZR beta)).
2: apply round_plus_ge_ulp...
rewrite ulp_neq_0.
unfold cexp.
rewrite <- mag_minus1 by easy.
unfold FLX_exp; apply bpow_le.
destruct (mag beta x) as (n,Hn); simpl.
cut (e + prec < n)%Z. lia.
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=He).
now apply Hn.
apply Rmult_integral_contrapositive_currified; try assumption.
apply Rinv_neq_0_compat.
apply Rgt_not_eq.
apply radix_pos.
Qed.

End Fprop_plus_ge_ulp.

Section Fprop_plus_le_ops.

Variable beta : radix.
Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Variable choice : Z -> bool.

Lemma plus_error_le_l :
  forall x y,
  generic_format beta fexp x -> generic_format beta fexp y ->
  (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs x)%R.
Proof.
intros x y Fx Fy.
apply (Rle_trans _ (Rabs (y - (x + y)))); [now apply round_N_pt|].
rewrite Rabs_minus_sym; right; f_equal; ring.
Qed.

Lemma plus_error_le_r :
  forall x y,
  generic_format beta fexp x -> generic_format beta fexp y ->
  (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs y)%R.
Proof. now intros x y Fx Fy; rewrite Rplus_comm; apply plus_error_le_l. Qed.

End Fprop_plus_le_ops.


From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import CoreExpr.CESyntax.
From Coq Require Import List.

(** * Free variables *)

(**

The predicate [Is_free x t : Prop] states that the variable [x] is
used in the term [t].
 *)

Module Type CEISFREE
       (Ids         : IDS)
       (Op          : OPERATORS)
       (Import Syn  : CESYNTAX Op).

  (* Warning: induction scheme is not strong enough. *)
  Inductive Is_free_in_exp : ident -> exp -> Prop :=
  | FreeEvar: forall x ty, Is_free_in_exp x (Evar x ty)
  | FreeEwhen1: forall e c cv x,
      Is_free_in_exp x e ->
      Is_free_in_exp x (Ewhen e c cv)
  | FreeEwhen2: forall e c cv,
      Is_free_in_exp c (Ewhen e c cv)
  | FreeEunop : forall c op e ty,
      Is_free_in_exp c e -> Is_free_in_exp c (Eunop op e ty)
  | FreeEbinop : forall c op e1 e2 ty,
      Is_free_in_exp c e1 \/ Is_free_in_exp c e2 -> Is_free_in_exp c (Ebinop op e1 e2 ty).

  Inductive Is_free_in_aexp : ident -> clock -> exp -> Prop :=
  | freeAexp1: forall ck e x,
      Is_free_in_exp x e  ->
      Is_free_in_aexp x ck e
  | freeAexp2: forall ck e x,
      Is_free_in_clock x ck ->
      Is_free_in_aexp x ck e.

  Inductive Is_free_in_aexps : ident -> clock -> list exp -> Prop :=
  | freeAexps1: forall ck les x,
      Exists (Is_free_in_exp x) les ->
      Is_free_in_aexps x ck les
  | freeAexps2: forall ck les x,
      Is_free_in_clock x ck ->
      Is_free_in_aexps x ck les.

  Inductive Is_free_in_cexp : ident -> cexp -> Prop :=
  | FreeEmerge_cond: forall i t f,
      Is_free_in_cexp i (Emerge i t f)
  | FreeEmerge_true: forall i t f x,
      Is_free_in_cexp x t ->
      Is_free_in_cexp x (Emerge i t f)
  | FreeEmerge_false: forall i t f x,
      Is_free_in_cexp x f ->
      Is_free_in_cexp x (Emerge i t f)
  (* | FreeEite: forall x b t f,  *)
  (*     Is_free_in_exp x b \/ Is_free_in_cexp x t \/ Is_free_in_cexp x f -> *)
  (*     Is_free_in_cexp x (Eite b t f) *)
  | FreeEite_cond: forall x b t f,
      Is_free_in_exp x b ->
      Is_free_in_cexp x (Eite b t f)
  | FreeEite_true: forall x b t f,
      Is_free_in_cexp x t ->
      Is_free_in_cexp x (Eite b t f)
  | FreeEite_false: forall x b t f,
      Is_free_in_cexp x f ->
      Is_free_in_cexp x (Eite b t f)
  | FreeEexp: forall e x,
      Is_free_in_exp x e ->
      Is_free_in_cexp x (Eexp e).

  Inductive Is_free_in_caexp : ident -> clock -> cexp -> Prop :=
  | FreeCAexp1: forall ck ce x,
      Is_free_in_cexp x ce ->
      Is_free_in_caexp x ck ce
  | FreeCAexp2: forall ck ce x,
      Is_free_in_clock x ck ->
      Is_free_in_caexp x ck ce.

  Hint Constructors Is_free_in_clock Is_free_in_exp
       Is_free_in_aexp Is_free_in_aexps Is_free_in_cexp
       Is_free_in_caexp.

  (** * Decision procedure *)

  Lemma Is_free_in_clock_disj:
    forall y ck x c, Is_free_in_clock y (Con ck x c)
                     <-> y = x \/ Is_free_in_clock y ck.
  Proof.
    intros y ck x c; split; intro HH.
    inversion_clear HH; [left; reflexivity|right; assumption].
    destruct HH as [HH|HH].
    rewrite HH; constructor.
    now constructor 2.
  Qed.

  Lemma Is_free_in_when_disj:
    forall y e x c, Is_free_in_exp y (Ewhen e x c)
                    <-> y = x \/ Is_free_in_exp y e.
  Proof.
    intros y e x c; split; intro HH.
    inversion_clear HH; auto.
    destruct HH as [HH|HH]; try rewrite HH; auto using Is_free_in_exp.
  Qed.

  Fixpoint free_in_clock_dec (ck : clock) (T: PS.t)
    : { S | forall x, PS.In x S <-> (Is_free_in_clock x ck \/ PS.In x T) }.
    refine (
        match ck with
        | Cbase => exist _ T _
        | Con ck' x c =>
          match free_in_clock_dec ck' T with
          | exist _ S' HF => exist _ (PS.add x S') _
          end
        end).
    - intro x; split; intro HH.
      right; exact HH.
      destruct HH as [HH|HH]; [inversion HH|exact HH].
    - intro y; split; intro HH.
      + rewrite PS.add_spec in HH.
        destruct HH as [HH|HH].
        rewrite HH; left; constructor.
        apply HF in HH.
        destruct HH as [HH|HH]; [left|right]; auto using Is_free_in_clock.
      + rewrite Is_free_in_clock_disj in HH.
        apply or_assoc in HH.
        destruct HH as [HH|HH].
        rewrite HH; apply PS.add_spec; left; reflexivity.
        apply HF in HH; apply PS.add_spec; right; assumption.
  Defined.

  Fixpoint free_in_clock (ck : clock) (fvs: PS.t) : PS.t :=
    match ck with
    | Cbase => fvs
    | Con ck' x _ => free_in_clock ck' (PS.add x fvs)
    end.

  Fixpoint free_in_exp (e: exp) (fvs: PS.t) : PS.t :=
    match e with
    | Econst _ => fvs
    | Evar x _ => PS.add x fvs
    | Ewhen e x _ => free_in_exp e (PS.add x fvs)
    | Eunop _ e _ => free_in_exp e fvs
    | Ebinop _ e1 e2 _ => free_in_exp e2 (free_in_exp e1 fvs)
    end.

  Definition free_in_aexp (ck: clock)(le : exp) (fvs : PS.t) : PS.t :=
    free_in_exp le (free_in_clock ck fvs).

  Definition free_in_aexps (ck: clock) (es : list exp) (fvs : PS.t) : PS.t :=
    fold_left (fun fvs e => free_in_exp e fvs) es (free_in_clock ck fvs).

  Fixpoint free_in_cexp (ce: cexp) (fvs: PS.t) : PS.t :=
    match ce with
    | Emerge i t f => free_in_cexp f (free_in_cexp t (PS.add i fvs))
    | Eite b t f => free_in_cexp f (free_in_cexp t (free_in_exp b fvs))
    | Eexp e => free_in_exp e fvs
    end.

  Definition free_in_caexp (ck: clock)(ce: cexp) (fvs: PS.t) : PS.t :=
    free_in_cexp ce (free_in_clock ck fvs).

  (** * Specification lemmas *)

  Lemma free_in_clock_spec:
    forall x ck m, PS.In x (free_in_clock ck m)
                   <-> Is_free_in_clock x ck \/ PS.In x m.
  Proof.
    induction ck.
    - split; intuition;
        (match goal with H:Is_free_in_clock _ Cbase |- _ => inversion H end).
    - split; intro H0.
      + apply IHck in H0; destruct H0 as [H0|H0]; try apply PS.add_spec in H0;
          intuition; subst; intuition.
      + apply IHck; destruct H0 as [H0|H0]; inversion H0;
          solve [right; apply PS.add_spec; intuition | intuition].
  Qed.

  Corollary free_in_clock_spec':
    forall x ck, PS.In x (free_in_clock ck PS.empty)
                 <-> Is_free_in_clock x ck.
  Proof.
    intros.
    rewrite (free_in_clock_spec x ck PS.empty).
    split; [intros [HH|HH]|intro HH]; intuition.
  Qed.

  Lemma free_in_exp_spec:
    forall x e m, PS.In x (free_in_exp e m)
                  <-> Is_free_in_exp x e \/ PS.In x m.
  Proof.
    intro x; induction e using exp_ind;
      try now intro m; (split;
                        [
                          intro H0; try apply IHe in H0
                        | intro H0; try apply IHe
                       ]);
      try destruct H0 as [H0|H0];
      try apply free_in_clock_spec in H0;
      try inversion H0; subst;
        try apply PS.add_spec;
        solve [
            intuition
          | right; apply free_in_clock_spec; intuition
          | apply PS.add_spec in H1; destruct H1; subst; intuition
          | right; apply PS.add_spec; intuition ].
    intro m.
    split; intro HH.
    - simpl in HH.
      apply IHe2 in HH.
      destruct HH as [HH|HH]; [now intuition|].
      apply IHe1 in HH. intuition.
    - simpl.
      destruct HH as [HH|HH].
      + inversion_clear HH as [| | | |? ? ? ? ? Hf].
        apply IHe2.
        destruct Hf as [HH|HH]; intuition.
        right. apply IHe1; intuition.
      + apply IHe2; right; apply IHe1; intuition.
  Qed.

  Lemma free_in_exp_spec':
    forall x e, PS.In x (free_in_exp e PS.empty)
                <-> Is_free_in_exp x e.
  Proof.
    setoid_rewrite (free_in_exp_spec _ _ PS.empty); intuition.
  Qed.

  Lemma free_in_aexp_spec:
    forall x ck e m, PS.In x (free_in_aexp ck e m)
                     <-> Is_free_in_aexp x ck e \/ PS.In x m.
  Proof.
    destruct e; split; intros;
      repeat
        (match goal with
         | H:_ \/ _ |- _ => destruct H as [H|H]
         | H:PS.In _ (free_in_aexp _ _ _) |- _ => apply free_in_exp_spec in H
         | H:PS.In _ (free_in_clock _ _) |- _ => apply free_in_clock_spec in H
         | |- PS.In _ (free_in_aexp _ _ _) => apply free_in_exp_spec
         | H:Is_free_in_aexp _ _ _ |- _ => inversion_clear H
         | |- context[PS.In _ (free_in_clock _ _)] => rewrite free_in_clock_spec
         end);
      intuition.
  Qed.

  Lemma free_in_aexp_spec':
    forall x ck e, PS.In x (free_in_aexp ck e PS.empty)
                   <-> Is_free_in_aexp x ck e.
  Proof.
    setoid_rewrite (free_in_aexp_spec _ _ _ PS.empty); intuition.
  Qed.

  Lemma free_in_fold_left_exp_spec : forall x l m,
      PS.In x (fold_left (fun fvs e => free_in_exp e fvs) l m) <->
      Exists (Is_free_in_exp x) l \/ PS.In x m.
  Proof.
    Local Hint Constructors Exists.
    intros x l. induction l; intro m; simpl.
    - intuition.
      match goal with H:Exists _ nil |- _ => inversion H end.
    - rewrite IHl. rewrite free_in_exp_spec.
      split; intros [H | H]; auto.
      + destruct H as [H | H]; auto.
      + inversion_clear H; auto.
  Qed.

  Lemma free_in_aexps_spec:
    forall x ck e m, PS.In x (free_in_aexps ck e m)
                     <-> Is_free_in_aexps x ck e \/ PS.In x m.
  Proof.
    intros x c l m. unfold free_in_aexps.
    rewrite free_in_fold_left_exp_spec.
    rewrite free_in_clock_spec.
    split; intros [H | H]; auto; inversion H; auto.
  Qed.

  Lemma free_in_aexps_spec':
    forall x ck l, PS.In x (free_in_aexps ck l PS.empty)
                   <-> Is_free_in_aexps x ck l.
  Proof.
    setoid_rewrite (free_in_aexps_spec _ _ _ PS.empty); intuition.
  Qed.

  Ltac destruct_Is_free :=
    repeat match goal with
           | H: _ \/ _ |- _ =>
             destruct H

           | H: Is_free_in_cexp _ (Emerge _ _ _) |- _ =>
             inversion H; subst; clear H

           | H: Is_free_in_cexp _ (Eexp _) |- _ =>
             inversion H; subst; clear H

           | IHe: context[PS.In _ (free_in_cexp ?e _)],
                  H:PS.In _ (free_in_cexp ?e _) |- _ =>
             apply IHe in H

           | H: PS.In _ (free_in_exp _ _) |- _ =>
             apply free_in_exp_spec in H

           | H: PS.In _ (PS.add _ _) |- _ =>
             apply PS.add_spec in H
           end.

  Lemma free_in_cexp_spec:
    forall x e m, PS.In x (free_in_cexp e m)
                  <-> Is_free_in_cexp x e \/ PS.In x m.
  Proof.
    intro x;
      induction e;
      intro m; simpl; split; intro H0;
        destruct_Is_free;
        subst; auto;
          try rewrite IHe2, IHe1;
          try rewrite free_in_exp_spec;
          match goal with
          | H:Is_free_in_cexp _ _ |- _ => inversion_clear H
          | |- _ => idtac
          end;
          intuition.
  Qed.

  Lemma free_in_cexp_spec':
    forall x e, PS.In x (free_in_cexp e PS.empty)
                <-> Is_free_in_cexp x e.
  Proof.
    setoid_rewrite (free_in_cexp_spec _ _ PS.empty); intuition.
  Qed.

  Lemma free_in_caexp_spec:
    forall x ck e m, PS.In x (free_in_caexp ck e m)
                     <-> Is_free_in_caexp x ck e \/ PS.In x m.
  Proof.
    destruct e; split; intros;
      repeat progress (match goal with
           | H:_ \/ _ |- _ => destruct H as [H|H]
           | H:PS.In _ _ |- _ => first [ apply free_in_cexp_spec in H
                                       | apply free_in_clock_spec in H ]
           | |- context [free_in_caexp _ _ _] => apply free_in_cexp_spec
           | H:Is_free_in_caexp _ _ _ |- _ => inversion_clear H
           | _ => solve [right; apply free_in_clock_spec; intuition
                        | intuition]
                       end).
  Qed.

  Lemma free_in_caexp_spec':
    forall x ck e, PS.In x (free_in_caexp ck e PS.empty)
                   <-> Is_free_in_caexp x ck e.
  Proof.
    setoid_rewrite (free_in_caexp_spec _ _ _ PS.empty); intuition.
  Qed.

End CEISFREE.

Module CEIsFreeFun
       (Ids  : IDS)
       (Op   : OPERATORS)
       (Syn  : CESYNTAX Op)
       <: CEISFREE Ids Op Syn.
  Include CEISFREE Ids Op Syn.
End CEIsFreeFun.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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 2.1 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 GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Reals.
Require Import Rsequence_def.
Require Import Rsequence_facts.

Require Import Lia Lra.
Open Scope Rseq_scope.
Open Scope nat_scope.
(** printing ~	~ *)
Definition is_extractor (phi : nat -> nat) := forall n, phi n < phi (S n).

Definition extractor := {phi | is_extractor phi}.

Definition extracted {X : Type} (phi : extractor) (Un : nat -> X) n := Un ((proj1_sig phi) n).

(** printing ⋅ #•# *)
Notation "Un ⋅ phi" := (extracted phi Un) (at level 40, left associativity) : Rseq_scope.

Definition subsequence {X : Type} (Un Vn : nat -> X) :=
  {phi | forall n, Un n = (Vn ⋅ phi) n}.

Lemma subsequence_helper {u v : Rseq} (f : nat -> nat) :
  (forall n, f n < f (1 + n))%nat ->
  (forall n, u n = v (f n)) ->
  subsequence u v.
Proof.
  intros Hf.
  hnf. unfold extractor.
  exists (exist is_extractor f Hf).
  eauto.
Qed.

(** Properties on nat -> nat sequences *)

(* Growing sequence *)
Lemma nat_seq_growing_trans : forall an : nat -> nat, (forall x, an x <= an (S x)) ->
  forall y x, x <= y -> an x <= an y.
Proof.
induction y.
 intros x Hx0; rewrite (le_n_O_eq x Hx0).
 apply le_refl.

 intros x Hxy.
 destruct (Compare.le_decide _ _ Hxy) as [Hyx|Hyx].
  apply le_trans with (an y).
   apply IHy.
   apply gt_S_le.
   apply Hyx.

   apply H.

  subst; apply le_refl.
Qed.

(* Strictly growing sequence *)
Lemma nat_seq_strict_growing_trans : forall an, (forall x, an x < an (S x)) ->
  forall y x, x < y -> an x < an y.
Proof.
induction y.
 intros x Hx0. inversion Hx0.

 intros x Hxy.
 destruct (Compare.le_decide _ _ Hxy) as [Hyx|Hyx].
  apply le_trans with (an y).
   apply IHy.
   apply gt_S_le.
   apply Hyx.
   apply lt_le_weak.
   apply H.

  rewrite <- Hyx.
  apply H.
Qed.

(* Inverse of stricty growing is growing *)
Lemma nat_seq_growing_trans_converse : forall an, (forall x, an x < an (S x)) ->
  forall x y, an x <= an y -> x <= y.
Proof.
intros an H x y Hxy.
destruct (le_le_S_dec x y).
 assumption.

 pose proof (nat_seq_strict_growing_trans an H x y).
 intuition lia.
Qed.

(** Properties on extractors *)
Lemma Rsubseq_n_le_extractor_n : forall phi n, is_extractor phi -> n <= phi n.
Proof.
intros phi n Hphi.
induction n.
 apply le_O_n.

 eapply le_trans with (S (phi n)).
 apply (le_n_S _ _ IHn).
 apply Hphi.
Qed.

(** Convergence compatible with subsequence *)
Lemma Rseq_subseq_cv_compat : forall Un Vn l, subsequence Un Vn -> Rseq_cv Vn l -> Rseq_cv Un l.
Proof.
intros Un Vn l Hsub Hcv eps Heps.
destruct (Hcv eps Heps) as [N HN].
exists N; intros n Hn.
destruct Hsub as [phi Hphi].
unfold extracted in *; simpl in Hphi.
rewrite Hphi.
apply HN.
apply le_trans with n.
 apply Hn.
 apply Rsubseq_n_le_extractor_n; destruct phi; auto.
Qed.

(** Divergence compatible with subsequence *)
Lemma Rseq_subseq_cv_pos_infty_compat :
  forall Un Vn, subsequence Un Vn ->
    Rseq_cv_pos_infty Vn -> Rseq_cv_pos_infty Un.
Proof.
intros Un Vn Hsub Hdv M.
destruct (Hdv M) as [N HN].
exists N; intros n Hn.
destruct Hsub as [phi Hphi].
rewrite Hphi.
apply HN.
apply le_trans with n.
 apply Hn.
 apply Rsubseq_n_le_extractor_n; destruct phi; auto.
Qed.

(** An extractor defines a partition of N *)
Lemma Rseq_extractor_partition : forall phi, is_extractor phi ->
  forall n, phi 0 <= n -> exists p, phi p <= n < phi (S p).
Proof.
intros phi ephi.
induction n.
 exists 0.
 split.
  assumption.
  apply (Rsubseq_n_le_extractor_n _ 1 ephi).

 destruct (le_le_S_dec (phi 0) n).
  intros _.
  destruct (IHn l) as [p [Hpn Hnsp]].
  destruct (Compare.le_decide _ _ Hnsp).
   exists p.
   split; [constructor|]; assumption.

   exists (S p).
   rewrite e.
   intuition.

  intro l'; rewrite (le_antisym _ _ l l').
  exists 0.
  split.
   constructor.
   apply ephi.
Qed.

(** Composition of extractors *)

Lemma extractor_comp : forall phi1 phi2,
  is_extractor phi1 -> is_extractor phi2 -> is_extractor (fun n => phi1 (phi2 n)).
Proof.
intros phi1 phi2 H1 H2 n.
apply nat_seq_strict_growing_trans; trivial.
Qed.

(** Common extractors *)
Definition Rseq_iter_S k := plus k.

Lemma extractor_S : is_extractor S.
Proof.
intro n.
constructor.
Qed.

Lemma extractor_Rseq_iter_S : forall k, is_extractor (Rseq_iter_S k).
Proof.
intros k n.
unfold Rseq_iter_S.
apply plus_lt_compat_l; constructor.
Qed.

Lemma is_extractor_mult_2 : is_extractor (mult 2).
Proof.
intros n; lia.
Qed.

Definition extractor_mult_2 := exist _ (mult 2) is_extractor_mult_2.

(** Rseq_zip can be inversed thanks to extractors *)

Lemma Rseq_zip_extract_evens : forall Un Vn,
  Rseq_zip Un Vn ⋅ extractor_mult_2 == Un.
Proof.
intros Un Vn n ; unfold Rseq_zip, extracted, extractor_mult_2 ;
 simpl ; case (n_modulo_2 (n + (n + 0))) ; intros [p Hp].
  f_equal ; lia.
  apply False_ind ; lia.
Qed.

(** Convergence of subsequence implies convergence of the growing sequence *)
Open Scope R_scope.

(* begin hide *)
Lemma R_dist_bounded_in_segment : forall a b c e, a <= b <= c -> R_dist a c < e ->
  R_dist b c < e.
Proof.
intros a b c e [ab bc] ace.
unfold R_dist in *.
assert (forall x y, x <= y -> Rabs (x - y) = y - x).
 intros.
 rewrite Rabs_minus_sym.
 apply Rabs_right.
 lra.

 pose proof (Rle_trans _ _ _ ab bc) as ac.

  repeat rewrite H; rewrite H in ace; intuition;
  apply Rle_lt_trans with (c - a);
   lra.
Qed.
(* end hide *)

Lemma Rseq_subseq_growing_cv_compat :
  forall Un Vn l, subsequence Un Vn -> Rseq_cv Un l -> Rseq_growing Vn -> Rseq_cv Vn l.
Proof.
intros un vn l [phi ephi] uncv vngrow eps epspos.
destruct phi as [phi Hphi]; unfold extracted in *; simpl in *.
assert (spliteps : (eps / 3 > 0)%R) by lra.
destruct (uncv (eps / 3) spliteps) as [Nu Hu].
exists (phi Nu).
intros n nNu.
destruct (Rseq_extractor_partition phi Hphi n) as [N Hpart].
 apply le_trans with (phi Nu).
  apply nat_seq_growing_trans.
   intros x.
   apply lt_le_weak.
   apply Hphi.

   apply le_O_n.

  exact nNu.

 assert (HNuN : (Nu <= N)%nat).
  destruct (le_le_S_dec Nu N) as [goal|Hinv].
   exact goal.

   destruct Hpart as [HNn HnSN].
   pose proof (nat_seq_growing_trans phi (fun x => lt_le_weak _ _ (Hphi _)) Nu (S N) Hinv).
   pose proof (le_trans _ _ _ H nNu).
   pose proof (lt_le_trans _ _ _ HnSN H).
   intuition lia.

 pose proof (Hu N HNuN) as Hun.
 pose proof (Hu (S N) (le_S _ _ HNuN)) as Husn.
 rewrite ephi in Hun.
 rewrite ephi in Husn.
 assert (vn (phi N) <= vn n <= vn (phi (S N)))%R.
  split; apply (Rseq_growing_trans _ vngrow); intuition.
 rewrite R_dist_sym in Husn.
 replace eps with (eps / 3 + eps / 3 + eps / 3) by field.
 eapply Rle_lt_trans.
  apply (R_dist_tri _ _ (vn (phi (S N)))).
  apply Rplus_lt_compat.
   eapply R_dist_bounded_in_segment.
    apply H.
    eapply Rle_lt_trans.
     apply (R_dist_tri _ _ l).
     apply Rplus_lt_compat.
      apply Hun.
      apply Husn.
   rewrite R_dist_sym .
   apply Husn.
Qed.

(** u(2n) → l and u growing implies u → l *)

Corollary Rseq_even_growing_compat : forall un l, Rseq_growing un ->
 Rseq_cv (fun i => un (2*i)%nat) l -> Rseq_cv un l.
Proof.
intros.
apply Rseq_subseq_growing_cv_compat with (fun i : nat => un (2 * i)%nat).
 assert (Hex : is_extractor (mult 2)).
   intros n; lia.
 pose (phi := exist _ (mult 2) Hex).
 exists phi; reflexivity.
 assumption.
 assumption.
Qed.

(** Link with Landau's relations *)
Section Landau.

Variables Un Vn : nat -> R.

(** Subsequence and big-O. *)

(**********)
Lemma Rseq_big_O_subseq_compat :
  forall phi, Un = O (Vn) -> (Un ⋅ phi) = O(Vn ⋅ phi).
Proof.
intros phi Heq.
destruct Heq as [N [HN [N0 HN0]]].
exists N; split.
assumption.
exists N0; intros n Hn.
apply HN0.
apply le_trans with n.
assumption.
apply Rsubseq_n_le_extractor_n; destruct phi; assumption.
Qed.

(** Subsequence and little-O. *)

(**********)
Lemma Rseq_little_O_subseq_compat :
  forall phi, Un = o (Vn) -> (Un ⋅ phi) = o(Vn ⋅ phi).
Proof.
intros [phi Hphi] Heq.
intros eps Heps.
destruct (Heq eps Heps) as [N HN].
exists N.
intros n Hn; unfold Rseq_minus.
apply HN.
apply le_trans with (phi N).
apply Rsubseq_n_le_extractor_n; assumption.
apply nat_seq_growing_trans; auto with *.
Qed.

(** Subsequence and equivalence. *)

(**********)
Lemma Rseq_equiv_subseq_compat :
  forall phi, Un ~ Vn -> (Un ⋅ phi) ~ (Vn ⋅ phi).
Proof.
intros [phi Hphi] Heq.
intros eps Heps.
destruct (Heq eps Heps) as [N HN].
exists N.
intros n Hn; unfold Rseq_minus.
apply HN.
apply le_trans with (phi N).
apply Rsubseq_n_le_extractor_n; assumption.
apply nat_seq_growing_trans;auto with *.
Qed.

End Landau.