(*
FSub (F<:)
T ::= Top | X | T -> T | Forall Z <: T. T^Z
t ::= x | lambda x:T.t | Lambda X<:T.t | t t | t [T]
*)

(* semantic equality big-step / small-step *)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.
Require Import Omega.
Require Import NPeano.

(* ### Syntax ### *)

Definition id := nat.

Inductive ty : Type :=
| TTop : ty
| TFun : ty -> ty -> ty
| TAll : ty -> ty -> ty
| TVarF : id -> ty (* free type variable, in concrete environment *)
| TVarH : id -> ty (* free type variable, in abstract environment  *)
| TVarB : id -> ty (* locally-bound type variable *)
.

Inductive tm : Type :=
| tvar : id -> tm
| tabs : ty -> tm -> tm
| tapp : tm -> tm -> tm
| ttabs : ty -> tm -> tm
| ttapp : tm -> ty -> tm
| tty: ty -> tm
.

Inductive binding {X: Type} :=
| bind_tm : X -> binding
| bind_ty : X -> binding
.

Inductive vl : Type :=
(* a closure for a term abstraction *)
| vabs : venv (*H*) -> ty -> tm -> vl
(* a closure for a type abstraction *)
| vtabs : venv (*H*) -> ty -> tm -> vl
(* a closure over a type *)
| vty : venv (*H*) -> ty -> vl
with venv : Type := (* need to recurse structurally, hence don't use built-in list *)
| vnil: venv
| vcons: vl -> venv -> venv
.

Definition tenv := list (@binding ty). (* Gamma environment: static *)
(*Definition venv := list vl. (* H environment: run-time *) *)
Definition aenv := list (venv*ty). (* J environment: abstract at run-time *)

(* ### Representation of Bindings ### *)

(* An environment is a list of values, indexed by decrementing ids. *)

Fixpoint lengthr (l : venv) : nat :=
  match l with
    | vnil => 0
    | vcons a  l' =>
      S (lengthr l')
  end.

Fixpoint indexr (n : id) (l : venv) : option vl :=
  match l with
    | vnil => None
    | vcons a  l' =>
      if (beq_nat n (lengthr l')) then Some a else indexr n l'
  end.

Inductive closed: nat(*B*) -> nat(*H*) -> nat(*F*) -> ty -> Prop :=
| cl_top: forall i j k,
    closed i j k TTop
| cl_fun: forall i j k T1 T2,
    closed i j k T1 ->
    closed i j k T2 ->
    closed i j k (TFun T1 T2)
| cl_all: forall i j k T1 T2,
    closed i j k T1 ->
    closed (S i) j k T2 ->
    closed i j k (TAll T1 T2)
| cl_sel: forall i j k x,
    k > x ->
    closed i j k (TVarF x)
| cl_selh: forall i j k x,
    j > x ->
    closed i j k (TVarH x)
| cl_selb: forall i j k x,
    i > x ->
    closed i j k (TVarB x)
.

(* open define a locally-nameless encoding wrt to TVarB type variables. *)
(* substitute type u for all occurrences of (TVarB k) *)
Fixpoint open_rec (k: nat) (u: ty) (T: ty) { struct T }: ty :=
  match T with
    | TTop        => TTop
    | TFun T1 T2  => TFun (open_rec k u T1) (open_rec k u T2)
    | TAll T1 T2  => TAll (open_rec k u T1) (open_rec (S k) u T2)
    | TVarF x => TVarF x
    | TVarH i => TVarH i
    | TVarB i => if beq_nat k i then u else TVarB i
  end.

Definition open u T := open_rec 0 u T.

(* Locally-nameless encoding with respect to varH variables. *)
Fixpoint subst (U : ty) (T : ty) {struct T} : ty :=
  match T with
    | TTop         => TTop
    | TFun T1 T2   => TFun (subst U T1) (subst U T2)
    | TAll T1 T2   => TAll (subst U T1) (subst U T2)
    | TVarB i      => TVarB i
    | TVarF i      => TVarF i
    | TVarH i      => if beq_nat i 0 then U else TVarH (i-1)
  end.

Definition liftb (f: ty -> ty) b :=
  match b with
    | bind_tm T => bind_tm (f T)
    | bind_ty T => bind_ty (f T)
  end.

Definition substb (U: ty) := liftb (subst U).

Fixpoint nosubst (T : ty) {struct T} : Prop :=
  match T with
    | TTop         => True
    | TFun T1 T2   => nosubst T1 /\ nosubst T2
    | TAll T1 T2   => nosubst T1 /\ nosubst T2
    | TVarB i      => True
    | TVarF i      => True
    | TVarH i      => i <> 0
  end.

(* ### Evaluation (Big-Step Semantics) ### *)

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v
*)

(* Environment-based evaluator *)

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | tty T        => Some (Some (vty env T))
        | tvar x       => Some (indexr x env)
        | tabs T y     => Some (Some (vabs env T y))
        | ttabs T y    => Some (Some (vtabs env T y))
        | tapp ef ex   =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match teval n env ef with
                | None => None
                | Some None => Some None
                | Some (Some (vtabs _ _ _)) => Some None
                | Some (Some (vty _ _)) => Some None
                | Some (Some (vabs env2 _ ey)) =>
                  teval n (vcons vx env2) ey
              end
          end
        | ttapp ef ex   =>
          match teval n env ef with
            | None => None
            | Some None => Some None
            | Some (Some (vabs _ _ _)) => Some None
            | Some (Some (vty _ _)) => Some None
            | Some (Some (vtabs env2 T ey)) =>
              teval n (vcons (vty env ex) env2) ey
          end
      end
  end.

(* Substitution-based evaluator *)

Fixpoint shift_ty (u:nat) (T : ty) {struct T} : ty :=
  match T with
    | TTop        => TTop
    | TFun T1 T2  => TFun (shift_ty u T1) (shift_ty u T2)
    | TAll T1 T2  => TAll (shift_ty u T1) (shift_ty u T2)
    | TVarF i     => TVarF i
    | TVarH i     => TVarH (i+u)
    | TVarB i     => TVarB i
  end.

Fixpoint shift_tm (u:nat) (T : tm) {struct T} : tm :=
  match T with
    | tvar i      => tvar (i + u)
    | tabs T1 t   => tabs (shift_ty u T1) (shift_tm u t)
    | tapp t1 t2  => tapp (shift_tm u t1) (shift_tm u t2)
    | ttabs T1 t  => ttabs (shift_ty u T1) (shift_tm u t)
    | ttapp t1 T2 => ttapp (shift_tm u t1) (shift_ty u T2)
    | tty T       => tty (shift_ty u T)
  end.

Definition et t := match t with
                     | tty T => T
                     | _ => TTop
                   end.

Fixpoint subst_tm (u:tm) (T : tm) {struct T} : tm :=
  match T with
    | tvar i      => if beq_nat i 0 then u else tvar (i-1)
    | tabs T1 t   => tabs (subst (et u) T1) (subst_tm (shift_tm 1 u) t)
    | tapp t1 t2  => tapp (subst_tm u t1) (subst_tm u t2)
    | ttabs T1 t  => ttabs (subst (et u) T1) (subst_tm (shift_tm 1 u) t)
    | ttapp t1 T2 => ttapp (subst_tm u t1) (subst (et u) T2)
    | tty T       => tty (subst (et u) T)
  end.

Fixpoint subst_ty (u:ty) (T : tm) {struct T} : tm :=
  match T with
    | tvar i      => if beq_nat i 0 then (tty u) else tvar (i-1)
    | tabs T1 t   => tabs (subst u T1) (subst_ty (shift_ty 1 u) t)
    | tapp t1 t2  => tapp (subst_ty u t1) (subst_ty u t2)
    | ttabs T1 t  => ttabs (subst u T1) (subst_ty (shift_ty 1 u) t)
    | ttapp t1 T2 => ttapp (subst_ty u t1) (subst u T2)
    | tty T       => tty (subst u T)
  end.

Fixpoint tevals(n: nat)(t: tm){struct n}: option (option tm) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | tty T        => Some (Some (tty T))
        | tvar x       => Some None
        | tabs T y     => Some (Some (tabs T y))
        | ttabs T y    => Some (Some (ttabs T y))
        | tapp ef ex   =>
          match tevals n ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match tevals n ef with
                | None => None
                | Some None => Some None
                | Some (Some (tty T)) => Some None
                | Some (Some (tvar _)) => Some None
                | Some (Some (tapp _ _)) => Some None
                | Some (Some (ttapp _ _)) => Some None
                | Some (Some (ttabs _ _)) => Some None
                | Some (Some (tabs _ ey)) =>
                  tevals n (subst_tm vx ey)
              end
          end
        | ttapp ef ex   =>
          match tevals n ef with
            | None => None
            | Some None => Some None
            | Some (Some (tty T)) => Some None
            | Some (Some (tvar _)) => Some None
            | Some (Some (tapp _ _)) => Some None
            | Some (Some (ttapp _ _)) => Some None
            | Some (Some (tabs _ _)) => Some None
            | Some (Some (ttabs T ey)) =>
              tevals n (subst_ty ex ey)
          end
      end
  end.

(* ### Evaluation (Small-Step Semantics) ### *)

Inductive value : tm -> Prop :=
| V_Abs : forall T t,
    value (tabs T t)
| V_TAbs : forall T t,
    value (ttabs T t)
| V_Ty : forall T,
    value (tty T)
.

Inductive step : tm -> tm -> Prop :=
| ST_AppAbs : forall v T1 t12,
    value v ->
    step (tapp (tabs T1 t12) v) (subst_tm v t12)
| ST_App1 : forall t1 t1' t2,
    step t1 t1' ->
    step (tapp t1 t2) (tapp t1' t2)
| ST_App2 : forall f t2 t2',
    value f ->
    step t2 t2' ->
    step (tapp f t2) (tapp f t2')
| ST_TAppAbs : forall T1 t12 T2,
    step (ttapp (ttabs T1 t12) T2) (subst_ty T2 t12)
| ST_TApp1 : forall t1 t1' t2,
    step t1 t1' ->
    step (ttapp t1 t2) (ttapp t1' t2)
.

Inductive mstep : nat -> tm -> tm -> Prop :=
| MST_Z : forall t,
    mstep 0 t t
| MST_S: forall n t1 t2 t3,
    step t1 t2 ->
    mstep n t2 t3 ->
    mstep (S n) t1 t3
.

(* automation *)

Hint Constructors venv.
Hint Unfold tenv.

Hint Unfold open.
Hint Unfold indexr.
Hint Unfold length.

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors closed.

Hint Constructors option.
Hint Constructors list.

Hint Resolve ex_intro.

(* ### Euivalence big-step env <-> big-step subst ### *)

Fixpoint subst_ty_all n venv t {struct venv} :=
  match venv with
    | vnil                       => t
    | vcons (vabs venv0 T y) tl  => subst TTop (subst_ty_all (S n) tl t) (* use TTop as placeholder *)
    | vcons (vtabs venv0 T y) tl => subst TTop (subst_ty_all (S n) tl t) (* use TTop as placeholder *)
    | vcons (vty venv0 T) tl     =>
      subst (shift_ty n (subst_ty_all 0 venv0 T)) (subst_ty_all (S n) tl t)
  end.

Fixpoint subst_tm_all n venv t {struct venv} :=
  match venv with
    | vnil => t
    | vcons (vabs venv0 T y) tl =>
      subst_tm (shift_tm n (tabs (subst_ty_all 0 venv0 T) (subst_tm_all 1 venv0 y))) (subst_tm_all (S n) tl t)
    | vcons (vtabs venv0 T y) tl =>
      subst_tm (shift_tm n (ttabs (subst_ty_all 0 venv0 T) (subst_tm_all 1 venv0 y))) (subst_tm_all (S n) tl t)
    | vcons (vty venv0 T) tl =>
      subst_ty (shift_ty n (subst_ty_all 0 venv0 T)) (subst_tm_all (S n) tl t)
  end.

Definition subst_tm_res t :=
  match t with
    | None => None
    | Some None => Some None
    | Some (Some (vabs venv0 T y)) => Some (Some ((tabs (subst_ty_all 0 venv0 T) (subst_tm_all 1 venv0 y))))
    | Some (Some (vtabs venv0 T y)) => Some (Some ((ttabs (subst_ty_all 0 venv0 T) (subst_tm_all 1 venv0 y))))
    | Some (Some (vty venv0 T)) => Some (Some (tty (subst_ty_all 0 venv0 T)))
  end.

Lemma idx_miss: forall env i l,
  i >= lengthr env ->
  indexr i env = None /\ subst_tm_all l env (tvar i) = (tvar (i-(lengthr env))).
Proof.
  intros env. induction env.
  - intros. simpl in H. simpl.
    assert (i-0=i). omega. rewrite H0. eauto.
  - intros. simpl in H. simpl.
    destruct (IHenv i (S l)) as [A B]. omega.
    rewrite B. simpl.
    assert (beq_nat (i - lengthr env) 0 = false). eapply beq_nat_false_iff. omega.
    assert (beq_nat i (lengthr env) = false). eapply beq_nat_false_iff. omega.
    rewrite H0. rewrite H1.
    assert (i - lengthr env - 1 = i - S (lengthr env)). omega.
    rewrite H2.

    destruct v; try destruct v; eauto.
Qed.

Lemma idx_miss1: forall env i l,
  i >= lengthr env ->
  subst_tm_all l env (tvar i) = (tvar (i-(lengthr env))).
Proof.
  intros env. eapply idx_miss; eauto.
Qed.

Lemma shiftz_id_ty: forall t,
  shift_ty 0 t = t.
Proof.
  intros. induction t; simpl; eauto; try rewrite IHt; try rewrite IHt1; try rewrite IHt2; eauto.
Qed.

Lemma shiftz_id: forall t,
  shift_tm 0 t = t.
Proof.
  intros. induction t; simpl; eauto; try rewrite IHt; try rewrite IHt1; try rewrite IHt2; eauto; try rewrite shiftz_id_ty; eauto.
Qed.

Lemma shift_add_ty: forall t l1 l2,
  shift_ty l1 (shift_ty l2 t) = shift_ty (l2+l1) t.
Proof.
  intros. induction t; simpl; eauto; try rewrite IHt; try rewrite IHt1; try rewrite IHt2; eauto.
  rewrite plus_assoc. eauto.
Qed.

Lemma shift_add: forall t l1 l2,
  shift_tm l1 (shift_tm l2 t) = shift_tm (l2+l1) t.
Proof.
  intros. induction t; simpl; eauto; try rewrite IHt; try rewrite IHt1; try rewrite IHt2; eauto; try rewrite shift_add_ty; eauto.
  rewrite plus_assoc. eauto.
Qed.

Lemma subst_shift_id_ty: forall t u l,
  subst u (shift_ty (S l) t) = shift_ty l t.
Proof.
  intros t. induction t; intros; simpl; eauto.
  - rewrite IHt1. rewrite IHt2. eauto.
  - rewrite IHt1. rewrite IHt2. eauto.
  - assert (beq_nat (i + S l) 0 = false). eapply beq_nat_false_iff. omega. rewrite H.
    assert (i+(S l)-1=i+l). omega. rewrite H0; eauto.
Qed.

Lemma subst_shift_id_ty1: forall t u l,
  subst_ty u (shift_tm (S l) t) = shift_tm l t.
Proof.
  intros t. induction t; intros; simpl; eauto.
  - assert (beq_nat (i + S l) 0 = false). eapply beq_nat_false_iff. omega. rewrite H.
    assert (i+(S l)-1=i+l). omega. rewrite H0; eauto.
  - rewrite IHt. rewrite subst_shift_id_ty. eauto.
  - rewrite IHt1. rewrite IHt2. eauto.
  - rewrite IHt. rewrite subst_shift_id_ty. eauto.
  - rewrite IHt. rewrite subst_shift_id_ty. eauto.
  - rewrite subst_shift_id_ty. eauto.
Qed.

Lemma subst_shift_id: forall t u l,
  subst_tm u (shift_tm (S l) t) = shift_tm l t.
Proof.
  intros t. induction t; intros; simpl; eauto.
  - assert (beq_nat (i + S l) 0 = false). eapply beq_nat_false_iff. omega. rewrite H.
    assert (i+(S l)-1=i+l). omega. rewrite H0; eauto.
  - rewrite IHt. rewrite subst_shift_id_ty. eauto.
  - rewrite IHt1. rewrite IHt2. eauto.
  - rewrite IHt. rewrite subst_shift_id_ty. eauto.
  - rewrite IHt. rewrite subst_shift_id_ty. eauto.
  - rewrite subst_shift_id_ty. eauto.
Qed.

Lemma subst_ty_tm: forall t u,
  subst_tm (tty u) t = subst_ty u t.
Proof.
  intros t. induction t; intros; simpl; eauto.
  - rewrite IHt. eauto.
  - rewrite IHt1. rewrite IHt2. eauto.
  - rewrite IHt. eauto.
  - rewrite IHt. eauto.
Qed.

Lemma idx_miss2: forall env i v l,
  i < lengthr env ->
  subst_tm_all l (vcons v env) (tvar i) = subst_tm_all l env (tvar i).
Proof.
  intros env. induction env.
  - intros. inversion H.
  - intros. simpl in H.
    case_eq (beq_nat i (lengthr env)); intros E.
    +
      assert (beq_nat (i - lengthr env) 0 = true) as E1.
      eapply beq_nat_true_iff. eapply beq_nat_true_iff in E. omega.

      simpl. rewrite idx_miss1. rewrite idx_miss1. simpl. rewrite E1.

      destruct v0; destruct v; eauto.

      simpl. rewrite subst_shift_id. eauto. rewrite subst_shift_id_ty. eauto.
      simpl. rewrite subst_shift_id. eauto. rewrite subst_shift_id_ty. eauto.
      simpl. rewrite subst_shift_id_ty. eauto.
      simpl. rewrite subst_shift_id. eauto. rewrite subst_shift_id_ty. eauto.
      simpl. rewrite subst_shift_id. eauto. rewrite subst_shift_id_ty. eauto.
      simpl. rewrite subst_shift_id_ty. eauto.

      simpl. rewrite subst_shift_id_ty. eauto. rewrite shift_add_ty. rewrite plus_comm.
      rewrite subst_shift_id_ty1. eauto.
      simpl. rewrite subst_shift_id_ty. eauto. rewrite shift_add_ty. rewrite plus_comm.
      rewrite subst_shift_id_ty1. eauto.
      simpl. rewrite subst_shift_id_ty. eauto.

      eapply beq_nat_true_iff in E. omega.
      eapply beq_nat_true_iff in E. omega.

    + assert (i < lengthr env). rewrite beq_nat_false_iff in E. omega.
      remember (vcons v env) as env1. simpl.
      subst env1. rewrite IHenv. rewrite IHenv.

      destruct v0.
      eapply (IHenv i (vabs v0 t t0)). eauto.
      eapply (IHenv i (vtabs v0 t t0)). eauto.
      eapply (IHenv i (vty v0 t)). eauto.
      eauto.
      eauto.
Qed.

Lemma idx_hit: forall env i,
  i < lengthr env ->
  subst_tm_res (Some (indexr i env)) = Some (Some (subst_tm_all 0 env (tvar i))).
Proof.
  intros env. induction env.
  - intros. inversion H.
  - intros.
    simpl in H. simpl.
    case_eq (beq_nat i (lengthr env)); intros E.
    + eapply beq_nat_true_iff in E.
      rewrite idx_miss1. subst i. simpl.
      assert (beq_nat (lengthr env - lengthr env) 0 = true). eapply beq_nat_true_iff. omega.
      rewrite H0.
      assert (beq_nat (lengthr env) (lengthr env) = true). eapply beq_nat_true_iff. omega.
      destruct v.
      rewrite shiftz_id. rewrite shiftz_id_ty. eauto.
      rewrite shiftz_id. rewrite shiftz_id_ty. eauto.
      rewrite shiftz_id_ty. eauto.
      omega.
    + assert (i <> lengthr env). eapply beq_nat_false_iff. eauto.
      assert (i < lengthr env). omega.

      specialize (IHenv _ H1).
      rewrite <-(idx_miss2 env _ v) in IHenv . simpl in IHenv. eauto. eauto.
Qed.

(* proof of equivalence *)

Theorem big_env_subst: forall n env e1 e2,
  subst_tm_all 0 env e1 = e2 ->
  subst_tm_res (teval n env e1) = (tevals n e2).
Proof.
  intros n. induction n.
  (* z *) intros. simpl. eauto.
  (* S n *) intros.
  destruct e1; simpl; eauto.
  - (* var *)
    assert (i < lengthr env \/ i >= lengthr env) as L. omega.
    destruct L as [L|L].
    + (* hit *)
      simpl in H.
      specialize (idx_hit env i L). intros IX. rewrite H in IX.
      remember (indexr i env). destruct o.
      * simpl in IX. rewrite IX. destruct v; inversion IX; eauto.
      * inversion IX.
    +
      specialize (idx_miss env i 0 L). intros IX. rewrite H in IX.
      destruct IX as [A B]. rewrite A. rewrite B. eauto.

  - (* tabs *)
    assert (forall env l,
              subst_tm_all l env (tabs t e1) =
              (tabs (subst_ty_all l env t) (subst_tm_all (S l) env e1))) as REC. {
    intros env0. induction env0; intros.
    simpl. eauto.
    simpl. destruct v; rewrite IHenv0; simpl; eauto;
    try rewrite shift_add; rewrite shift_add_ty; rewrite plus_comm; eauto. }

    rewrite REC in H. subst e2. eauto.
  - (* tapp *)
    assert (forall env l,
              subst_tm_all l env (tapp e1_1 e1_2) =
              (tapp (subst_tm_all l env e1_1) (subst_tm_all l env e1_2))) as REC. {
    intros env0. induction env0; intros.
    simpl. eauto.
    simpl. destruct v; rewrite IHenv0; simpl; eauto. }

    rewrite REC in H. subst e2.

    assert (subst_tm_res (teval n env e1_2) = tevals n (subst_tm_all 0 env e1_2)) as HF. eapply IHn; eauto.
    assert (subst_tm_res (teval n env e1_1) = tevals n (subst_tm_all 0 env e1_1)) as HX. eapply IHn; eauto.
    rewrite <-HF. rewrite <-HX. simpl.

    remember ((teval n env e1_2)) as A.
    destruct A as [[|]|]; simpl.
    * remember ((teval n env e1_1)) as B.
      destruct B as [[|]|]; simpl.
      { destruct v0; destruct v; simpl; eauto.
        eapply IHn. simpl. rewrite shiftz_id. rewrite shiftz_id_ty. eauto.
        eapply IHn. simpl. rewrite shiftz_id. rewrite shiftz_id_ty. eauto.
        eapply IHn. simpl. rewrite subst_ty_tm. rewrite shiftz_id_ty. eauto.
      }
      destruct v; eauto.
      destruct v; eauto.
    * eauto.
    * eauto.
  - (* ttabs *)
    assert (forall env l,
              subst_tm_all l env (ttabs t e1) =
              (ttabs (subst_ty_all l env t) (subst_tm_all (S l) env e1))) as REC. {
    intros env0. induction env0; intros.
    simpl. eauto.
    simpl. destruct v; rewrite IHenv0; simpl; eauto;
    try rewrite shift_add; rewrite shift_add_ty; rewrite plus_comm; eauto. }

    rewrite REC in H. subst e2. eauto.
  - (* ttapp *)
    assert (forall env l,
              subst_tm_all l env (ttapp e1 t) =
              (ttapp (subst_tm_all l env e1) (subst_ty_all l env t))) as REC. {
    intros env0. induction env0; intros.
    simpl. eauto.
    simpl. destruct v; rewrite IHenv0; simpl; eauto. }

    rewrite REC in H. subst e2.

    assert (subst_tm_res (teval n env e1) = tevals n (subst_tm_all 0 env e1)) as HX. eapply IHn; eauto.
    rewrite <-HX. simpl.

    remember ((teval n env e1)) as B.
    destruct B as [[?|]|]; simpl.
    { destruct v; simpl; eauto.
      eapply IHn. simpl. rewrite shiftz_id_ty. eauto. }
    eauto. eauto.
  - (* dummy *)
    assert (forall env l T,
              subst_tm_all l env (tty T) =
              (tty (subst_ty_all l env T))) as REC. {
      intros env0. induction env0; intros.
      simpl. eauto.
      simpl. destruct v; rewrite IHenv0; simpl; eauto;
             try rewrite shift_add; rewrite shift_add_ty; rewrite plus_comm; eauto. }

    rewrite REC in H. subst e2. eauto.
Qed.

(* ### Equivalence big-step subst <-> small-step subst ### *)

Lemma app_inv: forall nu t1 t2 t3,
  tevals nu (tapp t1 t2) = Some (Some t3) ->
  exists T ty v2 nv, nu = S nv /\
                     tevals nv t1 = Some (Some (tabs T ty)) /\
                     tevals nv t2 = Some (Some v2) /\
                     tevals nv (subst_tm v2 ty) = Some (Some t3).
Proof.
  intros. destruct nu. inversion H.
  simpl in H.
  remember (tevals nu t2) as rx.
  destruct rx. destruct o.
  remember (tevals nu t1) as rf.
  destruct rf. destruct o.

  destruct t0; inversion H; repeat eexists; eauto.
  inversion H. inversion H. inversion H. inversion H.
Qed.

Lemma tapp_inv: forall nu t1 t2 t3,
  tevals nu (ttapp t1 t2) = Some (Some t3) ->
  exists T ty nv, nu = S nv /\
                     tevals nv t1 = Some (Some (ttabs T ty)) /\
                     tevals nv (subst_ty t2 ty) = Some (Some t3).
Proof.
  intros. destruct nu. inversion H.
  simpl in H.
  remember (tevals nu t1) as rf.
  destruct rf. destruct o.

  destruct t; inversion H; repeat eexists; eauto.
  inversion H. inversion H.
Qed.

Lemma eval_stable: forall n t1 v j,
  tevals n t1 = Some v ->
  j >= n ->
  tevals j t1 = Some v.
Proof.
  intros n. induction n; intros. inversion H.
  destruct j. inversion H0.
  destruct t1; eauto.
  - simpl in H. simpl.
    remember (tevals n t1_2) as rx.
      destruct rx. destruct o.
      rewrite (IHn _ (Some t)).
      remember (tevals n t1_1) as rf.
      destruct rf. destruct o.
      rewrite (IHn _ (Some t0)).
      destruct t0; eauto; eapply IHn; eauto; omega.
      destruct t0; eauto; eapply IHn; eauto; omega.
      omega.
      rewrite (IHn _ None). eauto. eauto. omega.
      inversion H.

      eauto. omega.
      inversion H. rewrite (IHn _ None). eauto. eauto. omega.
      inversion H.
 - simpl in H. simpl.
    remember (tevals n t1) as rf.
      destruct rf. destruct o.
      rewrite (IHn _ (Some t0)).
      destruct t0; eauto; eapply IHn; eauto; omega.
      destruct t0; eauto; eapply IHn; eauto; omega.
      omega.
      rewrite (IHn _ None). eauto. eauto. omega.
      inversion H.
Qed.

Lemma value_eval: forall t1,
   value t1 ->
   forall nu, nu >= 1 -> tevals nu t1 = Some (Some t1).
Proof.
  intros. destruct nu. inversion H0. inversion H; eauto.
Qed.

Lemma step_eval: forall t1 t2,
  step t1 t2 ->
  forall t3 nu, tevals nu t2 = Some (Some t3) ->
  tevals (S nu) t1 = Some (Some t3).
Proof.
  intros ? ? ?. induction H; intros.
  - (* AppAbs *)
    simpl.
    assert (nu >= 1). destruct nu. inversion H0. omega.
    rewrite (value_eval v).
    rewrite (value_eval (tabs T1 t12)).
    eapply H0; omega. constructor.
    eauto. eauto. eauto.
  - (* App1 *)
    simpl. eapply app_inv in H0.
    repeat destruct H0 as [? H0].
    destruct H0 as [N [E1 [E2 E3]]].
    subst nu. eapply IHstep in E1.
    eapply eval_stable in E2.
    rewrite E1. rewrite E2. eapply eval_stable. eapply E3. eauto. eauto.
  - (* App2 *)
    simpl. eapply app_inv in H1.
    repeat destruct H1 as [? H1].
    destruct H1 as [N [E1 [E2 E3]]].
    subst nu. eapply IHstep in E2.
    eapply eval_stable in E1.
    rewrite E1. rewrite E2. eapply eval_stable. eapply E3. eauto. eauto.
  - (* TAppAbs *)
    simpl.
    assert (nu >= 1). destruct nu. inversion H. omega.
    rewrite (value_eval (ttabs T1 t12)).
    eapply H; omega. constructor.
    eauto.
  - (* App1 *)
    simpl. eapply tapp_inv in H0.
    repeat destruct H0 as [? H0].
    destruct H0 as [N [E1 E2]].
    subst nu. eapply IHstep in E1.
    eapply eval_stable in E2.
    rewrite E1. rewrite E2. eauto. eauto.
Qed.

(* proof of equivalence: small-step implies big-step *)

Theorem small_to_big: forall n t1 t2,
   mstep n t1 t2 -> value t2 ->
   exists ns, tevals ns t1 = Some (Some t2).
Proof.
  intros n. induction n.
  (* z *)
  intros. inversion H; subst.
  exists 1. eapply value_eval; eauto.
  (* S n *)
  intros. inversion H; subst.
  eapply IHn in H3. destruct H3.
  exists (S x). eapply step_eval; eauto.
  eauto.
Qed.

(* proof of equivalence: big-step implies small-step *)

Lemma ms_app1 : forall n t1 t1' t2,
     mstep n t1 t1' ->
     mstep n (tapp t1 t2) (tapp t1' t2).
Proof.
  intros. induction H. constructor.
  econstructor. eapply ST_App1; eauto. eauto.
Qed.

Lemma ms_app2 : forall n t1 t2 t2',
     value t1 ->
     mstep n t2 t2' ->
     mstep n (tapp t1 t2) (tapp t1 t2').
Proof.
  intros. induction H0. constructor.
  econstructor. apply ST_App2; eauto. eauto.
Qed.

Lemma ms_tapp1 : forall n t1 t1' t2,
     mstep n t1 t1' ->
     mstep n (ttapp t1 t2) (ttapp t1' t2).
Proof.
  intros. induction H. constructor.
  econstructor. eapply ST_TApp1; eauto. eauto.
Qed.

Lemma ms_trans : forall n1 n2 t1 t2 t3,
     mstep n1 t1 t2 ->
     mstep n2 t2 t3 ->
     mstep (n1+n2) t1 t3.
Proof.
  intros. induction H. eauto.
  econstructor. eauto. eauto.
Qed.

Theorem big_to_small: forall n t1 t2,
   tevals n t1 = Some (Some t2) ->
   exists ns, value t2 /\ mstep ns t1 t2.
Proof.
  intros n. induction n; intros. inversion H. destruct t1.
  - simpl in H. inversion H.
  - simpl in H. inversion H. eexists. split; constructor.
  - eapply app_inv in H. repeat destruct H as [? H].
    destruct H as [N [E1 [E2 E3]]]. inversion N. subst x2.
    eapply IHn in E1. eapply IHn in E2. eapply IHn in E3.
    destruct E1 as [? [? E1]]. destruct E2 as [? [? E2]]. destruct E3 as [? [? E3]].
    eexists. split. eauto.
    eapply ms_app1 in E1. eapply ms_app2 in E2.
    eapply ms_trans. eapply E1.
    eapply ms_trans. eapply E2. econstructor. econstructor.
    eauto. eauto. eauto.
  - simpl in H. inversion H. eexists. split; constructor.
  - eapply tapp_inv in H. repeat destruct H as [? H].
    destruct H as [N [E1 E2]]. inversion N. subst x1.
    eapply IHn in E1. eapply IHn in E2.
    destruct E1 as [? [? E1]]. destruct E2 as [? [? E2]].
    eexists. split. eauto.
    eapply ms_tapp1 in E1.
    eapply ms_trans. eapply E1.  econstructor. econstructor.
    eauto.
  - simpl in H. inversion H. eexists. split; constructor.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable sQ_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable rE_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable per_ : Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable eF_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable deftriangle_1 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_2 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable lemma_NCdistinct_3 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable lemma_inequalitysymmetric_4 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_extension_5 : (forall A B P Q : Universe, (exists X : Universe, ((A <> B /\ P <> Q) -> (betS_ A B X /\ cong_ B X P Q)))).
Variable defcollinear_6 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_7 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_8 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_9 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_10 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_11 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_12 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_13 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_betweennotequal_14 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_NChelper_15 : (forall A B C P Q : Universe, ((~(col_ A B C) /\ (col_ A B P /\ (col_ A B Q /\ P <> Q))) -> ~(col_ P Q C))).
Variable lemma_NCorder_16 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable proposition_11B_17 : (forall A B C P : Universe, (exists X : Universe, ((betS_ A C B /\ ~(col_ A B P)) -> (per_ A C X /\ tS_ X A B P)))).
Variable lemma_rightangleNC_18 : (forall A B C : Universe, (per_ A B C -> ~(col_ A B C))).
Variable lemma_layoff_19 : (forall A B C D : Universe, (exists X : Universe, ((A <> B /\ C <> D) -> (out_ A B X /\ cong_ A X C D)))).
Variable lemma_8_3_20 : (forall A B C D : Universe, ((per_ A B C /\ out_ B C D) -> per_ A B D)).
Variable proposition_46_21 : (forall A B R : Universe, (exists X Y : Universe, ((A <> B /\ ~(col_ A B R)) -> (sQ_ A B X Y /\ (tS_ Y A B R /\ pG_ A B X Y))))).
Variable lemma_oppositesideflip_22 : (forall A B P Q : Universe, (tS_ P A B Q -> tS_ P B A Q)).
Variable proposition_47_23 : (forall A B C D E F G H K : Universe, (exists X Y : Universe, ((triangle_ A B C /\ (per_ B A C /\ (sQ_ A B F G /\ (tS_ G B A C /\ (sQ_ A C K H /\ (tS_ H C A B /\ (sQ_ B C E D /\ tS_ D C B A))))))) -> (pG_ B X Y D /\ (betS_ B X C /\ (pG_ X C E Y /\ (betS_ D Y E /\ (eF_ A B F G B X Y D /\ eF_ A C K H X C E Y)))))))).
Variable lemma_congruencesymmetric_24 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_squaresequal_25 : (forall A B C D Xa Xb Xc Xd : Universe, ((cong_ A B Xa Xb /\ (sQ_ A B C D /\ sQ_ Xa Xb Xc Xd)) -> eF_ A B C D Xa Xb Xc Xd)).
Variable cn_congruencereflexive_26 : (forall A B : Universe, cong_ A B A B).
Variable axiom_EFtransitive_27 : (forall A B C D P Q R S Ca Cb Cc Cd : Universe, ((eF_ A B C D Ca Cb Cc Cd /\ eF_ Ca Cb Cc Cd P Q R S) -> eF_ A B C D P Q R S)).
Variable axiom_EFsymmetric_28 : (forall A B C D Ca Cb Cc Cd : Universe, (eF_ A B C D Ca Cb Cc Cd -> eF_ Ca Cb Cc Cd A B C D)).
Variable axiom_betweennesssymmetry_29 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable defsquare_30 : (forall A B C D : Universe, (sQ_ A B C D -> (cong_ A B C D /\ (cong_ A B B C /\ (cong_ A B D A /\ (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ per_ C D A)))))))).
Variable defsquare2_31 : (forall A B C D : Universe, ((cong_ A B C D /\ (cong_ A B B C /\ (cong_ A B D A /\ (per_ D A B /\ (per_ A B C /\ (per_ B C D /\ per_ C D A)))))) -> sQ_ A B C D)).
Variable lemma_collinearright_32 : (forall A B C D : Universe, ((per_ A B D /\ (col_ A B C /\ C <> B)) -> per_ C B D)).
Variable lemma_PGrotate_33 : (forall A B C D : Universe, (pG_ A B C D -> pG_ B C D A)).
Variable lemma_PGrectangle_34 : (forall A B C D : Universe, ((pG_ A C D B /\ per_ B A C) -> rE_ A C D B)).
Variable lemma_rectanglerotate_35 : (forall A B C D : Universe, (rE_ A B C D -> rE_ B C D A)).
Variable lemma_paste5_36 : (forall B C D E L M Xb Xc Xd Xe Xl Xm : Universe, ((eF_ B M L D Xb Xm Xl Xd /\ (eF_ M C E L Xm Xc Xe Xl /\ (betS_ B M C /\ (betS_ Xb Xm Xc /\ (betS_ E L D /\ (betS_ Xe Xl Xd /\ (rE_ M C E L /\ rE_ Xm Xc Xe Xl))))))) -> eF_ B C E D Xb Xc Xe Xd)).
Variable proposition_48A_37 : (forall A B C D Xa Xb Xc Xd : Universe, ((sQ_ A B C D /\ (sQ_ Xa Xb Xc Xd /\ eF_ A B C D Xa Xb Xc Xd)) -> cong_ A B Xa Xb)).
Variable proposition_08_38 : (forall A B C D E F : Universe, ((triangle_ A B C /\ (triangle_ D E F /\ (cong_ A B D E /\ (cong_ A C D F /\ cong_ B C E F)))) -> (congA_ B A C E D F /\ (congA_ C B A F E D /\ congA_ A C B D F E)))).
Variable lemma_equaltorightisright_39 : (forall A B C Xa Xb Xc : Universe, ((per_ A B C /\ congA_ Xa Xb Xc A B C) -> per_ Xa Xb Xc)).

Theorem proposition_48_40 : (forall A B C D E F G H K L M : Universe, ((triangle_ A B C /\ (sQ_ A B F G /\ (sQ_ A C K H /\ (sQ_ B C E D /\ (betS_ B M C /\ (betS_ E L D /\ (eF_ A B F G B M L D /\ (eF_ A C K H M C E L /\ rE_ M C E L)))))))) -> per_ B A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e480m2e240m1_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Bedrock.Platform.Cito.Syntax.

Set Implicit Arguments.

Require Import Bedrock.StringSet.
Import StringSet.
Require Import Coq.FSets.FSetProperties.
Module Import SSP := Properties StringSet.

(* syntactic_requirement *)
Section SynReq.

  Require Import Coq.Strings.String.

  Variable vars : list string.

  Variable temp_size : nat.

  Variable s : Stmt.

  Require Import Bedrock.Platform.Cito.FreeVars.
  Require Import Bedrock.Platform.Cito.Depth.

  Local Open Scope nat.

  Definition in_scope :=
    Subset (free_vars s) (of_list vars) /\
    depth s <= temp_size.

  Require Import Bedrock.Platform.Cito.WellFormed.

  Definition syn_req := in_scope /\ wellformed s.

End SynReq.

Require Import Bedrock.Platform.Cito.ADT.
Require Import Bedrock.Platform.Cito.RepInv.

Module Make (Import E : ADT) (Import M : RepInv E).

  Require Import Bedrock.Platform.Cito.Inv.
  Module Import InvMake := Make E.
  Import SemanticsMake.
  Module Import InvMake2 := Make M.

  Section Spec.

    Variable vars : list string.

    Variable temp_size : nat.

    Variable s k : Stmt.

    Variable rv_postcond : W -> vals -> Prop.

    Definition precond := inv vars temp_size rv_postcond (Syntax.Seq s k).

    Definition postcond := inv vars temp_size rv_postcond k.

    Definition imply (pre new_pre: assert) := forall specs x, interp specs (pre x) -> interp specs (new_pre x).

    Definition verifCond pre := imply pre precond :: syn_req vars temp_size (Syntax.Seq s k) :: nil.

  End Spec.

End Make.


Require Import Coq.Classes.Morphisms.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Tactics.SplitMinMax.
Require Import Crypto.Util.ZUtil.Stabilization.
Require Import Crypto.Util.ZUtil.MulSplit.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.PointedProp.
Require Import Crypto.Util.Bool.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZRange.Operations.
Require Import Crypto.Util.ZRange.BasicLemmas.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SpecializeAllWays.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.SpecializeBy.

Local Open Scope Z_scope.

Module ZRange.
  Import Operations.ZRange.
  Local Arguments is_bounded_by' !_ _ _ / .
  Local Coercion is_true : bool >-> Sortclass.

  Fixpoint app' {A B} {n : nat} : nary_T A B (S n) -> tuple' A n -> B
    := match n with
       | O => fun f x => f x
       | S n => fun f '(xs, x) => @app' A B n (f x) xs
       end.
  Definition app {A B} {n : nat} : nary_T A B n -> tuple A n -> B
    := match n with
       | O => fun x _ => x
       | S n => @app' A B n
       end.

  Local Notation R b := (match b with true => Z.le | false => Basics.flip Z.le end).

  Local Notation Rp b := (match b with true => Pos.le | false => Basics.flip Pos.le end).

  Fixpoint is_monotone_on_projections {n : nat} : nary_T Z Z n -> Prop
    := match n with
       | O => fun _ => True
       | S n' => fun f
                => (forall x, is_monotone_on_projections (f x))
                  /\ (forall args, exists b, Proper (R b ==> Z.le) (fun x => app (f x) args))
       end.

  Fixpoint is_piecewise_monotone_on_projections {n : nat} : nary_T Z Z n -> Prop
    := match n with
       | O => fun _ => True
       | S n'
         => fun f
            => (forall x, is_piecewise_monotone_on_projections (f x))
               /\ (forall args, exists b, Proper (Rp b ==> Z.le) (fun x => app (f (Zpos x)) args))
               /\ (forall args, exists b, Proper (Rp b ==> Z.le) (fun x => app (f (Zneg x)) args))
       end.

  Definition all_are_bounded_by_bool {n} (v : tuple Z n) (v_bs : tuple zrange n) : bool
    := Tuple.fieldwiseb is_bounded_by_bool v v_bs.

  Local Ltac fast_split_min_max := rewrite ?Z.min_le_iff, ?Z.max_le_iff.

  Local Ltac t_fin_common_step :=
    first [ progress cbv [all_are_bounded_by_bool is_bounded_by_bool is_monotone_on_projections is_true is_tighter_than_bool] in *
          | progress cbv [Proper respectful Basics.flip] in *
          | progress cbn in *
          | progress rewrite ?Bool.orb_true_iff, ?Bool.orb_false_iff, ?Bool.andb_true_iff, ?Z.leb_le, ?Z.ltb_lt in *
          | progress Z.ltb_to_lt
          | progress fast_split_min_max
          | progress destruct_head'_and
          | progress destruct_head'_prod
          | progress destruct_head'_ex
          | progress specialize_by exact tt
          | progress specialize_by exact I
          | progress destruct_head' zrange
          | solve [ auto using or_introl, or_intror, Z.le_refl ]
          | match goal with
            | [ H : _ -> True |- _ ] => clear H
            | [ H : ?x <= ?x |- _ ] => clear H
            | [ H : ?x \/ ?x |- _ ] => assert x by (destruct H; assumption); clear H
            | [ H : ?x < ?x |- _ ] => exfalso; clear -H; lia
            | [ H : 0 <= Z.pos _ |- _ ] => clear H
            | [ H : 0 < Z.pos _ |- _ ] => clear H
            | [ H : Z.neg _ <= 0 |- _ ] => clear H
            | [ H : Z.neg _ < 0 |- _ ] => clear H
            | [ H : Z.pos _ <= Z.neg _ |- _ ] => exfalso; clear -H; lia
            | [ H : Z.pos _ <= 0 |- _ ] => exfalso; clear -H; lia
            | [ H : 0 <= Z.neg _ |- _ ] => exfalso; clear -H; lia
            | [ H : Z.pos _ < 0 |- _ ] => exfalso; clear -H; lia
            | [ |- context[Z.max 1 (Z.pos ?x)] ] => rewrite (Z.max_r 1 (Zpos x)) by (clear; lia)
            | [ |- context[Z.min 1 (Z.pos ?x)] ] => rewrite (Z.min_l 1 (Zpos x)) by (clear; lia)
            | [ H : ?x > ?y |- _ ] => assert (y < x) by (clear -H; lia); clear H
            | [ H : ?x >= ?y |- _ ] => assert (y <= x) by (clear -H; lia); clear H
            | [ |- context[Z.max (Z.neg ?x) (-1)] ] => rewrite (Z.max_r (Zneg x) (-1)) by (clear; lia)
            | [ |- context[Z.min (Z.neg ?x) (-1)] ] => rewrite (Z.min_l (Zneg x) (-1)) by (clear; lia)
            end ].
  Local Ltac t_fin_saturate_step :=
    first [ progress destruct_head'_bool
          | match goal with
            | [ H : forall (x : Z) (y : Z), _ <= _ -> _ <= _, v : Z |- _ ]
              => unique pose proof (H v v ltac:(reflexivity))
            | [ H : forall (x : Z) (y : Z), _ <= _ -> _ <= _, v : Z, v' : Z |- _ ]
              => unique pose proof (H v v' ltac:(auto || reflexivity))
            end
          | apply conj ].
  Local Ltac t_fin_specific_pos_step :=
    first [ match goal with
            | [ H : _ \/ _ |- _ ] => destruct H as [H|H]; try (exfalso; clear -H; lia); []
            | [ H : Z.pos _ <= ?v |- _ ] => is_var v; destruct v as [|v|v]; try (exfalso; clear -H; lia)
            | [ H : ?v <= Z.neg _ |- _ ] => is_var v; destruct v as [|v|v]; try (exfalso; clear -H; lia)
            | [ H : 0 <= ?v |- _ ] => is_var v; destruct v as [|v|v]; try (exfalso; clear -H; lia)
            | [ H : ?v <= 0 |- _ ] => is_var v; destruct v as [|v|v]; try (exfalso; clear -H; lia)
            | [ H : 0 < ?v |- _ ] => is_var v; destruct v as [|v|v]; try (exfalso; clear -H; lia)
            | [ H : ?v < 0 |- _ ] => is_var v; destruct v as [|v|v]; try (exfalso; clear -H; lia)
            end
          | break_innermost_match_step
          | progress destruct_head'_bool
          | match goal with
            | [ H' : Z.le (?f ?p) (?g ?q) |- _ ]
              => first [ unique assert (Pos.le p q) by (clear -H'; lia)
                       | unique assert (Pos.le q p) by (clear -H'; lia) ]
            | [ H : forall x y, Pos.le _ _ -> _ <= _, H' : Pos.le _ _ |- _ ]
              => unique pose proof (H _ _ H')
            | [ H : forall x y, Pos.le x _ -> _ <= _, v : positive |- _ ]
              => unique pose proof (H 1%positive v ltac:(clear; lia))
            | [ H : forall x y, Pos.le _ x -> _ <= _, v : positive |- _ ]
              => unique pose proof (H v 1%positive ltac:(clear; lia))
            end
          | apply conj
          | progress destruct_head' Z ].
  Local Ltac t_fin :=
    repeat first [ t_fin_common_step
                 | t_fin_saturate_step ].
  Local Ltac t_fin_pos :=
    repeat first [ t_fin_common_step
                 | t_fin_specific_pos_step ].

  Lemma pull_union_under_args2 A n f g bs
    : @app' A _ n (under_args2 union f g) bs
      = union (app' f bs) (app' g bs).
  Proof. induction n; t_fin. Qed.

  Lemma monotone_n_corners_genb
        n f
        (Hmonotone : @is_monotone_on_projections n f)
        v v_bs
        (Hboundedx : @all_are_bounded_by_bool n v v_bs)
    : is_bounded_by_bool (app f v) (app (n_corners f) v_bs).
  Proof.
    destruct n as [|n].
    { cbv [all_are_bounded_by_bool is_bounded_by_bool is_monotone_on_projections is_true] in *; cbn in *.
      rewrite Bool.andb_true_iff, Z.leb_le; split; reflexivity. }
    cbv [app tuple all_are_bounded_by_bool fieldwiseb] in *.
    induction n as [|n IHn].
    { t_fin. }
    { destruct v_bs as [ v_bs [l u] ], v as [vs v]; cbn [lower upper] in *.
      cbn [fieldwiseb' fst snd] in Hboundedx.
      cbv [is_true] in *.
      rewrite Bool.andb_true_iff in Hboundedx.
      destruct Hboundedx as [Hboundedx0 Hboundedx1].
      destruct Hmonotone as [Hmonotone0 Hmonotone1].
      specialize (fun x => IHn (f x) (Hmonotone0 _) vs v_bs Hboundedx0).
      cbn [app'].
      set (Sn := S n) in *.
      cbn [n_corners].
      set (f' := fun x => @n_corners Sn (f x)).
      lazymatch type of IHn with
      | forall x, is_bounded_by_bool (@?B x) (app' _ ?v_bs) = true
        => change (forall x, is_bounded_by_bool (B x) (app' (f' x) v_bs) = true) in IHn
      end; cbv beta in *.
      clearbody f'.
      cbn -[Sn] in *.
      rewrite pull_union_under_args2.
      cbv [is_bounded_by_bool app] in *.
      unfold Sn in Hmonotone1.
      setoid_rewrite Bool.andb_true_iff in IHn.
      rewrite ?Bool.andb_true_iff in *.
      setoid_rewrite Z.leb_le in IHn.
      rewrite !Z.leb_le in *.
      specialize (Hmonotone1 vs).
      destruct Hmonotone1 as [? Hmonotone1].
      clear -IHn Hboundedx1 Hmonotone1.
      cbn [lower upper] in *.
      destruct_head'_bool.
      all: split; etransitivity; [ | eapply Hmonotone1, Hboundedx1 | eapply Hmonotone1, Hboundedx1 | ].
      all: first [ etransitivity; [ eapply IHn | ] | etransitivity; [ | eapply IHn ] ].
      all: clear; t_fin. }
  Qed.

  Lemma monotone_n_corners_and_zero_genb
        n f
        (Hmonotone : @is_piecewise_monotone_on_projections n f)
        v v_bs
        (Hboundedx : @all_are_bounded_by_bool n v v_bs)
    : is_bounded_by_bool (app f v) (app (n_corners_and_zero f) v_bs).
  Proof.
    destruct n as [|n].
    { cbv [all_are_bounded_by_bool is_bounded_by_bool is_piecewise_monotone_on_projections is_true] in *; cbn in *.
      rewrite Bool.andb_true_iff, Z.leb_le; split; reflexivity. }
    cbv [app tuple all_are_bounded_by_bool fieldwiseb] in *.
    induction n as [|n IHn].
    { t_fin_pos. }
    { destruct v_bs as [ v_bs [l u] ], v as [vs v]; cbn [lower upper] in *.
      cbn [fieldwiseb' fst snd] in Hboundedx.
      cbv [is_true] in *.
      rewrite Bool.andb_true_iff in Hboundedx.
      destruct Hboundedx as [Hboundedx0 Hboundedx1].
      destruct Hmonotone as [Hmonotone0 [Hmonotone1 Hmonotone2] ].
      specialize (fun f pf => IHn f pf vs v_bs Hboundedx0).
      specialize (fun x => IHn (f x) (Hmonotone0 _)).
      cbn [app'].
      set (Sn := S n) in *.
      cbn [n_corners_and_zero].
      set (f' := fun x => @n_corners_and_zero Sn (f x)).
      lazymatch type of IHn with
      | forall x, is_bounded_by_bool (@?B x) (app' _ ?v_bs) = true
        => change (forall x, is_bounded_by_bool (B x) (app' (f' x) v_bs) = true) in IHn
      end; cbv beta in *.
      clearbody f'.
      cbn -[Sn] in *.
      cbv [is_bounded_by_bool app] in *.
      unfold Sn in Hmonotone1, Hmonotone2.
      setoid_rewrite Bool.andb_true_iff in IHn.
      rewrite ?Bool.andb_true_iff in *.
      setoid_rewrite Z.leb_le in IHn.
      rewrite !Z.leb_le in *.
      specialize (Hmonotone1 vs).
      specialize (Hmonotone2 vs).
      destruct Hmonotone1 as [? Hmonotone1].
      destruct Hmonotone2 as [? Hmonotone2].
      clear -IHn Hboundedx1 Hmonotone1 Hmonotone2.
      cbn [lower upper] in *.
      destruct l as [|l|l], u as [|u|u], v as [|v|v].
      all: try (exfalso; clear -Hboundedx1; lia).
      all: cbn -[Sn] in *.
      all: rewrite !pull_union_under_args2.
      all: cbv [union]; cbn [lower upper].
      all: repeat match goal with
                  | [ H : context[Zpos ?p <= Zpos ?q] |- _ ]
                    => unique assert (Pos.le p q) by lia
                  | [ H : context[Zneg ?p <= Zneg ?q] |- _ ]
                    => unique assert (Pos.le q p) by lia
                  end.
      all: destruct_head'_bool.
      all: first [ split; etransitivity;
                   [ | first [ eapply Hmonotone1 | eapply Hmonotone2 ];
                       first [ eassumption | eapply Pos.le_1_l ]
                     | first [ eapply Hmonotone1 | eapply Hmonotone2 ];
                       first [ eassumption | eapply Pos.le_1_l ] | ]
                 | split ].
      all: first [ etransitivity; [ eapply IHn | ] | etransitivity; [ | eapply IHn ] ].
      all: fast_split_min_max.
      all: auto using Z.le_refl.
      all: repeat t_fin_common_step. }
  Qed.

  Lemma monotone_two_corners_genb'
        (f : Z -> Z)
        (Hmonotone : exists b, Proper (R b ==> Z.le) f)
        x_bs x
        (Hboundedx : is_bounded_by_bool x x_bs)
    : is_tighter_than_bool (constant (f x)) (two_corners f x_bs).
  Proof.
    exact (@monotone_n_corners_genb 1 f (ltac:(repeat split; auto)) x x_bs Hboundedx).
  Qed.

  Lemma monotone_two_corners_and_zero_genb'
        (f : Z -> Z)
        (Hmonotonep : exists b, Proper (Rp b ==> Z.le) (fun x => f (Zpos x)))
        (Hmonotonen : exists b, Proper (Rp b ==> Z.le) (fun x => f (Zneg x)))
        x_bs x
        (Hboundedx : is_bounded_by_bool x x_bs)
    : is_tighter_than_bool (constant (f x)) (two_corners_and_zero f x_bs).
  Proof.
    unshelve eapply (@monotone_n_corners_and_zero_genb 1 f _ x x_bs Hboundedx).
    repeat split; auto.
  Qed.

  Lemma monotoneb_two_corners_gen
        (f : Z -> Z)
        (Hmonotone : Proper (Z.le ==> Z.le) f \/ Proper (Basics.flip Z.le ==> Z.le) f)
        x_bs x
        (Hboundedx : ZRange.is_bounded_by_bool x x_bs = true)
    : ZRange.is_bounded_by_bool (f x) (ZRange.two_corners f x_bs) = true.
  Proof.
    apply (fun pf => monotone_two_corners_genb' f pf _ _ Hboundedx).
    rewrite Bool.ex_bool_iff_or; auto.
  Qed.

  Lemma monotoneb_two_corners_and_zero_gen
        (f : Z -> Z)
        (Hmonotonep : Proper (Pos.le ==> Z.le) (fun x => f (Zpos x)) \/ Proper (Basics.flip Pos.le ==> Z.le) (fun x => f (Zpos x)))
        (Hmonotonen : Proper (Pos.le ==> Z.le) (fun x => f (Zneg x)) \/ Proper (Basics.flip Pos.le ==> Z.le) (fun x => f (Zneg x)))
        x_bs x
        (Hboundedx : ZRange.is_bounded_by_bool x x_bs = true)
    : ZRange.is_bounded_by_bool (f x) (ZRange.two_corners_and_zero f x_bs) = true.
  Proof.
    apply (fun pf1 pf2 => monotone_two_corners_and_zero_genb' f pf1 pf2 _ _ Hboundedx).
    all: rewrite Bool.ex_bool_iff_or; auto.
  Qed.

  Local Ltac t_fill :=
    intros; rewrite ?Bool.ex_bool_iff_or; auto;
    cbn in *; cbv [is_true] in *; rewrite ?Bool.andb_true_iff; intuition eauto.

  Local Ltac t_red :=
    cbv [eight_corners_and_zero four_corners_and_zero two_corners_and_zero n_corners_and_zero apply_to_split_range apply_to_split_range_under_args apply_to_each_split_range apply_to_each_split_range_under_args under_args2 apply_to_range apply_to_range_under_args].

  Lemma two_corners_and_zero_eq f x
    : two_corners_and_zero f x = @n_corners_and_zero 1 f x.
  Proof. reflexivity. Qed.

  Lemma monotone_four_corners_genb'
        (f : Z -> Z -> Z)
        (Hmonotone1 : forall x, exists b, Proper (R b ==> Z.le) (fun y => f x y))
        (Hmonotone2 : forall y, exists b, Proper (R b ==> Z.le) (fun x => f x y))
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs)
        (Hboundedy : is_bounded_by_bool y y_bs)
    : is_tighter_than_bool (constant (f x y)) (four_corners f x_bs y_bs).
  Proof.
    apply (fun pf => @monotone_n_corners_genb 2 f pf (y, x) (y_bs, x_bs)).
    all: t_fill.
  Qed.

  Lemma four_corners_and_zero_eq f x y
    : four_corners_and_zero f x y = @n_corners_and_zero 2 f x y.
  Proof.
    set (n:=1%nat).
    cbv [four_corners_and_zero].
    cbn [n_corners_and_zero].
    generalize (fun x => two_corners_and_zero_eq (f x)).
    subst n.
    generalize (@two_corners_and_zero) (@n_corners_and_zero 1).
    t_red.
    break_innermost_match; intros ?? H; rewrite ?H; reflexivity.
  Qed.

  Lemma monotone_four_corners_and_zero_genb'
        (f : Z -> Z -> Z)
        (Hmonotone1p : forall x, exists b, Proper (Rp b ==> Z.le) (fun y => f x (Zpos y)))
        (Hmonotone1n : forall x, exists b, Proper (Rp b ==> Z.le) (fun y => f x (Zneg y)))
        (Hmonotone2p : forall y, exists b, Proper (Rp b ==> Z.le) (fun x => f (Zpos x) y))
        (Hmonotone2n : forall y, exists b, Proper (Rp b ==> Z.le) (fun x => f (Zneg x) y))
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs)
        (Hboundedy : is_bounded_by_bool y y_bs)
    : is_tighter_than_bool (constant (f x y)) (four_corners_and_zero f x_bs y_bs).
  Proof.
    rewrite four_corners_and_zero_eq.
    exact (@monotone_n_corners_and_zero_genb 2 f ltac:(t_fill) (y, x) (y_bs, x_bs) ltac:(t_fill)).
  Qed.

  Lemma monotoneb_four_corners_gen
        (f : Z -> Z -> Z)
        (Hmonotone1 : forall x, Proper (R true ==> Z.le) (fun y => f x y) \/ Proper (R false ==> Z.le) (fun y => f x y))
        (Hmonotone2 : forall y, Proper (R true ==> Z.le) (fun x => f x y) \/ Proper (R false ==> Z.le) (fun x => f x y))
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs)
        (Hboundedy : is_bounded_by_bool y y_bs)
    : is_tighter_than_bool (constant (f x y)) (four_corners f x_bs y_bs).
  Proof.
    apply monotone_four_corners_genb'; t_fill.
  Qed.

  Lemma monotoneb_four_corners_and_zero_gen
        (f : Z -> Z -> Z)
        (Hmonotone1p : forall x, Proper (Rp true ==> Z.le) (fun y => f x (Zpos y)) \/ Proper (Rp false ==> Z.le) (fun y => f x (Zpos y)))
        (Hmonotone1n : forall x, Proper (Rp true ==> Z.le) (fun y => f x (Zneg y)) \/ Proper (Rp false ==> Z.le) (fun y => f x (Zneg y)))
        (Hmonotone2p : forall y, Proper (Rp true ==> Z.le) (fun x => f (Zpos x) y) \/ Proper (Rp false ==> Z.le) (fun x => f (Zpos x) y))
        (Hmonotone2n : forall y, Proper (Rp true ==> Z.le) (fun x => f (Zneg x) y) \/ Proper (Rp false ==> Z.le) (fun x => f (Zneg x) y))
        x x_bs y y_bs
        (Hboundedx : is_bounded_by_bool x x_bs)
        (Hboundedy : is_bounded_by_bool y y_bs)
    : is_tighter_than_bool (constant (f x y)) (four_corners_and_zero f x_bs y_bs).
  Proof.
    apply monotone_four_corners_and_zero_genb'; t_fill.
  Qed.

  Lemma monotone_eight_corners_genb'
        (f : Z -> Z -> Z -> Z)
        (Hmonotone1 : forall x y, exists b, Proper (R b ==> Z.le) (fun z => f x y z))
        (Hmonotone2 : forall x z, exists b, Proper (R b ==> Z.le) (fun y => f x y z))
        (Hmonotone3 : forall y z, exists b, Proper (R b ==> Z.le) (fun x => f x y z))
        x x_bs y y_bs z z_bs
        (Hboundedx : is_bounded_by_bool x x_bs)
        (Hboundedy : is_bounded_by_bool y y_bs)
        (Hboundedz : is_bounded_by_bool z z_bs)
    : is_tighter_than_bool (constant (f x y z)) (eight_corners f x_bs y_bs z_bs).
  Proof.
    apply (fun pf => @monotone_n_corners_genb 3 f pf (z, y, x) (z_bs, y_bs, x_bs)).
    all: t_fill.
  Qed.

  Lemma eight_corners_and_zero_eq f x y z
    : eight_corners_and_zero f x y z = @n_corners_and_zero 3 f x y z.
  Proof.
    set (n:=2%nat).
    cbv [eight_corners_and_zero].
    cbn [n_corners_and_zero].
    generalize (fun x => four_corners_and_zero_eq (f x)).
    subst n.
    generalize (@four_corners_and_zero) (@n_corners_and_zero 2).
    t_red.
    break_innermost_match; intros ?? H; rewrite ?H; reflexivity.
  Qed.

  Lemma monotone_eight_corners_and_zero_genb'
        (f : Z -> Z -> Z -> Z)
        (Hmonotone1p : forall x y, exists b, Proper (Rp b ==> Z.le) (fun z => f x y (Zpos z)))
        (Hmonotone1n : forall x y, exists b, Proper (Rp b ==> Z.le) (fun z => f x y (Zneg z)))
        (Hmonotone2p : forall x z, exists b, Proper (Rp b ==> Z.le) (fun y => f x (Zpos y) z))
        (Hmonotone2n : forall x z, exists b, Proper (Rp b ==> Z.le) (fun y => f x (Zneg y) z))
        (Hmonotone3p : forall y z, exists b, Proper (Rp b ==> Z.le) (fun x => f (Zpos x) y z))
        (Hmonotone3n : forall y z, exists b, Proper (Rp b ==> Z.le) (fun x => f (Zneg x) y z))
        x x_bs y y_bs z z_bs
        (Hboundedx : is_bounded_by_bool x x_bs)
        (Hboundedy : is_bounded_by_bool y y_bs)
        (Hboundedz : is_bounded_by_bool z z_bs)
    : is_tighter_than_bool (constant (f x y z)) (eight_corners_and_zero f x_bs y_bs z_bs).
  Proof.
    rewrite eight_corners_and_zero_eq.
    exact (@monotone_n_corners_and_zero_genb 3 f ltac:(t_fill) (z, y, x) (z_bs, y_bs, x_bs) ltac:(t_fill)).
  Qed.

  Lemma monotoneb_eight_corners_gen
        (f : Z -> Z -> Z -> Z)
        (Hmonotone1 : forall x y, Proper (R true ==> Z.le) (fun z => f x y z) \/ Proper (R false ==> Z.le) (fun z => f x y z))
        (Hmonotone2 : forall x z, Proper (R true ==> Z.le) (fun y => f x y z) \/ Proper (R false ==> Z.le) (fun y => f x y z))
        (Hmonotone3 : forall y z, Proper (R true ==> Z.le) (fun x => f x y z) \/ Proper (R false ==> Z.le) (fun x => f x y z))
        x x_bs y y_bs z z_bs
        (Hboundedx : is_bounded_by_bool x x_bs)
        (Hboundedy : is_bounded_by_bool y y_bs)
        (Hboundedz : is_bounded_by_bool z z_bs)
    : is_tighter_than_bool (constant (f x y z)) (eight_corners f x_bs y_bs z_bs).
  Proof.
    apply monotone_eight_corners_genb'; t_fill.
  Qed.

  Lemma monotoneb_eight_corners_and_zero_gen
        (f : Z -> Z -> Z -> Z)
        (Hmonotone1p : forall x y, Proper (Rp true ==> Z.le) (fun z => f x y (Zpos z)) \/ Proper (Rp false ==> Z.le) (fun z => f x y (Zpos z)))
        (Hmonotone1n : forall x y, Proper (Rp true ==> Z.le) (fun z => f x y (Zneg z)) \/ Proper (Rp false ==> Z.le) (fun z => f x y (Zneg z)))
        (Hmonotone2p : forall x z, Proper (Rp true ==> Z.le) (fun y => f x (Zpos y) z) \/ Proper (Rp false ==> Z.le) (fun y => f x (Zpos y) z))
        (Hmonotone2n : forall x z, Proper (Rp true ==> Z.le) (fun y => f x (Zneg y) z) \/ Proper (Rp false ==> Z.le) (fun y => f x (Zneg y) z))
        (Hmonotone3p : forall y z, Proper (Rp true ==> Z.le) (fun x => f (Zpos x) y z) \/ Proper (Rp false ==> Z.le) (fun x => f (Zpos x) y z))
        (Hmonotone3n : forall y z, Proper (Rp true ==> Z.le) (fun x => f (Zneg x) y z) \/ Proper (Rp false ==> Z.le) (fun x => f (Zneg x) y z))
        x x_bs y y_bs z z_bs
        (Hboundedx : is_bounded_by_bool x x_bs)
        (Hboundedy : is_bounded_by_bool y y_bs)
        (Hboundedz : is_bounded_by_bool z z_bs)
    : is_tighter_than_bool (constant (f x y z)) (eight_corners_and_zero f x_bs y_bs z_bs).
  Proof.
    apply monotone_eight_corners_and_zero_genb'; t_fill.
  Qed.
End ZRange.


From Cyclic_PA.Maths Require Import naturals.
From Cyclic_PA.Maths Require Import ordinals.

From Cyclic_PA.Logic Require Import definitions.
From Cyclic_PA.Logic Require Import fol.
From Cyclic_PA.Logic Require Import PA_omega.
From Cyclic_PA.Logic Require Import proof_trees.
From Cyclic_PA.Logic Require Import substitute.
From Cyclic_PA.Logic Require Import inverse_omega.

Require Import Lia.

Definition quantif_sub_formula
  (A E F : formula) (n : nat) (S : subst_ind) : formula :=
  formula_sub_ind A (neg (univ n E)) F S.

Lemma quantif_sub_formula_closed :
    forall (A : formula),
        closed A = true ->
            forall (E F : formula) (n : nat) (S : subst_ind), closed F = true ->
                closed (quantif_sub_formula A E F n S) = true.
Proof.
intros A CA E F n S CF.
unfold quantif_sub_formula.
apply (formula_sub_ind_closed _ _ _ CA).
intros CnuE.
apply CF.
Qed.

Definition weak_ord_up (P: ptree) (alpha : ord) :=
match ord_ltb (ptree_ord P) alpha with
| true => ord_up alpha P
| false => P
end.

Lemma weak_ord_formula :
    forall (P : ptree) (alpha : ord),
        ptree_formula (weak_ord_up P alpha) = ptree_formula P.
Proof.
intros P alpha.
unfold weak_ord_up.
case (ord_ltb (ptree_ord P) alpha);
unfold ptree_formula;
reflexivity.
Qed.

Lemma weak_ord_deg :
    forall (P : ptree) (alpha : ord),
        ptree_deg (weak_ord_up P alpha) = ptree_deg P.
Proof.
intros P alpha.
unfold weak_ord_up.
case (ord_ltb (ptree_ord P) alpha);
unfold ptree_deg;
reflexivity.
Qed.

Lemma weak_ord_valid :
    forall (P : ptree) (alpha : ord),
        nf alpha ->
            valid P ->
                valid (weak_ord_up P alpha).
Proof.
intros P alpha NO VP.
unfold weak_ord_up.
case (ord_ltb (ptree_ord P) alpha) eqn:IO.
- repeat split.
  + apply ord_ltb_lt in IO.
    apply IO.
  + apply VP.
  + apply NO.
- apply VP.
Qed.

Fixpoint quantif_sub_ptree_fit
  (P Q : ptree) (E F : formula) (n dQ : nat) (beta : ord) (QP : P_proves Q (lor F (univ n E)) dQ beta) (S : subst_ind) : ptree :=
  match P, S with
| deg_up d P', _ => match nat_ltb (ptree_deg (quantif_sub_ptree_fit P' Q E F n dQ beta QP S)) d with
    | true => deg_up d (quantif_sub_ptree_fit P' Q E F n dQ beta QP S)
    | false => (quantif_sub_ptree_fit P' Q E F n dQ beta QP S)
    end
| ord_up alpha P', _ => match ord_ltb (ptree_ord (quantif_sub_ptree_fit P' Q E F n dQ beta QP S)) alpha with
    | true => ord_up alpha (quantif_sub_ptree_fit P' Q E F n dQ beta QP S)
    | false => (quantif_sub_ptree_fit P' Q E F n dQ beta QP S)
    end

| node A, _ => P

| exchange_ab A B d alpha P', lor_ind S_B S_A =>
    exchange_ab
      (quantif_sub_formula A E F n S_A)
      (quantif_sub_formula B E F n S_B)
      (ptree_deg (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind S_A S_B)))
      (ptree_ord (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind S_A S_B)))
      (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind S_A S_B))

| exchange_cab C A B d alpha P', lor_ind (lor_ind S_C S_B) S_A =>
    exchange_cab
      (quantif_sub_formula C E F n S_C)
      (quantif_sub_formula A E F n S_A)
      (quantif_sub_formula B E F n S_B)
      (ptree_deg (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (lor_ind S_C S_A) S_B)))
      (ptree_ord (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (lor_ind S_C S_A) S_B)))
      (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (lor_ind S_C S_A) S_B))

| exchange_abd A B D d alpha P', lor_ind (lor_ind S_B S_A) S_D =>
    exchange_abd
      (quantif_sub_formula A E F n S_A)
      (quantif_sub_formula B E F n S_B)
      (quantif_sub_formula D E F n S_D)
      (ptree_deg (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (lor_ind S_A S_B) S_D)))
      (ptree_ord (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (lor_ind S_A S_B) S_D)))
      (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (lor_ind S_A S_B) S_D))

| exchange_cabd C A B D d alpha P', lor_ind (lor_ind (lor_ind S_C S_B) S_A) S_D =>
    exchange_cabd
      (quantif_sub_formula C E F n S_C)
      (quantif_sub_formula A E F n S_A)
      (quantif_sub_formula B E F n S_B)
      (quantif_sub_formula D E F n S_D)
      (ptree_deg (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (lor_ind (lor_ind S_C S_A) S_B) S_D)))
      (ptree_ord (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (lor_ind (lor_ind S_C S_A) S_B) S_D)))
      (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (lor_ind (lor_ind S_C S_A) S_B) S_D))

| contraction_a A d alpha P', _ =>
    contraction_a
      (quantif_sub_formula A E F n S)
      (ptree_deg (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind S S)))
      (ptree_ord (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind S S)))
      (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind S S))

| contraction_ad A D d alpha P', lor_ind S_A S_D =>
    contraction_ad
      (quantif_sub_formula A E F n S_A)
      (quantif_sub_formula D E F n S_D)
      (ptree_deg (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (lor_ind S_A S_A) S_D)))
      (ptree_ord (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (lor_ind S_A S_A) S_D)))
      (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (lor_ind S_A S_A) S_D))

| weakening_ad A D d alpha P', lor_ind S_A S_D =>
    weakening_ad
      (quantif_sub_formula A E F n S_A)
      (quantif_sub_formula D E F n S_D)
      (ptree_deg (quantif_sub_ptree_fit P' Q E F n dQ beta QP S_D))
      (ptree_ord (quantif_sub_ptree_fit P' Q E F n dQ beta QP S_D))
      (quantif_sub_ptree_fit P' Q E F n dQ beta QP S_D)

| demorgan_ab A B d1 d2 alpha1 alpha2 P1 P2, _ => P

| demorgan_abd A B D d1 d2 alpha1 alpha2 P1 P2, lor_ind S_AB S_D =>
    demorgan_abd
      A B
      (quantif_sub_formula D E F n S_D)
      (ptree_deg (quantif_sub_ptree_fit P1 Q E F n dQ beta QP (lor_ind (0) S_D)))
      (ptree_deg (quantif_sub_ptree_fit P2 Q E F n dQ beta QP (lor_ind (0) S_D)))
      (ptree_ord (quantif_sub_ptree_fit P1 Q E F n dQ beta QP (lor_ind (0) S_D)))
      (ptree_ord (quantif_sub_ptree_fit P2 Q E F n dQ beta QP (lor_ind (0) S_D)))
      (quantif_sub_ptree_fit P1 Q E F n dQ beta QP (lor_ind (0) S_D))
      (quantif_sub_ptree_fit P2 Q E F n dQ beta QP (lor_ind (0) S_D))

| negation_a A d alpha P', _ => P

| negation_ad A D d alpha P', lor_ind S_A S_D =>
    negation_ad
      A
      (quantif_sub_formula D E F n S_D)
      (ptree_deg (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (non_target A) S_D)))
      (ptree_ord (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (non_target A) S_D)))
      (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (non_target A) S_D))

| quantification_a A k t d alpha P', _ =>
    (match form_eqb A E, nat_eqb k n, S with
    | true, true, (1) => (cut_ca F (substitution E n (projT1 t)) (ptree_deg (w_rule_sub_ptree Q E n t (lor_ind (non_target F) (1)))) d beta alpha (w_rule_sub_ptree Q E n t (lor_ind (non_target F) (1))) P')
    | _, _, _ => P
    end)

| quantification_ad A D k t d alpha P', lor_ind S_A S_D =>
    (match form_eqb A E, nat_eqb k n, S_A with
    | true, true, (1) => (cut_cad F (substitution E n (projT1 t)) (quantif_sub_formula D E F n S_D)
                              (ptree_deg (w_rule_sub_ptree Q E n t (lor_ind (non_target F) (1))))
                              (ptree_deg (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (0) S_D)))
                              beta (ptree_ord (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (0) S_D)))
                              (w_rule_sub_ptree Q E n t (lor_ind (non_target F) (1)))) (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (0) S_D))
    | _, _, _ => quantification_ad
                    A (quantif_sub_formula D E F n S_D) k t
                    (ptree_deg (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (0) S_D)))
                    (ptree_ord (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (0) S_D)))
                    (quantif_sub_ptree_fit P' Q E F n dQ beta QP (lor_ind (0) S_D))
    end)

| w_rule_a A k d alpha g, _ => P

| w_rule_ad A D k d alpha g, lor_ind S_A S_D =>
    w_rule_ad
          A (quantif_sub_formula D E F n S_D) k
          (Nat.max (Nat.max dQ d) (num_conn E + 1))
          (ord_add beta alpha)
          (fun (c : c_term) =>
            (weak_ord_up (quantif_sub_ptree_fit (g c) Q E F n dQ beta QP (lor_ind (non_target A) S_D)) (ord_add beta alpha)))

| cut_ca C A d1 d2 alpha1 alpha2 P1 P2, _ =>
    cut_ca
      (quantif_sub_formula C E F n S) A
      (ptree_deg (quantif_sub_ptree_fit P1 Q E F n dQ beta QP (lor_ind S (non_target A)))) d2
      (ptree_ord (quantif_sub_ptree_fit P1 Q E F n dQ beta QP (lor_ind S (non_target A)))) alpha2
      (quantif_sub_ptree_fit P1 Q E F n dQ beta QP (lor_ind S (non_target A)))  P2

| cut_ad A D d1 d2 alpha1 alpha2 P1 P2, _ =>
    cut_ad
      A (quantif_sub_formula D E F n S)
      d1 (ptree_deg (quantif_sub_ptree_fit P2 Q E F n dQ beta QP (lor_ind (0) S)))
      alpha1 (ptree_ord (quantif_sub_ptree_fit P2 Q E F n dQ beta QP (lor_ind (0) S)))
      P1   (quantif_sub_ptree_fit P2 Q E F n dQ beta QP (lor_ind (0) S))

| cut_cad C A D d1 d2 alpha1 alpha2 P1 P2, lor_ind S_C S_D =>
    cut_cad
      (quantif_sub_formula C E F n S_C) A (quantif_sub_formula D E F n S_D)
      (ptree_deg (quantif_sub_ptree_fit P1 Q E F n dQ beta QP (lor_ind S_C (non_target A))))
      (ptree_deg (quantif_sub_ptree_fit P2 Q E F n dQ beta QP (lor_ind (0) S_D)))
      (ptree_ord (quantif_sub_ptree_fit P1 Q E F n dQ beta QP (lor_ind S_C (non_target A))))
      (ptree_ord (quantif_sub_ptree_fit P2 Q E F n dQ beta QP (lor_ind (0) S_D)))
      (quantif_sub_ptree_fit P1 Q E F n dQ beta QP (lor_ind S_C (non_target A)))
      (quantif_sub_ptree_fit P2 Q E F n dQ beta QP (lor_ind (0) S_D))

| _, _ => P
end.

Definition quantif_sub_ptree
  (P Q : ptree) (E F : formula) (n dQ : nat) (beta : ord) (QP : P_proves Q (lor F (univ n E)) dQ beta) (S : subst_ind) : ptree :=
match subst_ind_fit (ptree_formula P) S with
| false => P
| true => quantif_sub_ptree_fit P Q E F n dQ beta QP S
end.

Lemma quantif_ptree_formula_true :
    forall (P Q : ptree) (E F : formula) (n dQ : nat) (beta : ord) (QP : P_proves Q (lor F (univ n E)) dQ beta) (S : subst_ind),
        subst_ind_fit (ptree_formula P) S = true ->
            quantif_sub_ptree_fit P Q E F n dQ beta QP S = quantif_sub_ptree P Q E F n dQ beta QP S.
Proof.
intros P Q E F n dQ beta QP S FS.
unfold quantif_sub_ptree.
rewrite FS.
reflexivity.
Qed.

Lemma quantif_ptree_formula' :
    forall (P Q : ptree) (E F : formula) (n dQ : nat) (beta : ord) (QP : P_proves Q (lor F (univ n E)) dQ beta),
        valid P ->
            forall (S : subst_ind),
                subst_ind_fit (ptree_formula P) S = true ->
                    ptree_formula (quantif_sub_ptree P Q E F n dQ beta QP S) =
                        quantif_sub_formula (ptree_formula P) E F n S.
Proof.
intros P Q E F n dQ beta QP PV.
induction P; try intros S FS;
unfold quantif_sub_ptree;
rewrite FS;
unfold ptree_formula in *; fold ptree_formula in *;
unfold quantif_sub_ptree_fit; fold quantif_sub_ptree_fit.

1 : destruct PV as [ID PV];
    case (nat_ltb (ptree_deg (quantif_sub_ptree_fit P Q E F n dQ beta QP S)) n0) eqn:IE.
3 : destruct PV as [[IO PV] NO];
    case (ord_ltb (ptree_ord (quantif_sub_ptree_fit P Q E F n dQ beta QP S)) o) eqn:IE.

1-4 : rewrite (quantif_ptree_formula_true _ _ _ _ _ _ _ _ _ FS);
      unfold ptree_formula; fold ptree_formula;
      apply (IHP PV _ FS).

1 : { inversion PV as [PX].
      unfold quantif_sub_ptree, quantif_sub_formula, formula_sub_ind.
      rewrite FS.
      unfold ptree_formula; fold ptree_formula.
      destruct (axiom_atomic _ PX) as [[a fa] | [a fa]];
      rewrite fa;
      unfold formula_sub_ind_fit; fold formula_sub_ind_fit;
      unfold form_eqb;
      reflexivity. }

all : destruct S; inversion FS as [FS'];
      try reflexivity.

1,5,6,13 :  apply and_bool_prop in FS';
            destruct FS' as [FS1 FS2];
            unfold ptree_formula, quantif_sub_formula, formula_sub_ind, formula_sub_ind_fit;
            fold formula_sub_ind_fit;
            rewrite FS,FS1,FS2;
            reflexivity.

6,7 : case (form_eqb f E) eqn:EQ1;
      case (nat_eqb n0 n) eqn:EQ2;
      unfold ptree_formula, quantif_sub_formula, formula_sub_ind, subst_ind_fit, formula_sub_ind_fit, form_eqb;
      fold form_eqb;
      rewrite EQ1,EQ2;
      reflexivity.

all : destruct S1; inversion FS' as [FS''].

1-3 : apply and_bool_prop in FS';
      destruct FS' as [FS1 FS2];
      apply and_bool_prop in FS1;
      destruct FS1 as [FS1_1 FS1_2].

3 : destruct S1_1; inversion FS'' as [FS'''];
    apply and_bool_prop in FS1_1;
    destruct FS1_1 as [FS1_1_1 FS1_1_2].

8,9 : case (form_eqb f E) eqn:EQ1;
      case (nat_eqb n0 n) eqn:EQ2.

all : unfold ptree_formula, quantif_sub_formula, formula_sub_ind, formula_sub_ind_fit, form_eqb;
      fold ptree_formula form_eqb formula_sub_ind_fit;
      try rewrite FS;
      try rewrite FS'';
      try rewrite EQ1;
      try rewrite EQ2;
      try rewrite FS1_1,FS1_2,FS2;
      try rewrite FS1_1_1,FS1_1_2,FS1_2,FS2;
      reflexivity.
Qed.

Lemma quantif_ptree_formula :
    forall (P Q : ptree) (E F : formula) (n dQ : nat) (beta : ord) (QP : P_proves Q (lor F (univ n E)) dQ beta),
        valid P ->
            forall (S : subst_ind),
                ptree_formula (quantif_sub_ptree P Q E F n dQ beta QP S) =
                    quantif_sub_formula (ptree_formula P) E F n S.
Proof.
intros P Q E F n dQ beta QP VP S.
destruct (subst_ind_fit (ptree_formula P) S) eqn:FS.
- apply quantif_ptree_formula'.
  apply VP.
  apply FS.
- unfold quantif_sub_ptree, quantif_sub_formula, formula_sub_ind.
  rewrite FS.
  reflexivity.
Qed.

Lemma quantif_ptree_deg :
    forall (P Q : ptree) (E F : formula) (n dQ : nat) (beta : ord) (QP : P_proves Q (lor F (univ n E)) dQ beta),
        valid P ->
            Nat.max dQ (ptree_deg P) < (num_conn E + 2) ->
                forall (S : subst_ind),
                    ptree_deg (quantif_sub_ptree P Q E F n dQ beta QP S) <= (Nat.max (Nat.max dQ (ptree_deg P)) (num_conn E + 1)).
Proof.
intros P Q E F n dQ beta QP PV IE.
inversion QP as [[[QF QV] QD] QO].
pose (ptree_formula P) as A.
induction P; intros S;
unfold quantif_sub_ptree;
case (subst_ind_fit A S) eqn:FS;
unfold A in FS;
try rewrite FS;
unfold quantif_sub_ptree_fit; fold quantif_sub_ptree_fit;
unfold ptree_deg in *; fold ptree_deg in *;
try lia.

1 : destruct PV as [ID PV].
2 : destruct PV as [[IO PV] NO].
3-8 : destruct PV as [[[PF PV] PD] PO].
9 : destruct PV as [[[[PF FC] PV] PD] PO].
11-13 : destruct PV as [[[PF PV] PD] PO].
10,15,16,17: destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

1 : { unfold ptree_formula in FS; fold ptree_formula in FS.
      case (nat_ltb (ptree_deg (quantif_sub_ptree_fit P Q E F n dQ beta QP S)) n0) eqn:EQ.
      - unfold ptree_deg. lia.
      - rewrite (quantif_ptree_formula_true _ _ _ _ _ _ _ _ _ FS).
        assert (Nat.max dQ (ptree_deg P) < num_conn E + 2) as IE1.
        { lia. }
        pose proof (IHP PV IE1 S);
        try lia. }

1 : { unfold ptree_formula in FS; fold ptree_formula in FS.
      case (ord_ltb (ptree_ord (quantif_sub_ptree_fit P Q E F n dQ beta QP S)) o) eqn:EQ;
      unfold ptree_deg; fold ptree_deg;
      rewrite (quantif_ptree_formula_true _ _ _ _ _ _ _ _ _ FS);
      pose proof (IHP PV IE S);
      try lia. }

5 : rewrite quantif_ptree_formula_true;
    rewrite <- PD in IHP;
    pose proof (IHP PV IE (lor_ind S S));
    try lia.

9 : rewrite quantif_ptree_formula_true;
    rewrite <- P1D in IHP1;
    pose proof (IHP1 P1V (nat_lt_max_shuffle_l _ _ _ _ _ IE) (lor_ind S (non_target f0)));
    try lia.

10 :  rewrite quantif_ptree_formula_true;
      rewrite <- P2D in IHP2;
      pose proof (IHP2 P2V (nat_lt_max_shuffle_r _ _ _ _ _ IE) (lor_ind (0) S));
      try lia.

5,9,10 :  try rewrite PF;
          try rewrite P1F;
          try rewrite P2F;
          unfold subst_ind_fit, ptree_formula in *; fold subst_ind_fit ptree_formula in *;
          try rewrite FS;
          try rewrite non_target_fit;
          reflexivity.

all : destruct S; inversion FS as [FS'];
      try destruct (and_bool_prop _ _ FS') as [FS1 FS2];
      try reflexivity.

10-12 : case (form_eqb f E) eqn:EQ1;
        case (nat_eqb n0 n) eqn:EQ2;
        unfold ptree_deg; fold ptree_deg;
        try lia;
        try rewrite (w_rule_ptree_deg _ _ _ _ QV);
        try destruct S1; inversion FS' as [FS''];
        unfold ptree_deg; fold ptree_deg;
        try rewrite quantif_ptree_formula_true;
        rewrite <- PD in IHP;
        try pose proof (IHP PV IE (lor_ind (0) S2));
        try lia;
        try rewrite PF;
        unfold subst_ind_fit; fold subst_ind_fit;
        try apply FS';
        destruct QP; repeat destruct p;
        unfold projT1;
        unfold ptree_deg; fold ptree_deg;
        unfold num_conn; fold num_conn;
        rewrite num_conn_sub;
        try lia.

2,3,4,7,9 : destruct S1; inversion FS' as [FS''];
            try destruct (and_bool_prop _ _ FS1) as [FS1_1 FS1_2].

4 : destruct S1_1; inversion FS'' as [FS'''];
    try destruct (and_bool_prop _ _ FS1_1) as [FS1_1_1 FS1_1_2].

all : unfold ptree_deg; fold ptree_deg;
      try rewrite <- PD in IHP;
      try rewrite <- P1D in IHP1;
      try rewrite <- P2D in IHP2;
      try pose proof (IHP PV IE (lor_ind S2 S1));
      try pose proof (IHP PV IE (lor_ind (lor_ind S1_1 S2) S1_2));
      try pose proof (IHP PV IE (lor_ind (lor_ind S1_2 S1_1) S2));
      try pose proof (IHP PV IE (lor_ind (lor_ind (lor_ind S1_1_1 S1_2) S1_1_2) S2));
      try pose proof (IHP1 P1V (nat_lt_max_max_l _ _ _ _ IE) (lor_ind (0) S2));
      try pose proof (IHP2 P2V (nat_lt_max_max_r _ _ _ _ IE) (lor_ind (0) S2));
      try pose proof (IHP PV IE (lor_ind (non_target f) S2));
      try pose proof (IHP PV IE (lor_ind (lor_ind S1 S1) S2));
      try pose proof (IHP PV IE (S2));
      try pose proof (IHP1 P1V (nat_lt_max_shuffle_l _ _ _ _ _ IE) (lor_ind S1 (non_target f0)));
      try pose proof (IHP2 P2V (nat_lt_max_shuffle_r _ _ _ _ _ IE) (lor_ind (0) S2));
      repeat rewrite quantif_ptree_formula_true;
      try rewrite PF;
      try rewrite P1F;
      try rewrite P2F;
      try lia;
      unfold subst_ind_fit; fold subst_ind_fit;
      try rewrite non_target_fit;
      try rewrite FS;
      try rewrite FS'';
      try rewrite FS1;
      try rewrite FS2;
      try rewrite FS1_1;
      try rewrite FS1_2;
      try rewrite FS1_1_1;
      try rewrite FS1_1_2;
      reflexivity.
Qed.

Lemma quantif_ptree_ord :
    forall (P Q : ptree) (E F : formula) (n dQ : nat) (beta : ord) (QP : P_proves Q (lor F (univ n E)) dQ beta),
        valid P ->
            forall (S : subst_ind),
                ord_ltb (ord_add beta (ptree_ord P)) (ptree_ord (quantif_sub_ptree P Q E F n dQ beta QP S)) = false.
Proof.
intros P Q E F n dQ beta QP PV.
inversion QP as [[[QF QV] QD] QO].
pose (ptree_formula P) as A.
induction P; intros S;
unfold quantif_sub_ptree;
case (subst_ind_fit A S) eqn:FS;
unfold A in FS;
try rewrite FS;
unfold quantif_sub_ptree_fit; fold quantif_sub_ptree_fit;
unfold ptree_ord in *; fold ptree_ord in *;
try apply add_left_non_decr.

1 : destruct PV as [ID PV].
2 : destruct PV as [[IO PV] NO].
3-8 : destruct PV as [[[PF PV] PD] PO].
9 : destruct PV as [[[[PF FC] PV] PD] PO].
11-13 : destruct PV as [[[PF PV] PD] PO].
10,15,16,17: destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

1 : { unfold ptree_formula in FS; fold ptree_formula in FS.
      case (nat_ltb (ptree_deg (quantif_sub_ptree_fit P Q E F n dQ beta QP S)) n0) eqn:EQ;
      rewrite (quantif_ptree_formula_true _ _ _ _ _ _ _ _ _ FS);
      unfold ptree_ord; fold ptree_ord;
      apply (IHP PV). }

1 : { unfold ptree_formula in FS; fold ptree_formula in FS.
      case (ord_ltb (ptree_ord (quantif_sub_ptree_fit P Q E F n dQ beta QP S)) o) eqn:EQ;
      unfold ptree_ord; fold ptree_ord.
      - apply add_left_non_decr.
      - rewrite (quantif_ptree_formula_true _ _ _ _ _ _ _ _ _ FS).
        apply (ord_geb_trans _ (ord_add beta (ptree_ord P))).
        + apply ord_ltb_asymm.
          apply ord_lt_ltb.
          apply add_right_incr.
          apply IO.
        + apply (IHP PV). }

5 : rewrite quantif_ptree_formula_true;
    rewrite <- PO in IHP;
    try apply (IHP PV).

9,10 :  rewrite quantif_ptree_formula_true;
        rewrite <- P1O in IHP1;
        rewrite <- P2O in IHP2;
        pose (IHP1 P1V (lor_ind S (non_target f0))) as IHnP1;
        pose (IHP2 P2V (lor_ind (0) S)) as IHnP2;
        try rewrite (ord_succ_add_succ _ _ (ptree_ord_nf_hyp _ _ QO QV) (nf_nf_succ _ (nf_ord_max _ _ (ptree_ord_nf_hyp _ _ P1O P1V) (ptree_ord_nf_hyp _ _ P2O P2V))));
        try rewrite (ord_succ_add_succ _ _ (ptree_ord_nf_hyp _ _ QO QV) (nf_ord_max _ _ (ptree_ord_nf_hyp _ _ P1O P1V) (ptree_ord_nf_hyp _ _ P2O P2V)));
        try rewrite ord_max_add_comm;
        repeat apply ord_geb_succ;
        try apply (ord_max_geb_split _ _ _ _ IHnP1 (add_left_non_decr _ _));
        try apply (ord_max_geb_split _ _ _ _ (add_left_non_decr _ _) IHnP2).

5,9,10 :  try rewrite PF;
          try rewrite P1F;
          try rewrite P2F;
          unfold subst_ind_fit, ptree_formula in *; fold subst_ind_fit ptree_formula in *;
          try rewrite FS;
          try rewrite non_target_fit;
          reflexivity.

all : destruct S; inversion FS as [FS'];
      try destruct (and_bool_prop _ _ FS') as [FS1 FS2];
      unfold ptree_ord; fold ptree_ord.

13 : { destruct (PV czero) as [[[PF PcV] PD] PO].
       rewrite (ord_succ_add_succ _ _ (ptree_ord_nf_hyp _ _ QO QV) (ptree_ord_nf_hyp _ _ PO PcV)).
       apply ord_ltb_irrefl. }

10-12 : case (form_eqb f E) eqn:EQ1;
        case (nat_eqb n0 n) eqn:EQ2;
        unfold ptree_ord; fold ptree_ord;
        try apply add_left_non_decr.

10 :  { rewrite (ord_succ_add_succ _ _ (ptree_ord_nf_hyp _ _ QO QV) (ptree_ord_nf_hyp _ _ PO PV)).
        apply ord_geb_succ.
        apply (ord_max_le_add _ _ (ptree_ord_nf_hyp _ _ QO QV) (ptree_ord_nf_hyp _ _ PO PV)). }

2,3,4,10 :  destruct S1; inversion FS' as [FS''];
            try destruct (and_bool_prop _ _ FS1) as [FS1_1 FS1_2].

4 : destruct S1_1; inversion FS'' as [FS'''];
    try destruct (and_bool_prop _ _ FS1_1) as [FS1_1_1 FS1_1_2].

all : unfold ptree_ord; fold ptree_ord;
      try rewrite <- PO in IHP;
      try rewrite <- P1O in IHP1;
      try rewrite <- P2O in IHP2;
      repeat rewrite quantif_ptree_formula_true;
      try rewrite (ord_succ_add_succ _ _ (ptree_ord_nf_hyp _ _ QO QV) (ptree_ord_nf_hyp _ _ PO PV));
      try rewrite (ord_succ_add_succ _ _ (ptree_ord_nf_hyp _ _ QO QV) (nf_ord_max _ _ (ptree_ord_nf_hyp _ _ P1O P1V) (ptree_ord_nf_hyp _ _ P2O P2V)));
      try rewrite ord_max_add_comm;
      repeat apply ord_geb_succ;
      try apply ord_max_geb_split;
      try apply (IHP PV);
      try apply (IHP1 P1V);
      try apply (IHP2 P2V);
      try rewrite PF;
      try rewrite P1F;
      try rewrite P2F;
      unfold subst_ind_fit; fold subst_ind_fit;
      try rewrite non_target_fit;
      try rewrite FS;
      try rewrite FS'';
      try rewrite FS1;
      try rewrite FS2;
      try rewrite FS1_1;
      try rewrite FS1_2;
      try rewrite FS1_1_1;
      try rewrite FS1_1_2;
      try reflexivity.

1 : { rewrite (ord_max_self (ord_add beta o)).
      apply ord_max_geb_split.
      apply add_right_non_decr.
      apply (IHP PV). }
Qed.

Lemma quantif_valid :
    forall (P Q : ptree) (E F : formula) (n dQ : nat) (beta : ord) (QP : P_proves Q (lor F (univ n E)) dQ beta),
        valid P ->
            closed F = true ->
                Nat.max dQ (ptree_deg P) < (num_conn E + 2) ->
                    forall (S : subst_ind),
                        subst_ind_fit (ptree_formula P) S = true ->
                            valid (quantif_sub_ptree P Q E F n dQ beta QP S).
Proof.
intros P Q E F n dQ beta QP PV CF IE.
inversion QP as [[[QF QV] QD] QO].
pose (ptree_formula P) as A.
induction P; intros S FS;
unfold quantif_sub_ptree;
rewrite FS;
unfold quantif_sub_ptree_fit; fold quantif_sub_ptree_fit;
unfold ptree_formula in *; fold ptree_formula in *;
try apply PV.

1 : destruct PV as [ID PV].
2 : destruct PV as [[IO PV] NO].
3-8 : destruct PV as [[[PF PV] PD] PO].
9 : destruct PV as [[[[PF FC] PV] PD] PO].
11-13 : destruct PV as [[[PF PV] PD] PO].
10,15,16,17: destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

1 : { unfold ptree_formula in FS; fold ptree_formula in FS.
      unfold ptree_deg in IE.
      rewrite (quantif_ptree_formula_true _ _ _ _ _ _ _ _ _ FS).
      case (nat_ltb (ptree_deg (quantif_sub_ptree P Q E F n dQ beta QP S)) n0) eqn:EQ.
      split.
      1 : { apply nat_ltb_lt. apply EQ. }
      all : refine (IHP PV _ _ FS);
            lia. }

1 : { unfold ptree_formula in FS; fold ptree_formula in FS.
      rewrite (quantif_ptree_formula_true _ _ _ _ _ _ _ _ _ FS).
      case (ord_ltb (ptree_ord (quantif_sub_ptree P Q E F n dQ beta QP S)) o) eqn:EQ;
      unfold ptree_ord; fold ptree_ord.
      split. split.
      3 : apply NO.
      1 : apply ord_ltb_lt. apply EQ.
      all : refine (IHP PV IE _ FS). }

1-4,6-8,11-15 : destruct S; inversion FS as [FS'];
                try destruct (and_bool_prop _ _ FS') as [FS1 FS2].

2-4,12 :  destruct S1; inversion FS' as [FS''];
          try destruct (and_bool_prop _ _ FS1) as [FS1_1 FS1_2].

4 : destruct S1_1; inversion FS'' as [FS'''];
    try destruct (and_bool_prop _ _ FS1_1) as [FS1_1_1 FS1_1_2].

14 :  { repeat split;
        try rewrite weak_ord_formula;
        try rewrite weak_ord_deg;
        try apply weak_ord_valid;
        destruct (PV t) as [[[PF PcV] PD] PO];
        try apply (nf_add _ _ (ptree_ord_nf_hyp _ _ QO QV) (ptree_ord_nf_hyp _ _ PO PcV));
        rewrite quantif_ptree_formula_true;
        try rewrite PF;
        unfold subst_ind_fit;fold subst_ind_fit;
        try rewrite non_target_sub_fit;
        try rewrite FS2;
        try reflexivity;
        fold valid in *.
        - rewrite (quantif_ptree_formula _ _ _ _ _ _ _ _ PcV).
          rewrite PF.
          unfold quantif_sub_formula.
          rewrite (non_target_term_sub _ n0 (projT1 t)).
          rewrite non_target_sub_lor.
          reflexivity.

        - assert (Nat.max dQ (ptree_deg (p t)) < num_conn E + 2) as IE1.
          { unfold ptree_deg in IE. lia. }
          apply (X _ PcV IE1).
          rewrite PF.
          unfold subst_ind_fit; fold subst_ind_fit.
          rewrite non_target_sub_fit.
          apply FS2.

        - assert (Nat.max dQ (ptree_deg (p t)) < num_conn E + 2) as IE1.
          { unfold ptree_deg in IE. lia. }
          pose proof (quantif_ptree_deg _ _ _ _ _ _ _ QP PcV IE1 (lor_ind (non_target f) S2)) as IE2.
          lia.

        - unfold weak_ord_up.
          destruct (ord_semiconnex_bool (ptree_ord (quantif_sub_ptree (p t) Q E F n dQ beta QP (lor_ind (non_target f) S2))) (ord_add beta o)) as [OLT | [OGT | OEQ]].

          + rewrite OLT.
            unfold ptree_ord.
            reflexivity.

          + rewrite PO in OGT.
            rewrite quantif_ptree_ord in OGT.
            inversion OGT.
            apply PcV.

          + apply ord_eqb_eq in OEQ.
            destruct OEQ.
            rewrite ord_ltb_irrefl.
            reflexivity. }

5,6,12,13 : case (form_eqb f E) eqn:EQ1;
            case (nat_eqb n0 n) eqn:EQ2.

all : repeat rewrite quantif_ptree_formula_true;
      try apply form_eqb_eq in EQ1;
      try apply nat_eqb_eq in EQ2;
      try destruct EQ1;
      try destruct EQ2;
      repeat split;
      try rewrite (w_rule_ptree_formula _ _ _ _ QV);
      try rewrite (w_rule_ptree_ord _ _ _ _ QV);
      try rewrite (quantif_ptree_formula _ _ _ _ _ _ _ _ PV);
      try rewrite (quantif_ptree_formula _ _ _ _ _ _ _ _ P1V);
      try rewrite (quantif_ptree_formula _ _ _ _ _ _ _ _ P2V);
      try rewrite QF;
      try rewrite PF;
      try rewrite P1F;
      try rewrite P2F;
      unfold w_rule_sub_formula;
      unfold quantif_sub_formula;
      try apply non_target_sub_lor;
      repeat rewrite formula_sub_ind_lor;
      try rewrite non_target_sub;
      try apply (w_rule_valid _ _ _ _ QV);
      try rewrite (quantif_ptree_formula _ _ _ _ _ _ _ _ PV);
      try apply IHP;
      try apply IHP1;
      try apply IHP2;
      try apply PV;
      try apply P1V;
      try apply P2V;
      try unfold ptree_deg in IE;
      try lia;
      try rewrite QF;
      try rewrite PF;
      try rewrite P1F;
      try rewrite P2F;
      unfold subst_ind_fit;
      fold subst_ind_fit;
      try rewrite non_target_fit;
      try rewrite FS;
      try rewrite FS1;
      try rewrite FS1_1;
      try rewrite FS1_2;
      try rewrite FS1_1_1;
      try rewrite FS1_1_2;
      try rewrite FS2;
      try apply QO;
      try apply PO;
      try apply P1O;
      try apply P2O;
      unfold formula_sub_ind, formula_sub_ind_fit, subst_ind_fit;
      fold formula_sub_ind_fit subst_ind_fit;
      try rewrite form_eqb_refl;
      try rewrite FS1;
      try reflexivity.

1 : { rewrite <- (sub_fit_true _ _ _ _ FS1).
      apply formula_sub_ind_closed.
      apply FC.
      intros CnuE.
      apply CF. }
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e450m2e225m1_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e450m2e225m1_20limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Inductive nat_btree : Set :=
| NLeaf : nat_btree
| NNode : nat_btree -> nat -> nat_btree -> nat_btree.

Theorem discriminate : forall nt1 n nt2,
  NLeaf <> NNode nt1 n nt2.
Proof.
  intros. intros H. inversion H.
Qed.

Theorem injectivity : forall nt1 nt2 nt3 nt4 n m,
  NNode nt1 n nt2 = NNode nt3 m nt4 -> n = m.
Proof.
  intros. inversion H. reflexivity.
Qed.


(* Some things about orthogonal factorization systems. *)

Require Import HoTT.
(* This redundant line is so that we pick up the intended [factor1] and [factor2]. If Sets/Ordinals.v is changed, we can remove the next line. *)
Require Import HoTT.Factorization.

Definition isequiv_in_left_and_right (F : FactorizationSystem)
           {X Y : Type} (f : X -> Y)
           (left : class1 F f) (right : class2 F f)
  : IsEquiv f.
Proof.
  transparent assert (fact1 : (Factorization (@class1 F) (@class2 F) f)).
  { snrapply (Build_Factorization Y f equiv_idmap).
    - reflexivity.
    - assumption.
    - rapply class2_isequiv. }
  transparent assert (fact2 : (Factorization (@class1 F) (@class2 F) f)).
  { snrapply (Build_Factorization X equiv_idmap f).
    - reflexivity.
    - rapply class1_isequiv.
    - assumption. }
  pose (PF := path_factor F f fact1 fact2).
  destruct PF.
  cbn in *.
  srapply isequiv_adjointify.
  - exact path_intermediate.
  - symmetry; exact path_factor2.
  - exact path_factor1.
Defined.
(* Note that we didn't use that path_intermediate is an equivalence. *)

(** The hypotheses are almost the same as a PathFactorization between fact and fact'.  The main difference is that we do not assume that path_intermediate is an equivalence.  We also don't need [path_fact_factors]. *)
Definition isequiv_path_factorization `{Univalence} (F : FactorizationSystem)
           {X Y : Type} (f : X -> Y)
           (fact fact' : Factorization (@class1 F) (@class2 F) f)
           (path_intermediate : intermediate fact -> intermediate fact')
           (path_factor1 : path_intermediate o factor1 fact == factor1 fact')
           (path_factor2 : factor2 fact == factor2 fact' o path_intermediate)
  : IsEquiv path_intermediate.
Proof.
  nrapply (isequiv_in_left_and_right F).
  - snrapply (cancelR_class1 _ (factor1 fact)).
    + apply inclass1.
    + refine (transport (fun g => class1 F g) (path_forall _ _ path_factor1)^ _).
      apply inclass1.
  - snrapply (cancelL_class2 _ _ (factor2 fact')).
    + apply inclass2.
    + refine (transport (fun g => class2 F g) (path_forall _ _ path_factor2) _).
      apply inclass2.
Defined.

(* u u0 u1 u2 u3 |= u0 <= u < {u1,u2} <= u3.  E.g. i i j j j. *)
Definition homotopic_filler_idmap `{Univalence} (F : FactorizationSystem)
           {X Y : Type} (f : X -> Y)
           (fact : Factorization (@class1 F) (@class2 F) f)
           (path_intermediate' : intermediate fact -> intermediate fact)
           (path_factor1' : path_intermediate' o factor1 fact == factor1 fact)
           (path_factor2' : factor2 fact == factor2 fact o path_intermediate')
           (path_fact_factors' : forall a, path_factor2' (factor1 fact a)
                                                    @ ap (factor2 fact) (path_factor1' a)
                                                    @ fact_factors fact a
                                      = fact_factors fact a)
  : path_intermediate' == idmap.
Proof.
  apply ap10.
  transparent assert (eq : (intermediate fact <~> intermediate fact)).
  { snrapply (Build_Equiv _ _ path_intermediate').
    apply isequiv_path_factorization; assumption. }
  transparent assert (PF : (PathFactorization fact fact)).
  { snrapply (Build_PathFactorization _ _ eq); assumption. }
  transparent assert (PF' : (PathFactorization fact fact)).
  { snrapply (Build_PathFactorization _ _ equiv_idmap).
    1, 2: reflexivity.
    intro a. apply concat_1p. }
  nrefine (@ap _ _ equiv_fun eq equiv_idmap _).
  nrefine (@ap _ _ path_intermediate PF PF' _).
  nrapply path_contr.
  nrefine (contr_equiv' _ _).
  1: exact (equiv_path_factorization fact fact)^-1%equiv.
  nrapply contr_paths_contr.
  exact (contr_factor F f).
Defined.


(* Copyright (c)  Inria. All rights reserved. *)
Require Import Reals  Psatz.
From Flocq Require Import Core Plus_error Relative Sterbenz Operations.
Require Import F2SumFLT.

Require Import mathcomp.ssreflect.ssreflect.

Set Implicit Arguments.

Section Fast2Sum.
Variable beta: radix.
Local Notation pow e := (bpow beta e).
Local Open Scope Z_scope.

Variables p  : Z.
Hypothesis Hp : Z.lt 1 p.

Local Instance p_gt_0 : Prec_gt_0 p.
Proof. by apply:(Z.lt_trans _ 1). Qed.

Local Notation fexp := (FLX_exp p).
Local Notation format := (generic_format beta fexp).
Local Notation ce := (cexp beta fexp).
Local Notation mant := (scaled_mantissa beta fexp).

Variable choice : Z -> bool.

Local Notation rnd_p := (round beta fexp (Znearest choice)).
Hypothesis rnd_p_sym : forall x, (rnd_p (-x) = - rnd_p (x))%R.

Theorem cexp_bpow  x e (xne0: x <> R0):  ce (x * pow e) = ce x + e.
Proof. rewrite /ce mag_mult_bpow // /FLX_exp; ring. Qed.

Theorem mant_bpow x e : mant (x * pow e) = mant x.
Proof.
case: (Req_dec x 0) => [->|Zx]; first by rewrite Rmult_0_l.
rewrite /scaled_mantissa cexp_bpow // Rmult_assoc -bpow_plus.
by ring_simplify (e + - (ce x + e)).
Qed.

Theorem round_bpow  x e:  rnd_p (x * pow e) = (rnd_p x * pow e)%R.
Proof.
case: (Req_dec x 0) => [->|Zx] ; first by rewrite Rmult_0_l round_0 Rmult_0_l.
by rewrite /round /F2R /= mant_bpow  cexp_bpow // bpow_plus Rmult_assoc.
Qed.

(* (* to move .... MoreFLXFlocq *) *)

(* cf FLX_format *)
Theorem FLX_mant_le  x (Fx: format x): Z.abs (Ztrunc (mant x)) <= beta^p - 1.
Proof.
suff :  (Z.abs (Ztrunc (mant x)) < beta ^ p)%Z by lia.
apply: lt_IZR; rewrite abs_IZR - scaled_mantissa_generic //.
rewrite IZR_Zpower; last lia.
have ->:  pow p = pow (mag beta x - ce x) by rewrite /ce /fexp; congr bpow; ring.
exact : scaled_mantissa_lt_bpow.
Qed.

Definition pair_opp (p: R*R):= ((-(fst p))%R, (- (snd p))%R).

Section F2Sum.

Variables a b   : R.
Hypothesis Fa : format a.
Hypothesis Fb : format b.
Notation  s := (rnd_p (a + b)).
Notation  z := (rnd_p (s - a)).
Notation t := (rnd_p (b - z)).
Hypothesis Hb3 : beta <= 3.

Variable fa : float beta.
Hypothesis exp_le:  (a = F2R fa) /\ (ce b  <= Fexp fa).

Notation ubemin x := ( mag beta  x - p)%Z.

Fact Rle_pmabs emin x:  (emin <= ubemin x)%Z -> x <> 0%R ->  (pow (emin + p - 1) <= Rabs x)%R.
Proof.
move=> hemin xn0.
apply:(Rle_trans _ (pow  ((mag beta x) - 1))).
  apply:bpow_le; lia.
by apply: bpow_mag_le.
Qed.

Definition  emin :=  (Z.min (ubemin a)
                           (Z.min (ubemin b)
                           (Z.min (ubemin s)
                           (Z.min (ubemin (a + b))
                           (Z.min  (ubemin z)
                           (Z.min (ubemin (s - a))
                           (Z.min (ubemin (b - z))(ubemin t)))))))).

Fact getnum_fa:  exists  (fa : float beta),
                 (a = F2R fa) /\  (Z.abs (Fnum fa) <= beta^p - 1)
                /\ (ce b  <= Fexp fa).
Proof.
case:exp_le => h1 h2.
case:(Z_lt_le_dec  ( ce a ) (ce b))=> h;  last first.
  rewrite Fa.
  set f'a := (Float beta _ _).
  exists f'a; split=>//; rewrite /fa /=; split =>//.
  by apply:FLX_mant_le.
exists fa; split=>//; split =>//.
move:h1; rewrite  Fa /F2R /=.
have -> : (Fexp fa) = ((Fexp fa) - (ce a)) + ce a by ring.
rewrite bpow_plus -Rmult_assoc.
move/Rmult_eq_reg_r.
have hh: pow (ce a) <> 0%R by move:(bpow_gt_0 beta (ce a)); lra.
move/(_ hh)=> h1.
apply:(Z.le_trans _ (Z.abs (Ztrunc (mant a)))); last by apply:FLX_mant_le.
apply:le_IZR.
rewrite !abs_IZR  h1 Rabs_mult // -[X in (X <= _)%R]Rmult_1_r.
apply:Rmult_le_compat_l; first by apply: Rabs_pos.
rewrite Rabs_pos_eq ; last by apply:bpow_ge_0.
change ( pow 0 <= pow (Fexp fa - ce a))%R.
by apply:bpow_le; lia.
Qed.

(* Hypothesis ZNE : choice = fun n => negb (Z.even n). *)

Theorem Fast2Sum_correct_proof_aux : t = (a + b - s)%R.
Proof.

case:getnum_fa=>// fa' [fa'E [h1 h2]].
case:(Req_dec a 0)=>a0.
  rewrite a0 !Rplus_0_l Rminus_0_r !round_generic //.
  have ->: (b - b = 0)%R by ring.
  by apply/generic_format_0.
have emin_a: (pow (emin + p - 1) <= Rabs a)%R.
  apply:Rle_pmabs=>//.
  by repeat (apply: Z.le_min_l || apply: (Z.le_trans _ _ _ (Z.le_min_r _ _))).
case:(Req_dec b 0)=>b0.
   rewrite b0 !Rplus_0_r (round_generic _ _ _ a) //.
  have ->: (a - a = 0)%R by ring.
  by rewrite round_0 Rminus_0_r round_0 //.
have emin_b: (pow (emin + p - 1) <= Rabs b)%R.
  apply:Rle_pmabs=>//.
  by repeat (apply: Z.le_min_l || apply: (Z.le_trans _ _ _ (Z.le_min_r _ _))).
case:(Req_dec (a+b) 0)=>ab0.
  rewrite  ab0 round_0 Rminus_0_l Rminus_0_r.
  rewrite  rnd_p_sym (round_generic _ _ _ a) //.
  have-> : (b - - a = a + b)%R by ring.
  by rewrite ab0 round_0.
have emin_apb: (pow (emin + p - 1) <= Rabs (a+b))%R.
  apply:Rle_pmabs=>//.
  by repeat (apply: Z.le_min_l || apply: (Z.le_trans _ _ _ (Z.le_min_r _ _))).
case:(Req_dec (s - a) 0)=>sma0.
 rewrite  sma0 round_0 Rminus_0_r round_generic //; lra.
have emin_sma: (pow (emin + p - 1) <= Rabs (s-a))%R.
  apply:Rle_pmabs=>//.
  by repeat (apply: Z.le_min_l || apply: (Z.le_trans _ _ _ (Z.le_min_r _ _))).
case:(Req_dec (b - z) 0)=>bmz0.
  (* pose emin := (Z.min (ubemin a)  *)
  (* (Z.min (ubemin b) (Z.min (ubemin (a + b))   (ubemin (s -a))))). *)
  rewrite bmz0 round_0 -!(round_FLT_FLX _ emin)//.
  have ->: (0%R = round beta (FLT_exp emin p) (Znearest choice) (b -z))%R.
    by rewrite bmz0 round_0.
  rewrite -!(round_FLT_FLX _ emin) //.
    apply Fast2Sum_correct_proof_flt with (fa := fa')=>//.
    + by rewrite /Prec_gt_0; lia.
    + by apply:generic_format_FLT_FLX.
    + by apply:generic_format_FLT_FLX.
    split=>//; split=>//.
    by rewrite cexp_FLT_FLX.
  by rewrite (round_FLT_FLX _ emin).
have emin_bmz: (pow (emin + p - 1) <= Rabs (b -z))%R.
  apply:Rle_pmabs=>//.
  by repeat (apply: Z.le_min_l || apply: (Z.le_trans _ _ _ (Z.le_min_r _ _))).
rewrite -!(round_FLT_FLX _ emin)//.
+ apply Fast2Sum_correct_proof_flt with (fa := fa')=>//.
  - rewrite / Prec_gt_0; lia.
  - by apply:generic_format_FLT_FLX.
  - by apply:generic_format_FLT_FLX.
  split=>//; split=>//.
  by rewrite cexp_FLT_FLX.
+ by rewrite !(round_FLT_FLX _ emin).
+ by rewrite !(round_FLT_FLX _ emin).
+ by rewrite !(round_FLT_FLX _ emin).
Qed.

Definition Fast2Sum := (s, t).

Definition  Fast2Sum_correct  :=
   let s := fst Fast2Sum  in let t := snd Fast2Sum  in t = (a+b -s)%R.
End F2Sum.

Fact Fast2Sum0f b (Fb:format b): (Fast2Sum 0 b ) = (b,0%R).
Proof.
rewrite /Fast2Sum !(Rplus_0_l, Rminus_0_r, round_0) !round_generic //;
  ring_simplify(b-b)%R=>//.
by apply:generic_format_0.
Qed.

 Fact Fast2Sumf0 a (Fa:format a): (Fast2Sum a 0 ) = (a,0%R).
 Proof.
by rewrite /Fast2Sum !(Rplus_0_r, Rminus_0_l, round_0) !round_generic //;
  ring_simplify(a-a)%R; rewrite ?Ropp_0 // ;
  apply:generic_format_0.
Qed.

Hypothesis ZNE : choice = fun n => negb (Z.even n).

 Fact Fast2Sum_asym a b : Fast2Sum (-a) (-b) = pair_opp (Fast2Sum a b).
 Proof.
rewrite /Fast2Sum /pair_opp/=.
rewrite -!Ropp_plus_distr ZNE round_NE_opp -ZNE.
rewrite -2!Ropp_minus_distr Ropp_involutive -Ropp_minus_distr.
set rab := rnd_p (a + b).
have->: (-rab - - a = - (rab - a))%R  by ring.
rewrite  ZNE !round_NE_opp -ZNE.
by have->: ((- rnd_p (rab - a) - - b) = (b - rnd_p (rab - a)))%R by ring.
Qed.

Fact Fast2SumS  x y  e (Fx : format x) (Fy : format y):
   Fast2Sum (x * pow e)  (y * pow e)  = ((fst (Fast2Sum x y) * pow e)%R,
                                (snd (Fast2Sum x y) * pow e)%R).
Proof.
rewrite /= /Fast2Sum.
by rewrite /= !(=^~ Rmult_plus_distr_r, round_bpow, =^~ Rmult_minus_distr_r).
Qed.

Hypothesis Hb3 : beta <= 3.

Notation ubemin x := ( mag beta  x - p)%Z.

Theorem F2Sum_correct_proof a b (Fa : format a) (Fb : format b) :
     (exists (fa:float beta), a = F2R fa /\ ce b <= Fexp fa )->
Fast2Sum_correct  a b.
Proof.
case=> fa [faE hle].
case:(@getnum_fa a b Fa fa)=>// fa' [fa'E [h1 h2]].
rewrite /Fast2Sum_correct /=.
by rewrite   (@Fast2Sum_correct_proof_aux _ _ Fa Fb Hb3 fa').
Qed.

Theorem F2Sum_correct_cexp a b (Fa : format a) (Fb : format b) :
                ce b <= ce a  -> Fast2Sum_correct  a b.
Proof.
move=> cexp_le.

move:(Fa); rewrite /generic_format.
set Ma := Ztrunc _.
set fa := Float beta _ _.
move=> afE.
apply: (@Fast2Sum_correct_proof_aux _ _ _ _ _ fa)=>//.
Qed.

Theorem F2Sum_correct_abs a b (Fa : format a) (Fb : format b) :
   (Rabs b <= Rabs a)%R  -> Fast2Sum_correct  a b.
Proof.
move=> abs_le.
move:(Fa); rewrite /generic_format.
set Ma := Ztrunc _.
set fa := Float beta _ _.
move=> afE.
case:(Req_dec b 0)=> [->|b0].
rewrite /Fast2Sum_correct Fast2Sumf0 //=; ring.
apply:F2Sum_correct_cexp=>//.
by apply/FLX_exp_monotone/mag_le_abs.
Qed.

Theorem  F2Sum_correct_DW a b : Fast2Sum_correct  a b ->
let s := fst (Fast2Sum a b) in let t := snd (Fast2Sum a b) in
     (format s /\format t) /\ s = rnd_p (s + t).
Proof.
rewrite  /Fast2Sum_correct.
case H: (Fast2Sum a b) => [s t] /=.
move: H; rewrite /Fast2Sum; case=> sE tE H.
split;first by split; rewrite -?sE -?tE; apply:generic_format_round.
by have -> : (s + t = a+b)%R;  lra.
Qed.

End Fast2Sum.