(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(** * FDHcsem.v : Semantics with a cyclic group, a trapdoor permutation and
    its inverse *)
Set Implicit Arguments.

Unset Strict Implicit.

Require Export PPT.
Require Export BuildTac.

Open Scope nat_scope.

Module Type CYCLIC_GROUP.

 Parameter t : nat -> Type.

 (** Generator *)
 Parameter g : forall k, t k.

 (** Identity element *)
 Parameter e : forall k, t k.

 (** Equality is decidable *)
 Parameter eqb : forall k, t k -> t k -> bool.
 Parameter eqb_spec : forall k (x y:t k), if eqb x y then x = y else x <> y.

 (** Operations: inverse, product, logarithm, power *)
 Parameter inv : forall k, t k -> t k.
 Parameter mul : forall k, t k -> t k -> t k.
 Parameter log : forall k, t k -> nat.

 Fixpoint pow (k:nat) (x:t k) (n:nat) : t k :=
  match n with
  | O => e k
  | S n => mul x (pow x n)
  end.

 (** Specification *)
 Parameter mul_assoc : forall k (x y z:t k), mul x (mul y z) = mul (mul x y) z.
 Parameter mul_e_l : forall k (x:t k), mul (e k) x = x.
 Parameter mul_inv_l : forall k (x:t k), mul (inv x) x = e k.

 Parameter cyclic_1 : forall k, pow (g k) k = e k.
 Parameter cyclic_2 : forall k n, pow (g k) n = e k -> exists i, n = k * i.

 Parameter log_lt : forall k (x:t k), log x < k.
 Parameter log_spec : forall k (x:t k), x = pow (g k) (log x).

 (* Cost *)
 Parameter cost_mul : forall k (x y:t k), nat.
 Parameter cost_pow : forall k (x:t k) (n:nat), nat.
 Parameter cost_inv : forall k (x:t k), nat.

 Parameter cost_mul_poly : polynomial.
 Parameter cost_pow_poly : polynomial.
 Parameter cost_inv_poly : polynomial.

 Parameter cost_mul_poly_spec : forall k (x y:t k),
  @cost_mul k x y <= peval cost_mul_poly (pred (size_nat k)).

 Parameter cost_pow_poly_spec : forall k (x:t k) (n:nat),
  @cost_pow k x n <= peval cost_pow_poly (pred (size_nat k)).

 Parameter cost_inv_poly_spec : forall k (x:t k),
  @cost_inv k x <= peval cost_inv_poly (pred (size_nat k)).

End CYCLIC_GROUP.

Module CG_Properties (CG:CYCLIC_GROUP).

 Import CG.

 Lemma mul_pow_plus : forall k (x:t k) n m,
  mul (pow x n) (pow x m) = pow x (n + m).
 Proof.
  induction n; intros; simpl.
  simpl; apply mul_e_l.
  simpl; rewrite <- mul_assoc, IHn; trivial.
 Qed.

 Lemma mul_comm : forall k (x y:t k), mul x y = mul y x.
 Proof.
  intros k x y.
  rewrite (log_spec x), (log_spec y).
  rewrite mul_pow_plus, plus_comm, <- mul_pow_plus; trivial.
 Qed.

 Lemma mul_e_r : forall k x, mul x (e k) = x.
 Proof.
  intros; rewrite mul_comm, mul_e_l; trivial.
 Qed.

 Lemma mul_inv_r : forall k x, mul x (inv x) = e k.
 Proof.
  intros; rewrite mul_comm, mul_inv_l; trivial.
 Qed.

 Lemma pow_e : forall k n, pow (e k) n = e k.
 Proof.
  induction n; intros.
  trivial.
  simpl; rewrite IHn, mul_e_r; trivial.
 Qed.

 Lemma pow_mul_distr : forall k (x y:t k) n,
  pow (mul x y) n = mul (pow x n) (pow y n).
 Proof.
  induction n; intros.
  simpl; rewrite mul_e_r; trivial.
  simpl; rewrite mul_assoc.
  rewrite (mul_comm x (pow x n)).
  rewrite <- (mul_assoc (pow x n)).
  rewrite (mul_comm (pow x n)).
  repeat rewrite <- mul_assoc.
  rewrite IHn; trivial.
 Qed.

 Lemma pow_pow : forall k (x:t k) n m, pow (pow x n) m = pow x (n * m).
 Proof.
  induction n; intros.
  simpl; simpl; rewrite pow_e; trivial.
  simpl; rewrite <- mul_pow_plus, <- IHn.
  apply pow_mul_distr.
 Qed.

 Lemma pow_inj : forall k a b,
  a < k ->
  b < k ->
  pow (g k) a = pow (g k) b ->
  a = b.
 Proof.
  induction a; intros.
  simpl in H1; symmetry in H1; apply cyclic_2 in H1.
  destruct H1 as [i H1]; subst.
  destruct i; [ trivial |].
  rewrite mult_comm in H0; simpl in H0.
  rewrite <- plus_0_r in H0.
  apply plus_lt_reg_l in H0.
  elimtype False; apply (lt_n_O _ H0).

  destruct b.
  simpl (pow (g k) 0) in H1.
  apply cyclic_2 in H1.
  destruct H1 as [i H1].
  clear IHa H0.
  destruct i.
  omega.
  rewrite mult_comm in H1; simpl in H1.
  rewrite H1 in H; clear H1.
  rewrite <- plus_0_r in H.
  apply plus_lt_reg_l in H.
  elimtype False; apply (lt_n_O _ H).

  apply f_equal.
  apply IHa; clear IHa; [ omega | omega | ].
  simpl in H1.
  rewrite <- mul_e_r with (x:=pow (g k) a).
  rewrite <- mul_e_r with (x:=pow (g k) b).
  rewrite <- mul_inv_r with (x:=g k).
  repeat rewrite mul_assoc.
  rewrite mul_comm with (x:=pow (g k) a).
  rewrite mul_comm with (x:=pow (g k) b).
  rewrite H1; trivial.
 Qed.

End CG_Properties.

Declare Module CG : CYCLIC_GROUP.

Module Type TRAPDOOR_PERM.

 (** * Trapdoor permutation and its inverse *)
 Parameter ap_f    : forall k (x:CG.t (2^k)), CG.t (2^k).
 Parameter ap_finv : forall k (x:CG.t (2^k)), CG.t (2^k).

 Parameter f_spec : forall k (x:CG.t (2^k)), ap_finv (ap_f x) = x.
 Parameter finv_spec : forall k (x:CG.t (2^k)), ap_f (ap_finv x) = x.

 Parameter f_homo : forall k (x y:CG.t (2^k)),
  ap_f (CG.mul x y) = CG.mul (ap_f x) (ap_f y).

 Parameter cost_f : polynomial.
 Parameter cost_finv : nat -> nat.

 (* Maximum number of queries made to the signing oracle *)
 Parameter qS_poly : polynomial.

 (* Maximum number of queries made to the hash oracle *)
 Parameter qH_poly : polynomial.

 (* REMARK: qS <= qH *)

End TRAPDOOR_PERM.

Declare Module TP : TRAPDOOR_PERM.

Module CGP := CG_Properties CG.

Inductive ut_ : Type := group.

(** * User-defined type module *)
Module Ut <: UTYPE.

 Definition t := ut_.
 Definition eqb ( _ _ :t) := true.

 Lemma eqb_spec : forall x y, if eqb x y then x = y else x <> y.
 Proof.
  simpl; destruct x; destruct y; trivial.
 Qed.

 Definition eq_dec (x y:t) : {x = y} + {True} :=
  match x as x0 return {x0 = y} + {True} with
  | group =>
    match y as y0 return {group = y0} + {True} with
    | group => left _ (refl_equal group)
    end
  end.

 Lemma eq_dec_r : forall x y i, eq_dec x y = right _ i -> x <> y.
 Proof.
  destruct x; destruct y; simpl; intros; discriminate.
 Qed.

 Definition interp k (_:t) := CG.t (2^k).

 Definition size k (_:t) (_:CG.t (2^k)) := S k.

 Definition default k (t0:t) : interp k t0 := CG.e (2^k).

 Definition default_poly (t0:t) := pplus (pcst 1) pvar.

 Lemma size_positive : forall k (t0:t) x, 0 < @size k t0 x.
 Proof.
  intros k t0 x; unfold size; auto with arith.
 Qed.

 Lemma default_poly_spec : forall k (t0:t),
  @size k t0 (default k t0) <= peval (default_poly t0) k.
 Proof.
  intros k t0.
  unfold default, default_poly, size.
  rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
 Qed.

 Definition i_eqb k t (g1 g2: interp k t) := CG.eqb g1 g2.

 Lemma i_eqb_spec : forall k t (x y:interp k t),
  if i_eqb x y then x = y else x <> y.
 Proof.
  intros; refine (CG.eqb_spec _ _).
 Qed.

End Ut.

Fixpoint lfalse (n:nat) :=
 match n with
 | O => nil
 | S n => false :: lfalse n
 end.

Definition bool_support (k:nat) := true :: lfalse (peval TP.qS_poly k).

Definition group_support (k:nat) :=
 map (fun i => CG.pow (CG.g (2^k)) i) (seq 0 (2^k)).

Lemma group_support_notnil : forall k, group_support k <> nil.
Proof.
 induction k; simpl; intros.
 discriminate.
 unfold group_support; intro Heq.
 assert (In 0 (seq 0 (2 ^ (S k)))).
 apply le_In_seq; split; [ trivial | ].
 rewrite plus_0_r; apply pow_lt_0; auto.
 apply in_map with (f:=fun i : nat => CG.pow (CG.g (2 ^ S k)) i) in H.
 rewrite Heq in H; inversion H.
Qed.

Lemma group_support_full : forall k (x:CG.t (2^k)), In x (group_support k).
Proof.
 intros; rewrite (CG.log_spec x).
 assert (Hlt:=CG.log_lt x).
 unfold group_support.
 rewrite in_map_iff.
 exists (CG.log x); split.
 trivial.
 apply le_In_seq; auto with arith.
Qed.

Lemma group_support_NoDup : forall k n,
 n <= k ->
 NoDup (map (fun i => CG.pow (CG.g k) i) (seq 0 n)).
Proof.
 intros k n Hlt; induction n.
 constructor.

 rewrite seq_S; simpl.
 rewrite map_app; apply NoDup_app.
 auto with arith.
 constructor.
 apply in_nil.
 constructor.

 intros x H1 H2.
 rewrite in_map_iff in H1.
 rewrite in_map_iff in H2.
 destruct H1 as [a [Ha1 Ha2] ].
 destruct H2 as [b [Hb1 Hb2] ].
 inversion Ha2; [ | trivial]; clear Ha2 IHn; subst.
 apply In_seq_le in Hb2; rewrite plus_0_r in Hb2.

 assert (b = a).
 apply CGP.pow_inj with k; [ omega | omega | trivial].
 omega.
Qed.

Module T := MakeType Ut.

Inductive usupport_
 (Ttype:Type) (Tuser:ut_ -> Ttype) (Tbool:Ttype) : Ttype -> Type :=
| Ugroup : usupport_ Tuser Tbool (Tuser group)
| Ubool_p : usupport_ Tuser Tbool Tbool.

Module Us <: USUPPORT Ut T.

 Definition usupport : T.type -> Type := usupport_ T.User T.Bool.

 Definition eval k t (s:usupport t) : list (T.interp k t) :=
  match s in usupport_ _ _ t0 return list (T.interp k t0) with
  | Ugroup => group_support k
  | Ubool_p => bool_support k
  end.

 Definition ceval k t (s:usupport t) : list (T.interp k t) * nat :=
  match s in usupport_ _ _ t0 return list (T.interp k t0) * nat with
  | Ugroup => (group_support k, S O)
  | Ubool_p => (bool_support k, S O)
  end.

 Lemma eval_usupport_nil : forall k t (s:usupport t), eval k s <> nil.
 Proof.
  intros; case s.
  apply group_support_notnil.
  discriminate.
 Qed.

 Lemma ceval_spec : forall k t (s:usupport t), eval k s = fst (ceval k s).
 Proof.
  intros k t s; case s; trivial.
 Qed.

 Definition eqb (t1 t2:T.type) (s1:usupport t1) (s2:usupport t2) : bool :=
  match s1, s2 with
  | Ugroup, Ugroup => true
  | Ubool_p, Ubool_p => true
  | _, _ => false
  end.

 Lemma eqb_spec_dep :  forall t1 (e1 : usupport t1) t2 (e2:usupport t2),
  if eqb e1 e2 then eq_dep T.type usupport t1 e1 t2 e2
  else ~eq_dep T.type usupport t1 e1 t2 e2.
 Proof.
  intros.
  case e1; case e2; simpl; try constructor; intro H; inversion H.
 Qed.

 Lemma eqb_spec : forall t (e1 e2:usupport t),
  if eqb e1 e2 then e1 = e2 else e1 <> e2.
 Proof.
  intros t e1 e2.
  generalize (eqb_spec_dep e1 e2).
  case (eqb e1 e2); intro H.
  apply T.eq_dep_eq; trivial.
  intro Heq; apply H; rewrite Heq; constructor.
 Qed.

End Us.

Module Entries.

 Export TP.

 Lemma f_inj : forall k (x y:CG.t (2^k)), ap_f x = ap_f y -> x = y.
 Proof.
  intros; rewrite <- (f_spec x), <- (f_spec y), H; trivial.
 Qed.

 Lemma f_inj_Veqb : forall k (x y:CG.t (2^k)),
  CG.eqb (ap_f x) (ap_f y) = CG.eqb x y.
 Proof.
  intros.
  generalize (CG.eqb_spec x y); case (CG.eqb x y); intro H.
  generalize (CG.eqb_spec (ap_f x) (ap_f y)).
  case (CG.eqb (ap_f x) (ap_f y)); trivial.
  rewrite H; intro H0; elim H0; trivial.

  generalize (CG.eqb_spec (ap_f x) (ap_f y)).
  case (CG.eqb (ap_f x) (ap_f y)); trivial.
  intro H0; apply f_inj in H0; elim H; trivial.
 Qed.

 Inductive uop_ : Type :=
 | OGorder
 | OGen
 | OGmul
 | OGpow
 | OGinv
 | Of
 | Ofinv
 | OqS
 | OqH.

 Module Uop <: UOP Ut T.

  Definition t := uop_.

  Definition eqb (o1 o2 : t) : bool :=
   match o1, o2 with
   | OGorder, OGorder
   | OGen, OGen
   | OGmul, OGmul
   | OGpow, OGpow
   | OGinv, OGinv
   | Of, Of
   | Ofinv, Ofinv
   | OqS, OqS
   | OqH, OqH => true
   | _, _ => false
   end.

  Lemma eqb_spec :  forall x y, if eqb x y then x = y else x <> y.
  Proof.
   destruct x; destruct y; simpl; trivial; intro; discriminate.
  Qed.

  Definition targs (op : t) : list T.type :=
   match op with
   | OGorder
   | OGen => nil
   | OGmul => T.User group :: T.User group :: nil
   | OGpow => T.User group :: T.Nat :: nil
   | OGinv => T.User group :: nil
   | Of => T.User group :: nil
   | Ofinv => T.User group :: nil
   | OqS => nil
   | OqH => nil
   end.

  Definition tres (op: t) : T.type :=
   match op with
   | OGorder => T.Nat
   | OGen => T.User group
   | OGmul => T.User group
   | OGpow => T.User group
   | OGinv => T.User group
   | Of => T.User group
   | Ofinv => T.User group
   | OqS => T.Nat
   | OqH => T.Nat
   end.

  Definition interp_op (k:nat) (op:t) : T.type_op k (targs op) (tres op) :=
   match op as op0 return T.type_op k (targs op0) (tres op0) with
   | OGorder => 2^k
   | OGen => @CG.g (2^k)
   | OGmul => @CG.mul (2^k)
   | OGpow => @CG.pow (2^k)
   | OGinv => @CG.inv (2^k)
   | Of => @ap_f k
   | Ofinv => @ap_finv k
   | OqS => peval qS_poly k
   | OqH => peval qH_poly k
   end.

  Implicit Arguments interp_op [k].

  Definition cinterp_op (k:nat) (op:t) : T.ctype_op k (targs op) (tres op) :=
   match op as op0 return T.ctype_op k (targs op0) (tres op0) with
   | OGorder => (2^k, 1)
   | OGen => (@CG.g (2^k), 1)
   | OGmul => fun x y => (@CG.mul (2^k) x y, CG.cost_mul x y)
   | OGpow => fun x n => (@CG.pow (2^k) x n, CG.cost_pow x n)
   | OGinv => fun x => (@CG.inv (2^k) x, CG.cost_inv x)
   | Of => fun x => (@ap_f k x, peval cost_f k)
   | Ofinv => fun x => (@ap_finv k x, cost_finv k)
   | OqS => (peval qS_poly k, 1)
   | OqH => (peval qH_poly k, 1)
   end.

  Implicit Arguments cinterp_op [k].

  Definition eval_op k
   (op:t) (args: dlist (T.interp k) (targs op)) : T.interp k (tres op) :=
   @T.app_op k (targs op) (tres op) (interp_op op) args.

  Definition ceval_op k
   (op:t) (args: dlist (T.interp k) (targs op)) : T.interp k (tres op) * nat :=
   @T.capp_op k (targs op) (tres op) (cinterp_op op) args.

  Lemma ceval_op_spec : forall k op args,
   @eval_op k op args = fst (@ceval_op k op args).
  Proof.
   intros k o args; destruct o; simpl in args;
    T.dlist_inversion args; subst; trivial.
  Qed.

 End Uop.

 (** Semantics with optimizations *)
 Module SemO <: SEM_OPT.

  Module Sem := MakeSem.Make Ut T Uop Us.
  Export Sem.

  (* The trapdoor permutation and its inverse *)
  Notation f := (E.Eop (O.Ouser Of)).
  Notation finv := (E.Eop (O.Ouser Ofinv)).

  (* Group operation *)
  Notation "x '|x|' y" := (E.Eop (O.Ouser OGmul) {x,y}) (at level 40).

  (* Group inverse *)
  Notation "x '^-1'" := (E.Eop (O.Ouser OGinv) {x}) (at level 40).

  (* Maximum number of queries made to the hash oracle *)
  Notation "'qH'" := (E.Eop (O.Ouser OqH) (dnil E.expr)).

  (* Maximum number of queries made to the signing oracle *)
  Notation "'qS'" := (E.Eop (O.Ouser OqS) (dnil E.expr)).

  (* Supports *)
  Notation "'{0,1}_p'" := (E.Duser (Ubool_p T.User T.Bool)).
  Notation "'G_k'" := (E.Duser (Ugroup T.User T.Bool)).

  (* Some infinite type (bitstrings in the literature) *)
  Notation Msg := T.Nat.

  (** Simplifies [f (finv x)] to [x] *)
  Definition simpl_op (op : Uop.t) : E.args (Uop.targs op) ->
   E.expr (Uop.tres op) :=
   match op as op0 return E.args (Uop.targs op0) -> E.expr (Uop.tres op0) with
   | Of => fun args =>
    E.app_expr (T.User group) args
    (fun (e:E.expr (T.User group)) =>
     match E.get_uop e with
     | Some (existT uop args) =>
       match uop as uop0
       return E.args (Uop.targs uop0) -> E.expr (T.User group) with
       | Ofinv =>
         fun args =>
          E.app_expr (T.User group) args (fun e1:E.expr (T.User group) => e1)
       | _ => fun _ => f {e}
       end args
     | None => f {e}
     end)
   | op => fun args => E.Eop (O.Ouser op) args
   end.

  Implicit Arguments simpl_op [].

  Lemma simpl_op_spec : forall k op args (m:Mem.t k),
   E.eval_expr (simpl_op op args) m = E.eval_expr (E.Eop (O.Ouser op) args) m.
  Proof.
   destruct op; simpl; trivial.
   intros args m.
   intros;T.dlist_inversion args; rewrite Heq; simpl.
   generalize (E.get_uop_spec x); destruct (E.get_uop x); trivial.
   destruct s as (uop, args0).
   intros H; generalize (H uop args0 (refl_equal _)); clear H; simpl; intros.
   destruct uop; trivial.
   rewrite (T.eq_dep_eq H); clear H.
   clear Heq;T.dlist_inversion args0; rewrite Heq; simpl.
   symmetry; exact (finv_spec (E.eval_expr x0 m)).
  Qed.

 End SemO.

 Module BP := BaseProp.Make SemO.Sem.

 Module Uppt.

  Import BP.

  Implicit Arguments T.size [k t].

  (** PPT expression *)
  Definition PPT_expr (t:T.type) (e:E.expr t)
   (F:polynomial -> polynomial)
   (G:polynomial -> polynomial) : Prop :=
   forall k (m:Mem.t k) p,
    (forall t (x:Var.var t),
     BP.Vset.mem x (BP.fv_expr e) -> T.size (m x) <= peval p k)  ->
    let (v,n) := E.ceval_expr e m in
     T.size v <= peval (F p) k /\
     n <= peval (G p) k.

  (** PPT support *)
  Definition PPT_support t (s:E.support t)
   (F:polynomial -> polynomial)
   (G:polynomial -> polynomial) : Prop :=
   forall k (m:Mem.t k) p,
    (forall t (x:Var.var t),
     BP.Vset.mem x (BP.fv_distr s) -> T.size (m x) <= peval p k)  ->
    let (l,n) := E.ceval_support s m in
     (forall v, In v l -> T.size v <= peval (F p) k) /\
     n <= peval (G p) k.

  Definition utsize : UT.t -> nat := fun _ => 1.

  Definition utsize_default_poly : nat -> polynomial :=
   fun _ => pplus (pcst 1) pvar.

  Lemma utsize_default_poly_spec : forall r ut,
   utsize ut <= r ->
   forall k,
    UT.size (t:=ut) (UT.default k ut) <= peval (utsize_default_poly r) k.
  Proof.
   intros r ut _ k.
   case ut; simpl.
   unfold UT.size, utsize_default_poly.
   rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
  Qed.

  Definition uop_poly (o:Uop.t) : bool :=
   match o with
   | OGorder | OGen | OGmul | OGpow | OGinv | Of | OqS | OqH => true
   | _ => false
   end.

  Lemma uop_poly_spec : forall o (la:dlist E.expr (O.targs (O.Ouser o))),
   uop_poly o ->
   (forall t (e:E.expr t), @DIn _ E.expr _ e _ la ->
    exists F, exists G, PPT_expr e F G) ->
   exists F, exists G, PPT_expr (E.Eop (O.Ouser o) la) F G.
  Proof.
   intros o la H Hla.
   destruct o.

   (* OGorder *)
   T.dlist_inversion la.
   rewrite Heq in Hla |- *.
   exists (fun _ => pplus 1 pvar).
   exists (fun _ => 1).
   simpl; split.
   rewrite pplus_spec, pcst_spec, pvar_spec; rewrite size_nat_pow_2; trivial.
   rewrite pcst_spec; trivial.

   (* OGen *)
   T.dlist_inversion la.
   rewrite Heq in Hla |- *.
   exists (fun _ => pplus 1 pvar).
   exists (fun _ => 1).
   simpl; split.
   rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
   rewrite pcst_spec; trivial.

   (* OGmul *)
   T.dlist_inversion la.
   rewrite Heq in Hla |- *.
   destruct (Hla _ x) as [F1 [G1 H1] ].
   left; trivial.
   destruct (Hla _ x0) as [F2 [G2 H2] ].
   right; left; trivial.
   exists (fun _ => pplus 1 pvar).
   exists (fun p => pplus CG.cost_mul_poly (pplus (G1 p) (G2 p))).
   intros k m p Hm; simpl; split.

   rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
   rewrite pplus_spec, pplus_spec.
   apply plus_le_compat.
   apply le_trans with (peval CG.cost_mul_poly (pred (size_nat (2^k)))).
   apply CG.cost_mul_poly_spec.
   rewrite size_nat_pow_2; trivial.

   generalize (H1 k m p) (H2 k m p); clear H1 H2.
   case_eq (E.ceval_expr x m); simpl.
   case_eq (E.ceval_expr x0 m); simpl.
   intros i n Heqi i0 n0 Heqi0 Hi Hi0.
   destruct Hi.
   intros; apply Hm; simpl.
   apply Vset.subset_correct with (fv_expr x); [ | trivial].
   unfold fv_expr; simpl.
   apply fv_expr_rec_subset.
   destruct Hi0.
   intros; apply Hm; simpl.
   apply Vset.subset_correct with (fv_expr x0); [ | trivial].
   unfold fv_expr at 2; simpl.
   fold (fv_expr_extend x0 (fv_expr_rec Vset.empty x)).
   rewrite union_fv_expr_spec.
   apply VsetP.subset_union_l.
   rewrite plus_0_r; apply plus_le_compat; auto.

   (* OGpow *)
   T.dlist_inversion la.
   rewrite Heq in Hla |- *.
   destruct (Hla _ x) as [F1 [G1 H1] ].
   left; trivial.
   destruct (Hla _ x0) as [F2 [G2 H2] ].
   right; left; trivial.
   exists (fun _ => pplus 1 pvar).
   exists (fun p => pplus CG.cost_pow_poly (pplus (G1 p) (G2 p))).
   intros k m p Hm; simpl; split.

   rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
   rewrite pplus_spec, pplus_spec.
   apply plus_le_compat.
   apply le_trans with (peval CG.cost_pow_poly (pred (size_nat (2^k)))).
   apply CG.cost_pow_poly_spec.
   rewrite size_nat_pow_2; trivial.

   generalize (H1 k m p) (H2 k m p); clear H1 H2.
   case_eq (E.ceval_expr x m); simpl.
   case_eq (E.ceval_expr x0 m); simpl.
   intros i n Heqi i0 n0 Heqi0 Hi Hi0.
   destruct Hi.
   intros; apply Hm; simpl.
   apply Vset.subset_correct with (fv_expr x); [ | trivial].
   unfold fv_expr; simpl.
   apply fv_expr_rec_subset.
   destruct Hi0.
   intros; apply Hm; simpl.
   apply Vset.subset_correct with (fv_expr x0); [ | trivial].
   unfold fv_expr at 2; simpl.
   fold (fv_expr_extend x0 (fv_expr_rec Vset.empty x)).
   rewrite union_fv_expr_spec.
   apply VsetP.subset_union_l.
   rewrite plus_0_r; apply plus_le_compat; auto.

   (* OGinv *)
   T.dlist_inversion la.
   rewrite Heq in Hla |- *.
   destruct (Hla _ x) as [F1 [G1 H1] ].
   left; trivial.
   exists (fun _ => pplus 1 pvar).
   exists (fun p => pplus CG.cost_inv_poly (G1 p)).
   intros k m p Hm; simpl; split.

   rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
   rewrite pplus_spec.
   apply plus_le_compat.
   apply le_trans with (peval CG.cost_inv_poly (pred (size_nat (2^k)))).
   apply CG.cost_inv_poly_spec.
   rewrite size_nat_pow_2; trivial.

   generalize (H1 k m p); clear H1.
   case_eq (E.ceval_expr x m); simpl.
   intros y n Heqy Hy.
   destruct Hy.
   intros; apply Hm; simpl.
   apply Vset.subset_correct with (fv_expr x); [ | trivial].
   apply VsetP.subset_refl.
   rewrite plus_0_r; trivial.

   (* Of *)
   T.dlist_inversion la.
   rewrite Heq in Hla |- *.
   destruct (Hla _ x) as [F1 [G1 H1] ].
   left; trivial.
   exists (fun _ => pplus 1 pvar).
   exists (fun p => pplus (cost_f) (G1 p)).
   simpl; split.
   unfold T.size, UT.size; rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
   rewrite pplus_spec; apply plus_le_compat; trivial.
   simpl.
   generalize (H1 k m p); clear H1.
   case_eq (E.ceval_expr x m); simpl.
   intros i n Heqi Hi.
   destruct Hi.
   intros; apply H0; simpl.
   apply Vset.subset_correct with (fv_expr x); [ | trivial].
   unfold fv_expr; simpl; auto with set.
   rewrite plus_0_r; trivial.

   (* Ofinv *)
   discriminate.

   (* OqS *)
   T.dlist_inversion la.
   rewrite Heq in Hla |- *.
   exists (fun _ => pplus 1 qS_poly).
   exists (fun _ => pcst 1).
   simpl; split.
   rewrite pplus_spec, pcst_spec; case (peval qS_poly k).
   trivial.
   intro n; apply le_trans with (S n); [apply size_nat_le | ]; auto with arith.
   rewrite pcst_spec; trivial.

   (* OqS *)
   T.dlist_inversion la.
   rewrite Heq in Hla |- *.
   exists (fun _ => pplus 1 qH_poly).
   exists (fun _ => pcst 1).
   simpl; split.
   rewrite pplus_spec, pcst_spec; case (peval qH_poly k).
   trivial.
   intro n; apply le_trans with (S n); [apply size_nat_le | ]; auto with arith.
   rewrite pcst_spec; trivial.
  Qed.

  Definition usupport_poly t (us:US.usupport t) : bool := true.

  Lemma usupport_poly_spec : forall t (us:US.usupport t),
   usupport_poly us ->
   exists F, exists G, PPT_support (E.Duser us) F G.
  Proof.
   intros t us; case us; intros _.

   exists (fun _ => pplus (pcst 1) pvar).
   exists (fun _ => pcst 1).
   intros k m p Hm.
   rewrite pplus_spec, pvar_spec, pcst_spec.
   rewrite (surjective_pairing
    (E.ceval_support (E.Duser (Ugroup T.User T.Bool)) m)).
   split; trivial.

   exists (fun _ => pcst 1).
   exists (fun _ => pcst 1).
   intros k m p Hm.
   rewrite pcst_spec.
   split; trivial.
  Qed.

 End Uppt.

End Entries.

Module Tactics := BuildTac.Make Entries.
Export Tactics.


Require Import CertiGraph.msl_application.Graph.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import VST.msl.alg_seplog_direct.
Require Import CertiGraph.msl_ext.abs_addr.
Require Import CertiGraph.msl_ext.seplog.
Require Import CertiGraph.msl_ext.log_normalize.
Require Import CertiGraph.msl_ext.precise_direct.
Require Import CertiGraph.msl_ext.overlapping_direct.
Require Import CertiGraph.msl_ext.alg_seplog_direct.
Require Import CertiGraph.msl_ext.ramify_tactics.
Require Import CertiGraph.heap_model_direct.SeparationAlgebra.
Require Import CertiGraph.heap_model_direct.mapsto.
Require Import CertiGraph.heap_model_direct.SeparationLogic.
Require Import VST.msl.msl_direct.
Require Import VST.msl.predicates_sa.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.ZArith.Znumtheory.

Local Open Scope nat.
Local Open Scope pred.

Instance SGS_HMD: PointwiseGraphSetting.
  apply (Build_PointwiseGraphSetting adr 0 eq_nat_dec).
Defined.

Definition trinode x (dlr: bool * nat * nat) :=
  match dlr with
  | (d, l, r) => !! Z.divide 3 (Z.of_nat x) && ((mapsto x (if d then 1 else 0)) * (mapsto (x+1) l) * (mapsto (x+2) r))
  end.

Lemma trinode_unfold: forall x, exp (trinode x) = !! Z.divide 3 (Z.of_nat x) && ((EX d: bool, (mapsto x (if d then 1 else 0))) * (exp (mapsto (x + 1))) * (exp (mapsto (x + 2)))).
Proof.
  intros.
  replace (exp (trinode x) =
   !! Z.divide 3 (Z.of_nat x) && ((EX d: bool, (mapsto x (if d then 1 else 0))) * exp (mapsto (x + 1)) * exp (mapsto (x + 2)))) with
    ((EX dlr : bool * adr * adr,
      !! Z.divide 3 (Z.of_nat x) &&
      (mapsto x (if (fst (fst dlr)) then 1 else 0) * mapsto (x + 1) (snd (fst dlr)) *
       mapsto (x + 2) (snd dlr))) =
   !! Z.divide 3 (Z.of_nat x) && ((EX d: bool, (mapsto x (if d then 1 else 0))) * seplog.exp (mapsto (x + 1)) * seplog.exp (mapsto (x + 2))))%logic.
  2: {
    f_equal.
    simpl.
    f_equal.
    extensionality dlr; destruct dlr as [[? ?] ?]. reflexivity.
  }
  rewrite <- log_normalize.exp_andp2.
  f_equal.
  repeat rewrite exp_curry; simpl fst; simpl snd.
  rewrite seplog.sepcon_assoc.
  rewrite log_normalize.exp_sepcon1.
  f_equal. extensionality s.
  rewrite log_normalize.exp_sepcon1.
  rewrite log_normalize.exp_sepcon2.
  f_equal; extensionality l.
  rewrite !log_normalize.exp_sepcon2.
  f_equal; extensionality r.
  rewrite seplog.sepcon_assoc.
  reflexivity.
Qed.

Lemma mapsto_derives_aux: forall x, EX  d : bool, mapsto x (if d then 1 else 0) |-- exp (mapsto x).
Proof.
  intros.
  apply exp_left; intro d.
  apply (exp_right (if d then 1 else 0)); auto.
Qed.

Lemma trinode__precise: forall x, precise (exp (trinode x)).
Proof.
  intros.
  rewrite trinode_unfold.
  pose proof (@precise_andp_right _ _ _ PSLdirect).
  simpl in H.
  apply H.
  repeat apply precise_sepcon; try apply mapsto__precise.
  apply derives_precise with (exp (mapsto x)); [| apply mapsto__precise].
  apply mapsto_derives_aux.
Qed.

Lemma trinode_conflict: forall p1 p2 v1 v2, p1 = p2 -> trinode p1 v1 * trinode p2 v2 |-- FF.
Proof.
  intros.
  destruct v1 as [[d1 l1] r1].
  destruct v2 as [[d2 l2] r2].
  change (trinode p1 (d1, l1, r1) * trinode p2 (d2, l2, r2) |-- FF) with
   (seplog.derives (!! Z.divide 3 (Z.of_nat p1) && (mapsto p1 (if d1 then 1 else 0) * mapsto (p1 + 1) l1 * mapsto (p1 + 2) r1) *
   (!! Z.divide 3 (Z.of_nat p2) && (mapsto p2 (if d2 then 1 else 0) * mapsto (p2 + 1) l2 * mapsto (p2 + 2) r2)))
    FF)%logic.
  eapply seplog.derives_trans.
  + apply seplog.sepcon_derives;
    (apply log_normalize.andp_derives;
    [| apply seplog.sepcon_derives; [apply seplog.sepcon_derives | apply seplog.derives_refl ]]);
    apply TT_right.
  + rewrite !TT_andp.
    simpl.
    rewrite !sepcon_assoc.
    rewrite (sepcon_comm (mapsto (p1 + 2) r1)).
    rewrite !sepcon_assoc.
    pose proof sepcon_left2_corable_right as HH; simpl in HH.
    do 4 (try apply HH); try apply corable_prop.
    apply mapsto_conflict.
    congruence.
Qed.

Lemma align_3_aux: forall x, Z.divide 3 (Z.of_nat x) <-> exists k, x = (k * 3) % nat.
Proof.
  intros.
  unfold Z.divide.
  split; intros [?k ?].
  + exists (Z.to_nat k).
    rewrite <- (Nat2Z.id x).
    rewrite H.
    assert (0 <= k)%Z.
    1: {
      destruct (Z_lt_le_dec k 0%Z); auto.
      assert (k * 3 < 0 * 3)%Z by (apply Z.mul_lt_mono_pos_r; lia).
      simpl in H0.
      lia.
    }
    apply Z2Nat.inj_mul; lia.
  + exists (Z.of_nat k).
    rewrite H.
    apply Nat2Z.inj_mul.
Qed.

Lemma align_3_aux1: forall p1 p2 k1 k2, (p1 = k1 * 3 -> p2 = k2 * 3 -> p1 = p2 + 1 -> False)%nat.
Proof.
  intros.
  subst.
  destruct (le_dec k1 k2).
  + pose proof mult_le_compat_r _ _ 3 l.
    lia.
  + assert (k2 * 3 < k1 * 3) by (apply Nat.mul_lt_mono_pos_r; lia).
    lia.
Qed.

Lemma align_3_aux2: forall p1 p2 k1 k2, (p1 = k1 * 3 -> p2 = k2 * 3 -> p1 = p2 + 2 -> False)%nat.
Proof.
  intros.
  subst.
  destruct (le_dec k1 k2).
  + pose proof mult_le_compat_r _ _ 3 l.
    lia.
  + assert (k2 * 3 < k1 * 3) by (apply Nat.mul_lt_mono_pos_r; lia).
    lia.
Qed.

Lemma disj_trinode_: forall p1 p2, p1 <> p2 -> disjointed (EX  v : bool * adr * adr, trinode p1 v)
  (EX  v : bool * adr * adr, trinode p2 v).
Proof.
  intros.
  change (EX  v : bool * adr * adr, trinode p1 v) with (exp (trinode p1)).
  change (EX  v : bool * adr * adr, trinode p2 v) with (exp (trinode p2)).
  rewrite !trinode_unfold.
  pose proof disj_prop_andp_left as HH; simpl in HH; apply HH; clear HH; [apply Zdivide_dec |].
  intros.
  apply align_3_aux in H0; destruct H0 as [k1 ?].
  pose proof disj_prop_andp_right as HH; simpl in HH; apply HH; clear HH; [apply Zdivide_dec |].
  intros.
  apply align_3_aux in H1; destruct H1 as [k2 ?].
  pose proof disj_sepcon_right as HH; simpl in HH.
  repeat apply HH; apply disj_comm; repeat apply HH;
  try (eapply disj_derives;
         [ first [apply mapsto_derives_aux | apply derives_refl]
         | first [apply mapsto_derives_aux | apply derives_refl]
         | apply disj_mapsto_]; lia).
Qed.

Lemma trinode_inj: forall p v1 v2, trinode p v1 && trinode p v2 |-- !! (v1 = v2).
Proof.
  intros.
  unfold trinode.
  destruct v1 as [[d1 l1] r1].
  destruct v2 as [[d2 l2] r2].
  eapply derives_trans.
  + apply andp_derives;
    (apply andp_derives;
    [apply (@TT_right _ Ndirect) | apply derives_refl]).
  + pose proof TT_andp.
    simpl in H; rewrite !H; clear H.
    rewrite !sepcon_assoc.
    eapply derives_trans.
    apply precise_left_sepcon_andp_distr with (exp (mapsto p)).
    1: apply mapsto__precise.
    1: apply (exp_right (if d1 then 1 else 0)); auto.
    1: apply (exp_right (if d2 then 1 else 0)); auto.

    eapply derives_trans; [apply sepcon_derives |].
    1: apply mapsto_inj.

    eapply derives_trans.
    apply precise_left_sepcon_andp_distr with (exp (mapsto (p + 1))).
    1: apply mapsto__precise.
    1: apply (exp_right l1); auto.
    1: apply (exp_right l2); auto.

    eapply derives_trans; [apply sepcon_derives |].
    1: apply mapsto_inj.
    1: apply mapsto_inj.
    1: apply derives_refl.

    pose proof sepcon_prop_prop.
    simpl in H; rewrite !H; clear H.

    intro; simpl in *; intros.
    unfold prop in *.

    destruct d1, d2; destruct H as [? [? ?]]; congruence.
Qed.

Instance MSLdirect : MapstoSepLog AV_SGraph trinode.
Proof.
  apply mkMapstoSepLog.
  apply trinode__precise.
Defined.

Instance sMSLdirect : StaticMapstoSepLog AV_SGraph trinode.
Proof.
  apply mkStaticMapstoSepLog; simpl; intros.
  + hnf in H. simpl in H. unfold addr_eqb in H. simpl in H.
    destruct eq_nat_dec.
    - inversion H.
    - exfalso; tauto.
  + apply trinode_conflict.
    unfold addr_eqb in H; simpl in H.
    destruct (eq_nat_dec p1 p2); congruence.
  + apply disj_trinode_.
    unfold addr_eqb in H; simpl in H.
    destruct (eq_nat_dec p1 p2); congruence.
Defined.

Instance nMSLdirect : NormalMapstoSepLog AV_SGraph trinode.
Proof.
  apply mkNormalMapstoSepLog.
  apply trinode_inj.
Defined.

Instance SGA_HMD: PointwiseGraphAssum.
  apply (Build_PointwiseGraphAssum (pred world) _ _ _ _ _ _ _ _ SGS_HMD trinode _ _ (* nMSLdirect *)).
Defined.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

   Do substitutions commute?

*)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Static_Semantics_Typing_Heap_Objects.
Require Export Cyclone_Classes Cyclone_Inductions Cyclone_LN_Tactics Cyclone_LN_Extra_Lemmas_And_Automation.
Require Export Cyclone_Context_Weakening_Proof.
Require Export Cyclone_LN_Types_Lemmas.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

Lemma A_5_Commuting_Substitutions:
  forall beta t2,
    beta \notin T.fv t2 ->
    forall t0 t1 alpha,
      (T.subst t2 alpha (T.subst t1 beta t0)) =
      (T.subst (T.subst t2 alpha t1) beta (T.subst t2 alpha t0)).
Proof.
  induction t0; intros; try solve[auto]; try solve[simpl;try case_var*; fequals*].
  simpl; case_var; case_var.
  admit. (* Wrong ? *)
  simpl.
  case_var*.
  simpl.
  case_var*.
  rewrite* TP.subst_fresh.
  simpl.
  case_var*.
  case_var*.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_assoc: forall l1 l2 l3,
  append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
induction l1.
  - simpl. intros. rewrite IHl1. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (qreva x y) (append (rev x) y).
Proof.
induction x.
  - intros. simpl. lfind. Admitted.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tG_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable deftogethergreater_1 : (forall A B C D E F : Universe, (exists X : Universe, (tG_ A B C D E F -> (betS_ A B X /\ (cong_ B X C D /\ lt_ E F A X))))).
Variable deftogethergreater2_2 : (forall A B C D E F X : Universe, ((betS_ A B X /\ (cong_ B X C D /\ lt_ E F A X)) -> tG_ A B C D E F)).
Variable lemma_betweennotequal_3 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable axiom_nocollapse_4 : (forall A B C D : Universe, ((A <> B /\ cong_ A B C D) -> C <> D)).
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 lemma_doublereverse_6 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ D C B A /\ cong_ B A D C))).
Variable lemma_congruenceflip_7 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable axiom_betweennesssymmetry_8 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable cn_sumofparts_9 : (forall A B C E F G : Universe, ((cong_ A B E F /\ (cong_ B C F G /\ (betS_ A B C /\ betS_ E F G))) -> cong_ A C E G)).
Variable lemma_lessthancongruence_10 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ C D E F) -> lt_ A B E F)).

Theorem lemma_TGsymmetric_11 : (forall A B C Xa Xb Xc : Universe, (tG_ A Xa B Xb C Xc -> tG_ B Xb A Xa C Xc)).
Proof.
  time tac.
Qed.

End FOFProblem.


Add LoadPath "../ml_proof".

Require Import reduction.

Require Import proofsystem.
Set Implicit Arguments.

Require Import Setoid.
Require Import Relation_Definitions.

Section domain.
Variable cfg : Set.

(* step according to a system *)
Inductive ts (S : system cfg) : cfg -> cfg -> Prop :=
  | ts_step : forall gamma gamma' env phi phi',
    S env phi phi' ->
    (exists rho, phi gamma rho /\ phi' gamma' rho) ->
    ts S gamma gamma'.

Section FixBaseSystem.

(* underlying transition relation *)
Variable SF : cfg -> cfg -> Prop.

(* at points under gamma, the rule holds semantically *)
(* TODO: give global version that people care directly about *)
Definition gamma_entails parent strict env
  (phi phi' : formula cfg env) :=
  forall gamma : cfg,
    clos SF false parent gamma ->
    forall rho : env,
      phi gamma rho ->
      exists gamma' : cfg,
        clos SF strict gamma gamma'
        /\ phi' gamma' rho.

Lemma gamma_entails_fwd :
  forall (gamma gamma' : cfg),
    clos SF false gamma gamma' ->
    forall strict env (phi phi' : formula cfg env),
      gamma_entails gamma strict phi phi'->
      gamma_entails gamma' strict phi phi'.
Proof.
  unfold gamma_entails. intros. eauto using clos_trans.
Qed.

Definition gamma_entails_system parent strict (S : system cfg) :=
  forall env (phi phi' : formula cfg env), S env phi phi' ->
    gamma_entails parent strict phi phi'.

Lemma gamma_system_fwd : forall gamma gamma' strict S,
  clos SF false gamma gamma' ->
  gamma_entails_system gamma strict S ->
  gamma_entails_system gamma' strict S.
Proof.
  unfold gamma_entails_system.
  intuition.
  eauto using gamma_entails_fwd.
Qed.

Lemma gamma_system_cons : forall gamma S env
  (phi phi' : formula cfg env),
  gamma_entails_system gamma true S ->
  gamma_entails gamma true phi phi' ->
   gamma_entails_system gamma true (cons_system cfg env phi phi' S).
Proof.
  intros. intro env0. intros.
  destruct H1.
  (* from system *)
  auto.
  (* new rule *)
  destruct H1 as [Heq [Hphi Hphi']].
  subst env0.
  unfold eq_rect_r in * |-; simpl in * |-.
  clear -H0 Hphi Hphi'.
  intro gamma'; intros.
  rewrite <- Hphi in H1.
  specialize (H0 gamma' H rho H1).
  setoid_rewrite Hphi' in H0.
  assumption.
Qed.

Lemma gamma_entails_unstrict :
  forall gamma strict env (phi phi' : formula cfg env),
  gamma_entails gamma true phi phi' ->
  gamma_entails gamma strict phi phi'.
Proof.
  unfold gamma_entails.
  firstorder.
  destruct (H gamma0 H0 rho H1).
  exists x.
  intuition.
  destruct strict; auto using clos_unstrict.
Qed.

Lemma gamma_entails_trans :
  forall gamma env (phi phi' phi'' : formula cfg env),
    gamma_entails gamma true phi phi' ->
    (forall gamma',
      clos SF true gamma gamma' ->
      gamma_entails gamma' false phi' phi'') ->
    gamma_entails gamma true phi phi''.
Proof.
  intros. intro gamma0; intros.
  specialize (H gamma0 H1 rho H2).
  destruct H as [gamma' [Hstep Hphi']].
  specialize (H0 gamma' (clos_cat H1 Hstep)
    gamma' (clos_refl _ _) rho Hphi').
  destruct H0 as [gamma'0 [Hstep' Hphi'']].
  exists gamma'0.
  split;[|assumption].
  eauto using clos_trans_lt.
Qed.

Theorem soundness : forall strict S env phi phi',
  forall (proof : IS cfg S strict env phi phi'),
    forall gamma,
      terminates gamma SF ->
      gamma_entails_system gamma true S ->
      gamma_entails gamma strict phi phi'.

Proof.
  intros strict S env phi phi' proof.
  induction proof; intros gamma Hterm Hsystem.

(* refl *)
  intro gamma0; intros;
  exists gamma0; solve[firstorder using clos_refl].

(* axiom *)
  apply gamma_entails_unstrict; solve[auto].

(* subst *)
  specialize (IHproof gamma Hterm Hsystem); clear -IHproof.
  solve[firstorder].

(* trans *)
  specialize (IHproof1 gamma Hterm Hsystem);
  specialize (IHproof2 gamma Hterm Hsystem);
  clear -IHproof1 IHproof2.
  unfold gamma_entails.
  intros.
  specialize (IHproof1 gamma0 H rho H0).
  destruct IHproof1 as [x [xtranz xsat]].
  assert (clos SF false gamma x) by
     (clear -H xtranz; destruct strict;
      eauto using clos,clos_unstrict).
  specialize (IHproof2 x H1 rho xsat).
  destruct IHproof2 as [gamma'' [Htranz Hsat'']].
  exists gamma''.
  split;[apply clos_trans_lt with x|];assumption.

(* ps_case *)
  solve[firstorder].

(* ps_lf *)
  specialize (IHproof gamma Hterm Hsystem).
  solve[firstorder].

(* ps_conseq *)
  specialize (IHproof gamma Hterm Hsystem).
  intro gamma0; intros.
  specialize (IHproof gamma0).
  apply H in H2.
  solve[firstorder].

(* ps_abstr *)
  solve[firstorder].

(* ps_circ *)
  specialize (IHproof1 gamma Hterm Hsystem).

  assert (forall gamma2,
    clos SF true gamma gamma2 ->
    gamma_entails gamma2 true phi phi' ->
    gamma_entails gamma2 false phi'' phi').
  intros.
  apply IHproof2;[solve[eauto using terminates_fwd]|].
  apply gamma_system_cons;[|assumption].
  clear -Hsystem H.
  unfold gamma_entails_system.
  intros. specialize (Hsystem env phi phi' H0).
  eauto using gamma_entails_fwd, clos_unstrict.

  clear IHproof2.
  rename H into IHproof2.

  cut (gamma_entails gamma true phi phi').
  apply gamma_entails_unstrict.

  apply terminates_trans in Hterm.
  revert Hterm. induction 1.

  eapply gamma_entails_trans;[eassumption|].
  intros.
  apply IHproof2;[assumption|].

  apply H0;
    eauto using gamma_entails_fwd, gamma_system_fwd,
      clos_unstrict, clos_trans.
Qed.
End FixBaseSystem.
End domain.


Require Export List.

Require Import term.
Require Import rpo.

Require Export utils.
Require Export coccinelle_utils.

(** Translation of the specification *)
Module Specif.

  Inductive symb : Set :=
  | id_0
  | id_S
  | id_true
  | id_false
  | id_evenm
  | id_oddm
  | id_even
  | id_odd
  | id_evenr
  | id_oddc
  | id_plus
  .

  Definition arity (f:symb) :=
    match f with
    | id_0 => term_spec.Free 0
    | id_S => term_spec.Free 1
    | id_true => term_spec.Free 0
    | id_false => term_spec.Free 0
    | id_evenm => term_spec.Free 1
    | id_oddm => term_spec.Free 1
    | id_even => term_spec.Free 1
    | id_odd => term_spec.Free 1
    | id_evenr => term_spec.Free 1
    | id_oddc => term_spec.Free 1
    | id_plus => term_spec.Free 2
    end.

Definition status (f:symb) :=
     match f with
    | id_0 => rpo.Mul
    | id_S => rpo.Mul
    | id_true => rpo.Mul
    | id_false => rpo.Mul
    | id_evenm => rpo.Mul
    | id_oddm => rpo.Mul
    | id_even => rpo.Mul
    | id_odd => rpo.Mul
    | id_evenr => rpo.Mul
    | id_oddc => rpo.Mul
    | id_plus => rpo.Mul

    end.
  Definition index (f:symb) :=
     match f with
    | id_0 => 2
    | id_S => 3
    | id_true => 4
    | id_false => 5
    | id_evenm => 10
    | id_oddm => 10
    | id_even => 11
    | id_odd => 11
    | id_evenr => 12
    | id_oddc => 13
    | id_plus => 7
    end.

  Definition max_size := 100.

End Specif.

(* Nat and comparisons *)
Module Nat <: decidable_set.S.

  Definition A:=nat.
  Definition eq_bool := utils.beq_nat.
  Definition eq_bool_ok := utils.beq_nat_ok.

End Nat. (*: decidable_set.S*)

(** Initialisation of Coccinelle *)
Module Symbols <: term_spec.Signature.

  Module Symb <: decidable_set.S.

    Definition A:=Specif.symb.

    Theorem symb_eq_dec: forall x y:A, {x=y}+{x<>y}.
    Proof.
    decide equality.
    Defined.

    Definition eq_bool := utils.eq_bool A symb_eq_dec.
    Definition eq_bool_ok := utils.eq_bool_ok A symb_eq_dec.

  End Symb. (* Symb : decidable_set.S *)

  Definition arity := Specif.arity.

End Symbols. (* Symbols : term_spec.Signature *)

Module Terms <: term_spec.Term := term.Make' Symbols Nat.
Module Rpo := coccinelle_utils.Make Terms.

Export Specif.
Export Rpo.

Theorem prec_eq_status : forall f g, utils.prec_eq symb index f g -> status f = status g.
Proof.
intros f g; case f; case g; reflexivity.
Qed.

Definition P := rpo.Build_Precedence status
    (utils.prec_bool symb index) (utils.prec_bool_ok symb index)  (utils.prec_antisym symb index) (utils.prec_transitive symb index) (utils.prec_eq_bool symb index) (utils.prec_eq_transitive symb index) (utils.prec_eq_refl symb index) (utils.prec_eq_bool_ok symb index) (utils.prec_eq_prec1 symb index) (utils.prec_eq_prec2 symb index) (utils.prec_eq_sym symb index) (utils.prec_not_prec_eq symb index) (prec_eq_status).

Notation less := (rpo_mul P (bb (empty_rpo_infos P max_size))).

(* Coq version of the specification. *) (* TODO: should be in Spec module but model_* *)

Fixpoint model_nat (v: nat): term :=
match v with
| O => (Term id_0 nil)
| (S x) => let r := model_nat x in   (Term id_S (r::nil))
 end.

Fixpoint model_bool (v: bool): term :=
match v with
|true => (Term id_true nil)
|false => (Term id_false nil)
end.

Fixpoint plus (x y:nat): nat :=
match x with
| O => y
| (S x') => S (plus x' y)
end.

Fixpoint evenr (x: nat): bool :=
match x with
| 0 => true
| (S O) => false
| (S (S x')) => evenr x'
end.

Definition oddc (x: nat): bool :=
match evenr(x) with
| true => false
| false => true
end.

Fixpoint evenm (v:nat): bool:=
match v with
| O => true
| (S x) => oddm x
end
with
oddm (v:nat): bool :=
match v with
| O => false
| (S x) => evenm x
end.

Fixpoint even (v:nat): bool :=
match v with
  | 0 => true
  | S x => match odd x with
             | true => true
             | false => false
           end
end
with odd (v:nat): bool :=
match v with
  | 0 => false
  | S x => match even x with
             | true => true
             | false => false
           end
end.

(** Initialisation of proof process *)
Lemma model_nat_0: model_nat 0 = (Term id_0 nil).
Proof.
auto.
Qed.

Lemma model_nat_S: forall (u1: nat), model_nat (S u1) = (Term id_S ((model_nat u1)::nil)).
Proof.
auto.
Qed.

Lemma model_bool_true: model_bool true = (Term id_true nil).
Proof.
auto.
Qed.

Lemma model_bool_false: model_bool false = (Term id_false nil).
Proof.
auto.
Qed.

Hint Rewrite model_bool_true model_bool_false : model_bool.
Hint Rewrite model_nat_0 model_nat_S : model_nat.

Ltac rewrite_model := autorewrite with model_bool model_nat.


(************************************************************************)
(* Copyright (c) 2017, Ajay Kumar Eeralla <ae266@mail.missouri.edu>     *)
(*                   University of Missouri-Columbia.                   *)
(*                                                                      *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)

Load "ex7_8".
(** This library defines a theorem that states,
[[
For variables b1, b2, n1, n1', n2, n2', n3, n3', n4' : b1, b2, n1, n2, n3 ~ b1, b2, n1', n2, n3' ~ b1, b2, n4', n2', n3' ->
if b1 then n1 else (if b2 then <n2, n3> else <n1, n2 ,n3> ~ if not(b2 ) then (if b1 then n1' else <n1' , n2' , n3'>)
else (if b1' then n4' else < n2' , n3' >).
]]
*)

Theorem Example17: forall (n11  :nat) (n1  n2  n3 n1' n2' n3' n4' : nat),
[bol (Bvar n11) ; bol (Bvar (n11 + 1)); msg (N n1); msg (N n2); msg (N n3)] ~ [bol (Bvar n11) ; bol (Bvar (n11 + 1)); msg (N n1'); msg (N n2'); msg (N n3')] /\ [bol (Bvar n11); bol (Bvar (n11 + 1)); msg (N n1'); msg (N n2'); msg (N n3')] ~ [bol (Bvar n11) ; bol (Bvar (n11 + 1)); msg (N n4'); msg (N n2'); msg (N n3')] ->
[msg (ifm (Bvar n11) (N n1) (ifm  (Bvar (n11 + 1))  (pair  (N n2)  (N n3))  (pair ( pair  (N n1)  (N n2)  ) (N n3) )))  ] ~ [msg ( ifm (notb (Bvar (n11 + 1))) (ifm (Bvar n11) (N n1')  (pair  (pair (N n1')  (N n2')) (N n3'))) (ifm (Bvar n11) (N n4')  (pair (N n2')  (N n3'))))].

Proof. intros.
assert(H1:  (ifm (Bvar n11) (N n1) (ifm (Bvar (n11 + 1))   (pair  (N n2)  (N n3))  (pair ( pair  (N n1)  (N n2)  ) (N n3) ))) # (ifm (Bvar (n11 + 1)) (ifm (Bvar n11) (N n1) (pair  (N n2)  (N n3)) ) (ifm (Bvar n11) (N n1) (pair ( pair  (N n1)  (N n2)  ) (N n3) )))).
rewrite IFMORPH_M4 with (n1 := n11)  (m1 := (N n1)).
reflexivity.
assert (H2: (ifm (Bvar (n11 + 1)) (ifm (Bvar n11) (N n1) (pair (N n2) (N n3)) )
          (ifm (Bvar n11) (N n1)  (pair (pair (N n1) (N n2)) (N n3)) )) # (ifm (notb (Bvar (n11 + 1)) ) (ifm (Bvar n11) (N n1)  (pair (pair (N n1) (N n2)) (N n3)))(ifm (Bvar n11)(N n1) (pair (N n2) (N n3)) ))).
rewrite    Example16_M . reflexivity.

assert (H3 : [ bol (notb (Bvar (n11 + 1))); msg (ifm (Bvar n11) (N n1)  (pair (pair (N n1) (N n2)) (N n3)) )] ~ [ bol (notb (Bvar (n11 + 1))); msg (ifm (Bvar n11) (N n1')  (pair (pair (N n1') (N n2')) (N n3')) )]).
inversion H.
apply FUNCApp_negpos with (p :=2) in H0.
 unfold neg_at_pos in H0 ;unfold chkbol_os in H0 ; unfold getelt_at_pos in H0.
  simpl in H0.
apply FUNCApp_ifmnespair with (p1:=1) (p2:=3)(p3:=4) (p4:=5) in H0. unfold ifm_nespair in H0. unfold chkbol_os in H0. unfold getelt_at_pos in H0. unfold chkmsg_os in H0.  unfold pair_term_pos in H0. unfold pair_at_pos in H0. unfold getelt_at_pos in H0.  simpl in H0.
(********drop first five elements**************************)
aply_in 5 dropone_in H0.
apply H0.
assert (H5: [ bol (notb (Bvar (n11 + 1))); msg (ifm (Bvar n11) (N n1)  (pair (N n2) (N n3)) )] ~ [ bol (notb (Bvar (n11 + 1))); msg (ifm (Bvar n11) (N n4')  (pair  (N n2') (N n3')) )]).
inversion H.
assert(H5: [bol (Bvar n11); bol (Bvar (n11 + 1)); msg (N n1); msg (N n2); msg (N n3)] ~[bol (Bvar n11); bol (Bvar (n11 + 1)); msg (N n4');
       msg (N n2'); msg (N n3')]).
apply EQI_trans with (ml1 := [bol (Bvar n11); bol (Bvar (n11 + 1)); msg (N n1); msg (N n2); msg (N n3)]) (ml2 := [bol (Bvar n11); bol (Bvar (n11 + 1)); msg (N n1'); msg (N n2'); msg (N n3')]) (ml3:=  [bol (Bvar n11); bol (Bvar (n11 + 1)); msg (N n4'); msg (N n2'); msg (N n3')]).
apply H0.
apply H4.
apply FUNCApp_negpos with (p :=2)  in H5.
 unfold neg_at_pos in H5 . unfold chkbol_os in H5.  simpl in H5.
apply FUNCApp_ifmpair with (p1:=1)(p2:=3)(p3:=4)(p4:=5) in H5. unfold ifm_pair in H5. unfold chkbol_os in H5. unfold getelt_at_pos in H5. unfold chkmsg_os in H5. unfold pair_at_pos in H5.  simpl in H5.

(***drop first five elements***********)
aply_in 5 dropone_in H5.
apply H5.
assert (H6 : [bol (notb (Bvar (n11 + 1)));
      msg (ifm (Bvar n11) (N n1)  (pair  (pair (N n1) (N n2)) (N n3) ))] ~
     [bol (notb (Bvar (n11 + 1)));
     msg (ifm (Bvar n11) (N n1')   (pair  (pair (N n1') (N n2')) (N n3') ))] /\ [bol (notb (Bvar (n11 + 1)));
      msg (ifm (Bvar n11) (N n1)  (pair ( N n2) (N n3)))] ~
     [bol (notb (Bvar (n11 + 1)));
     msg (ifm (Bvar n11) (N n4')  (pair (N n2') (N n3')))]).
split.
apply H3. apply H5.
pose proof (IFBRANCH_M1).
assert(H7 : [bol (notb (Bvar (n11 + 1))); msg (ifm (notb (Bvar (n11 + 1))) (ifm (Bvar n11) (N n1)   (pair  (pair (N n1) (N n2)) (N n3) )) (ifm (Bvar n11) (N n1)  (pair ( N n2) (N n3))))]~
[bol (notb (Bvar (n11 + 1))) ; msg (ifm (notb (Bvar (n11 + 1))) (ifm (Bvar n11) (N n1')   (pair  (pair (N n1') (N n2')) (N n3') )) (ifm (Bvar n11) (N n4')  (pair ( N n2') (N n3'))))]).
apply IFBRANCH_M with (ml1 := []) (ml2 := [])(b := (notb (Bvar (n11 + 1)))) (b' := (notb (Bvar (n11 + 1)))) (x := (ifm (Bvar n11) (N n1) (pair  (pair (N n1) (N n2)) (N n3) ))) (x' := (ifm (Bvar n11) (N n1') (pair  (pair (N n1') (N n2')) (N n3') ) ))  (y := (ifm (Bvar n11) (N n1)  (pair ( N n2) (N n3))))(y':=(ifm (Bvar n11) (N n4')  (pair (N n2') (N n3')))) .
simpl. apply H3.
simpl. apply H5.
dropone_in H7.
rewrite Example16_M with (n:= (n11 + 1)) (m1 := (ifm (Bvar n11) (N n1)   (pair  (pair (N n1) (N n2)) (N n3) ))) in H7.
rewrite <- IFMORPH_M4 with  (m1 := (N n1))  in H7.
apply H7.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*                      SF_Normal.v                                   *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega Max.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Wave_as_SF.SF_Terms.
Require Import IntensionalLib.Wave_as_SF.SF_Tactics.
Require Import IntensionalLib.Wave_as_SF.SF_reduction.

Inductive status_val :=
| Active : status_val
| Passive : status_val
.

Fixpoint status M :=
match M with
| Ref _ => Active
| Op _ => Passive
| App (App (App (Op Node) M1) _ ) _ => status M1
| App M1 _ => status M1
end.

(* normal terms *)

Inductive normal : SF -> Prop :=
| nf_ref : forall n, normal (Ref n)
| nf_op : forall o, normal (Op o)
| nf_active : forall M1 M2, normal M1 -> normal M2 ->
                              status (App M1 M2) = Active ->
                              normal (App M1 M2)
| nf_compound : forall M1 M2, normal M1 -> normal M2 ->
                              compound (App M1 M2) -> normal (App M1 M2)
.

Hint Constructors normal.

Definition irreducible M (red:termred) := forall N, red M N -> False.

Lemma ref_irreducible : forall n, irreducible (Ref n) sf_seqred1.
Proof. intro n. red. split_all. inversion H; auto. Qed.

Lemma normal_is_irreducible:
forall M, normal M -> irreducible M sf_seqred1.
Proof.
intros M nor; induction nor; split_all.
(* 4 *)
eapply2 ref_irreducible.
(* 3 *)
red; split_all. inversion H.
(* 2 *)
intro. intro. inversion H0; subst; simpl in *; try discriminate.
(* 4 *)
eapply2 IHnor1.
(* 3 *)
eapply2 IHnor2.
(* 1 *)
intro. intro. inversion H0; subst; simpl in *; try (inversion H; fail).
eapply2 IHnor1.
eapply2 IHnor2.
Qed.

Theorem SF_progress : forall (M : SF), normal M \/ (exists N, sf_seqred1 M N) .
Proof.
induction M; try (inversion IHM); subst; split_all; eauto.
(* 1 *)
inversion IHM1; split_all. 2: right; inversion H; exist (App x M2).
inversion IHM2; split_all.  2:right; inversion H0; exist (App M1 x).
gen_case H M1. case o; try (right; eauto; fail); left; auto.
inversion H; subst.
(* 2 *)
left; auto.
eapply2 nf_active. gen_case H5 s. gen_case H5 s1. discriminate.
(* 1 *)
gen2_case H3 H5 s.
left; case o; auto.
gen2_case H3 H5 s1.
gen2_case H3 H5 o; try (right; eauto; fail).
inversion H3; subst. inversion H8.
inversion H7; subst. left; eapply2 nf_active.
right; eauto. left; eapply2 nf_active.
right; eauto. inversion H5.
(* 2 *)
inversion H9; subst; eauto.
(* 1 *)
inversion H5.
Qed.


From Coq Require Import Reals List Lia.
From Flocq Require Import Core.
Require Export Gappa_library.

Strategy 1000 [Generic_fmt.round].

Module Gappa_Private.

(* factor an integer into odd*2^e *)
Definition float2_of_pos x :=
  let fix aux (m : positive) e { struct m } :=
    match m with
    | xO p => aux p (Z.succ e)
    | _ => Float2 (Zpos m) e
    end in
  aux x Z0.

Lemma float2_of_pos_correct :
  forall x, float2R (float2_of_pos x) = IZR (Zpos x).
Proof.
intros x.
unfold float2_of_pos.
rewrite <- (Rmult_1_r (IZR (Zpos x))).
change (IZR (Zpos x) * 1)%R with (float2R (Float2 (Zpos x) 0%Z)).
generalize 0%Z.
induction x ; intros e ; try apply refl_equal.
rewrite IHx.
unfold float2R.
simpl.
replace (Zpos (xO x)) with (Zpos x * 2)%Z.
exact (Gappa_round_aux.float2_shift_p1 _ _).
now rewrite Zmult_comm.
Qed.

Definition compact_float2 m e :=
  match m with
  | Z0 => Float2 0 0
  | Zpos p =>
    match float2_of_pos p with
    | Float2 m e1 => Float2 m (e + e1)
    end
  | Zneg p =>
    match float2_of_pos p with
    | Float2 m e1 => Float2 (-m) (e + e1)
    end
  end.

Lemma compact_float2_correct :
  forall m e, float2R (compact_float2 m e) = float2R (Float2 m e).
Proof.
unfold float2R, F2R. simpl.
intros [|m|m] e ; simpl.
now rewrite 2!Rmult_0_l.
rewrite <- (float2_of_pos_correct m).
destruct (float2_of_pos m) as (m1, e1).
simpl.
rewrite Zplus_comm.
now rewrite bpow_plus, <- Rmult_assoc.
change (IZR (Zneg m)) with (- IZR (Zpos m))%R.
rewrite <- (float2_of_pos_correct m).
destruct (float2_of_pos m) as (m1, e1).
simpl.
rewrite Zplus_comm.
rewrite bpow_plus, <- Rmult_assoc.
now rewrite opp_IZR, Ropp_mult_distr_l_reverse.
Qed.

Definition float10_of_pos x :=
  let fix aux (n : nat) m e { struct n } :=
    match n, m with
    | S n, xO p =>
      let (q,r) := Z.pos_div_eucl p 5 in
      match r, q with
      | Z0, Zpos q => aux n q (Z.succ e)
      | _, _ => Float10 (Zpos m) e
      end
    | _, _ => Float10 (Zpos m) e
    end in
  aux (Digits.digits2_Pnat x) x Z0.

Lemma float10_of_pos_correct :
  forall x, float10R (float10_of_pos x) = IZR (Zpos x).
Proof.
intros x.
unfold float10_of_pos.
rewrite <- (Rmult_1_r (IZR (Zpos x))).
change (IZR (Zpos x) * 1)%R with (float10R (Float10 (Zpos x) 0%Z)).
generalize (Digits.digits2_Pnat x) 0%Z.
intros n. revert x.
induction n ; intros m e. easy.
destruct m as [m|m|] ; try easy.
generalize (Z.pos_div_eucl_eq m 5 eq_refl).
destruct Z.pos_div_eucl as [q r].
intros Hm.
destruct r as [|r|r] ; try easy.
destruct q as [|q|q] ; try easy.
rewrite IHn.
rewrite Pos2Z.pos_xO, Hm.
replace (2 * (Zpos q * 5 + 0))%Z with (Zpos q * 10)%Z by ring.
unfold float10R, F2R. simpl.
unfold Z.succ.
rewrite Zplus_comm.
rewrite bpow_plus, <- Rmult_assoc.
change (Zpos (q * 10)) with (Zpos q * 10)%Z.
now rewrite mult_IZR.
Qed.

Definition compact_float10 m e :=
  match m with
  | Z0 => Float10 0 0
  | Zpos p =>
    match float10_of_pos p with
    | Float10 m e1 => Float10 m (e + e1)
    end
  | Zneg p =>
    match float10_of_pos p with
    | Float10 m e1 => Float10 (-m) (e + e1)
    end
  end.

Lemma compact_float10_correct :
  forall m e, float10R (compact_float10 m e) = float10R (Float10 m e).
Proof.
unfold float10R, F2R. simpl.
intros [|m|m] e ; simpl.
now rewrite 2!Rmult_0_l.
rewrite <- (float10_of_pos_correct m).
destruct (float10_of_pos m) as [m1 e1].
simpl.
rewrite Zplus_comm.
now rewrite bpow_plus, <- Rmult_assoc.
change (IZR (Zneg m)) with (- IZR (Zpos m))%R.
rewrite <- (float10_of_pos_correct m).
destruct (float10_of_pos m) as [m1 e1].
simpl.
rewrite Zplus_comm.
rewrite bpow_plus, <- Rmult_assoc.
now rewrite opp_IZR, Ropp_mult_distr_l_reverse.
Qed.

Inductive UnaryOp : Set :=
  | uoNeg | uoSqrt | uoAbs | uoInv.

Inductive BinaryOp : Set :=
  | boAdd | boSub | boMul | boDiv.

Inductive Format : Set :=
  | fFixed : Z -> Format
  | fFloat : Z -> Z -> Format
  | fFloatx : Z -> Format.

Inductive Mode : Set :=
  | mRndDN
  | mRndUP
  | mRndZR
  | mRndNE
  | mRndNA.

(* represent an expression on real numbers *)
Inductive RExpr :=
  | reUnknown : positive -> RExpr
  | reInteger : Z -> RExpr
  | reFloat2 : Z -> Z -> RExpr
  | reFloat10 : Z -> Z -> RExpr
  | reUnary : UnaryOp -> RExpr -> RExpr
  | reBinary : BinaryOp -> RExpr -> RExpr -> RExpr
  | reBpow2 : Z -> RExpr
  | reBpow10 : Z -> RExpr
  | rePow2 : Z -> RExpr
  | rePow10 : Z -> RExpr
  | reINR : positive -> RExpr
  | reIZR : Z -> RExpr
  | reRound : Format -> Mode -> RExpr -> RExpr.

Scheme Equality for positive.
Scheme Equality for Z.
Scheme Equality for UnaryOp.
Scheme Equality for BinaryOp.
Scheme Equality for Format.
Scheme Equality for Mode.
Scheme Equality for RExpr.

(* represent an atomic proposition *)
Inductive RAtom :=
  | raBound : option RExpr -> RExpr -> option RExpr -> RAtom
  | raRel : RExpr -> RExpr -> RExpr -> RExpr -> RAtom
  | raLe : RExpr -> RExpr -> RAtom
  | raEq : RExpr -> RExpr -> RAtom
  | raGeneric : Format -> RExpr -> RAtom
  | raFormat : Format -> RExpr -> RAtom.

Inductive RTree :=
  | rtTrue : RTree
  | rtFalse : RTree
  | rtAtom : RAtom -> RTree
  | rtNot : RTree -> RTree
  | rtAnd : RTree -> RTree -> RTree
  | rtOr : RTree -> RTree -> RTree
  | rtImpl : RTree -> RTree -> RTree.

Section Convert.

Definition convert_exp (f : Format) : Z -> Z :=
  match f with
  | fFloat e p => FLT_exp e p
  | fFloatx p => FLX_exp p
  | fFixed e => FIX_exp e
  end.

Definition convert_format (f : Format) : R -> Prop :=
  match f with
  | fFloat e p => FLT_format radix2 e p
  | fFloatx p => FLX_format radix2 p
  | fFixed e => FIX_format radix2 e
  end.

Definition convert_mode (m : Mode) : R -> Z :=
  match m with
  | mRndZR => Ztrunc
  | mRndDN => Zfloor
  | mRndUP => Zceil
  | mRndNE => rndNE
  | mRndNA => rndNA
  end.

Variable unknown_values : list R.

(* convert to an expression on real numbers *)
Fixpoint convert_expr (t : RExpr) : R :=
  match t with
  | reUnknown x =>
    nth (nat_of_P x) (R0 :: unknown_values) R0
  | reInteger x => IZR x
  | reFloat2 x y => float2R (Float2 x y)
  | reFloat10 x y => float10R (Float10 x y)
  | reUnary o x =>
    match o with
    | uoNeg  => Ropp
    | uoSqrt => sqrt
    | uoAbs  => Rabs
    | uoInv  => Rinv
    end (convert_expr x)
  | reBinary o x y =>
    match o with
    | boAdd => Rplus
    | boSub => Rminus
    | boMul => Rmult
    | boDiv => Rdiv
    end (convert_expr x) (convert_expr y)
  | reBpow2 x =>
    bpow radix2 x
  | reBpow10 x =>
    bpow radix10 x
  | rePow2 x =>
    powerRZ 2%R x
  | rePow10 x =>
    powerRZ 10%R x
  | reINR x =>
    INR (nat_of_P x)
  | reIZR x =>
    IZR x
  | reRound f m x =>
    Generic_fmt.round radix2 (convert_exp f) (convert_mode m) (convert_expr x)
  end.

(* convert to an atomic proposition *)
Definition convert_atom (a : RAtom) : Prop :=
  match a with
  | raBound None _ None => True
  | raBound (Some l) e None => (convert_expr l <= convert_expr e)%R
  | raBound None e (Some u) => (convert_expr e <= convert_expr u)%R
  | raBound (Some l) e (Some u) => (convert_expr l <= convert_expr e <= convert_expr u)%R
  | raRel er ex l u => exists eps : R, (convert_expr l <= eps <= convert_expr u)%R /\ (convert_expr er = convert_expr ex * (1 + eps))%R
  | raLe x y => (convert_expr x <= convert_expr y)%R
  | raEq x y => (convert_expr x = convert_expr y)%R
  | raGeneric f x => generic_format radix2 (convert_exp f) (convert_expr x)
  | raFormat f x => convert_format f (convert_expr x)
  end.

Fixpoint convert_tree (t : RTree) : Prop :=
  match t with
  | rtTrue => True
  | rtFalse => False
  | rtAtom a => convert_atom a
  | rtNot t => not (convert_tree t)
  | rtAnd t1 t2 => (convert_tree t1) /\ (convert_tree t2)
  | rtOr t1 t2 => (convert_tree t1) \/ (convert_tree t2)
  | rtImpl t1 t2 => (convert_tree t1) -> (convert_tree t2)
  end.

Lemma decidable_atom :
  forall a, { convert_atom a } + { not (convert_atom a) }.
Proof with auto with typeclass_instances.
intros [[l|] e [u|]|x y l u|x y|x y|fmt x|fmt x] ; simpl.
destruct (Rle_lt_dec (convert_expr l) (convert_expr e)) as [Hl|Hl].
destruct (Rle_lt_dec (convert_expr e) (convert_expr u)) as [Hu|Hu].
now left ; split.
right.
intros (_,H).
now apply Rlt_not_le with (1 := Hu).
right.
intros (H,_).
now apply Rlt_not_le with (1 := Hl).
destruct (Rle_lt_dec (convert_expr l) (convert_expr e)) as [Hl|Hl].
now left.
right.
now apply Rlt_not_le.
destruct (Rle_lt_dec (convert_expr e) (convert_expr u)) as [Hu|Hu].
now left.
right.
now apply Rlt_not_le.
now left.
destruct (Req_EM_T (convert_expr y) 0) as [Zy|Zy].
destruct (Req_EM_T (convert_expr x) 0) as [Zx|Zx].
destruct (Rle_lt_dec (convert_expr l) (convert_expr u)) as [H|H].
left.
exists (convert_expr l).
split.
split.
apply Rle_refl.
exact H.
now rewrite Zy, Rmult_0_l.
right.
intros (eps,((H1,H2),_)).
apply Rlt_not_le with (1 := H).
now apply Rle_trans with eps.
right.
intros (eps,(_,H')).
now rewrite Zy, Rmult_0_l in H'.
destruct (Rle_lt_dec (convert_expr l) (convert_expr x / convert_expr y - 1)) as [Hl|Hl].
destruct (Rle_lt_dec (convert_expr x / convert_expr y - 1) (convert_expr u)) as [Hu|Hu].
left.
exists (convert_expr x / convert_expr y - 1)%R.
split.
now split.
now field.
right.
intros (eps,((_,H),H')).
apply Rlt_not_le with (1 := Hu).
rewrite H'.
now replace (convert_expr y * (1 + eps) / convert_expr y - 1)%R with eps ; [idtac | field].
right.
intros (eps,((H,_),H')).
apply Rlt_not_le with (1 := Hl).
rewrite H'.
now replace (convert_expr y * (1 + eps) / convert_expr y - 1)%R with eps ; [idtac | field].
destruct (Rle_lt_dec (convert_expr x) (convert_expr y)) as [H|H].
now left.
right.
now apply Rlt_not_le.
apply Req_EM_T.
apply Req_EM_T.
destruct fmt as [e|e p|p].
simpl.
destruct (Req_EM_T (convert_expr x) (round radix2 (FIX_exp e) rndZR (convert_expr x))) as [H|H].
left.
apply FIX_format_generic.
rewrite H.
apply generic_format_round...
right.
contradict H.
apply sym_eq, round_generic...
now apply generic_format_FIX.
destruct (Z_lt_le_dec 0 p) as [Hp|Hp].
destruct (Req_EM_T (convert_expr x) (round radix2 (FLT_exp e p) rndZR (convert_expr x))) as [H|H].
left.
apply FLT_format_generic.
apply Hp.
rewrite H.
apply generic_format_round...
right.
contradict H.
apply sym_eq, round_generic...
now apply generic_format_FLT.
destruct p.
destruct (Req_EM_T (convert_expr x) 0) as [H|H].
left.
rewrite H.
exists (Float radix2 0 e).
apply sym_eq, F2R_0.
apply eq_refl.
apply Z.le_refl.
right.
intros ((xm,xe),H1,H2,H3).
simpl in H2.
assert (xm = Z0).
clear -H2 ; zify ; lia.
now rewrite H0, F2R_0 in H1.
now elim Hp.
right.
intros ((xm,xe),H1,H2,H3).
apply Zlt_not_le with (1 := H2).
apply Zabs_pos.
destruct (Z_lt_le_dec 0 p) as [Hp|Hp].
destruct (Req_EM_T (convert_expr x) (round radix2 (FLX_exp p) rndZR (convert_expr x))) as [H|H].
left.
apply FLX_format_generic.
apply Hp.
rewrite H.
apply generic_format_round...
right.
contradict H.
apply sym_eq, round_generic...
now apply generic_format_FLX.
destruct p.
destruct (Req_EM_T (convert_expr x) 0) as [H|H].
left.
rewrite H.
exists (Float radix2 0 0).
apply sym_eq, F2R_0.
apply eq_refl.
right.
intros ((xm,xe),H1,H2).
simpl in H2.
assert (xm = Z0).
clear -H2 ; zify ; lia.
now rewrite H0, F2R_0 in H1.
now elim Hp.
right.
intros ((xm,xe),H1,H2).
apply Zlt_not_le with (1 := H2).
apply Zabs_pos.
Qed.

Lemma decidable_tree :
  forall t, { convert_tree t } + { not (convert_tree t) }.
Proof.
induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2].
now left.
now right.
apply decidable_atom.
destruct Ht as [Ht|Ht].
now right.
now left.
destruct Ht1 as [Ht1|Ht1].
destruct Ht2 as [Ht2|Ht2].
now left ; split.
right.
now intros (_,H).
right.
now intros (H,_).
destruct Ht1 as [Ht1|Ht1].
left.
now left.
destruct Ht2 as [Ht2|Ht2].
left.
now right.
right.
now intros [H|H].
destruct Ht2 as [Ht2|Ht2].
left.
now intros _.
destruct Ht1 as [Ht1|Ht1].
right.
contradict Ht2.
now apply Ht2.
left.
now intros H.
Qed.

Fixpoint normalize_tree (t : RTree) (pos : bool) :=
  match t with
  | rtTrue => if pos then rtTrue else rtFalse
  | rtFalse => if pos then rtFalse else rtTrue
  | rtAtom a => if pos then t else rtNot t
  | rtNot t => normalize_tree t (negb pos)
  | rtImpl t1 t2 => (if pos then rtOr else rtAnd) (normalize_tree t1 (negb pos)) (normalize_tree t2 pos)
  | rtOr t1 t2 => (if pos then rtOr else rtAnd) (normalize_tree t1 pos) (normalize_tree t2 pos)
  | rtAnd t1 t2 => (if pos then rtAnd else rtOr) (normalize_tree t1 pos) (normalize_tree t2 pos)
  end.

Theorem normalize_tree_correct :
  forall t pos,
  convert_tree (normalize_tree t pos) <-> if pos then convert_tree t else not (convert_tree t).
Proof.
induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2] ;
  destruct pos ; split ; simpl ; try easy.
try (intros H ; now apply H).
apply (Ht false).
apply (Ht false).
intros H.
intros H'.
apply H'.
now apply (Ht true).
intros H.
apply (Ht true).
now destruct (decidable_tree t) as [H'|H'].
intros (H1,H2).
split.
now apply (Ht1 true).
now apply (Ht2 true).
intros (H1,H2).
split.
now apply (Ht1 true).
now apply (Ht2 true).
intros [H|H] (H1,H2).
now apply (Ht1 false).
now apply (Ht2 false).
specialize (Ht1 false).
specialize (Ht2 false).
intros H.
destruct (decidable_tree t1) as [H'|H'].
right.
apply Ht2.
contradict H.
now split.
left.
now apply Ht1.
intros [H|H].
left.
now apply (Ht1 true).
right.
now apply (Ht2 true).
intros [H|H].
left.
now apply (Ht1 true).
right.
now apply (Ht2 true).
intros (H1,H2) [H|H].
now apply (Ht1 false).
now apply (Ht2 false).
intros H.
split.
apply (Ht1 false).
contradict H.
now left.
apply (Ht2 false).
contradict H.
now right.
intros [H|H] H'.
now apply (Ht1 false) in H.
now apply (Ht2 true).
intros H.
destruct (decidable_tree t1) as [H'|H'].
right.
apply (Ht2 true).
now apply H.
left.
now apply (Ht1 false).
intros (H1,H2) H'.
apply (Ht1 true) in H1.
apply H' in H1.
now apply (Ht2 false).
intros H.
split.
destruct (decidable_tree t1) as [H'|H'].
now apply (Ht1 true).
now elim H.
apply (Ht2 false).
now contradict H.
Qed.

Fixpoint simplify_tree (t : RTree) :=
  match t with
  | rtNot rtTrue => rtFalse
  | rtNot rtFalse => rtTrue
  | rtAnd t1 t2 =>
    match simplify_tree t1, simplify_tree t2 with
    | rtTrue, t => t
    | rtFalse, _ => rtFalse
    | t, rtTrue => t
    | _, rtFalse => rtFalse
    | t1, t2 => rtAnd t1 t2
    end
  | rtOr t1 t2 =>
    match simplify_tree t1, simplify_tree t2 with
    | rtTrue, _ => rtTrue
    | rtFalse, t => t
    | _, rtTrue => rtTrue
    | t, rtFalse => t
    | t1, t2 => rtOr t1 t2
    end
  | _ => t
  end.

Theorem simplify_tree_correct :
  forall t,
  convert_tree t -> convert_tree (simplify_tree t).
Proof.
induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2] ; try easy.
destruct t ; try easy.
intros H.
now apply H.
intros (H1,H2).
specialize (Ht1 H1).
specialize (Ht2 H2).
simpl.
destruct (simplify_tree t1) ; try easy ; destruct (simplify_tree t2) ; try easy ; split ; easy.
intros [H|H].
specialize (Ht1 H).
simpl.
destruct (simplify_tree t1) ; try easy ; destruct (simplify_tree t2) ; try easy ; left ; easy.
specialize (Ht2 H).
simpl.
destruct (simplify_tree t1) ; try easy ; destruct (simplify_tree t2) ; try easy ; right ; easy.
Qed.

Section StableExpr.

Definition stable_expr f :=
  forall t, convert_expr (f t) = convert_expr t.

Variable chg_expr : RExpr -> RExpr.

(* apply a function recursively, starting from the leafs of an expression *)
Fixpoint transform_expr (t : RExpr) :=
  chg_expr
    match t with
    | reUnary o x => reUnary o (transform_expr x)
    | reBinary o x y => reBinary o (transform_expr x) (transform_expr y)
    | reRound f m x => reRound f m (transform_expr x)
    | _ => t
    end.

Theorem transform_expr_correct :
  stable_expr chg_expr ->
  stable_expr transform_expr.
Proof.
unfold stable_expr.
intros Hf t.
induction t ; simpl ; rewrite Hf ; simpl ; try easy.
now rewrite IHt.
now rewrite IHt1, IHt2.
now rewrite IHt.
Qed.

End StableExpr.

Definition stable_atom f :=
  forall a, convert_atom (f a) <-> convert_atom a.

Definition transform_atom_bound f a :=
  match a with
  | raBound (Some l) e (Some u) => raBound (Some (f l)) e (Some (f u))
  | raBound (Some l) e None => raBound (Some (f l)) e None
  | raBound None e (Some u) => raBound None e (Some (f u))
  | raRel er ex l u => raRel er ex (f l) (f u)
  | _ => a
  end.

Theorem transform_atom_bound_correct :
  forall f,
  stable_expr f ->
  stable_atom (transform_atom_bound (transform_expr f)).
Proof.
now intros f Hf [[l|] e [u|]|x y l u|x y|x y|fmt x|fmt x] ;
  simpl ; split ; repeat rewrite (transform_expr_correct _ Hf).
Qed.

Definition transform_atom_expr f a :=
  match a with
  | raBound l e u => raBound l (f e) u
  | raRel er ex l u => raRel (f er) (f ex) l u
  | raEq ex ey => raEq (f ex) (f ey)
  | raLe ex ey => raLe (f ex) (f ey)
  | raGeneric fmt e => raGeneric fmt (f e)
  | raFormat fmt e => raFormat fmt (f e)
  end.

Theorem transform_atom_expr_correct :
  forall f,
  stable_expr f ->
  stable_atom (transform_atom_expr (transform_expr f)).
Proof.
now intros f Hf [l e u|x y l u|x y|x y|fmt x|fmt x] ;
  simpl ; split ; repeat rewrite (transform_expr_correct _ Hf).
Qed.

Definition stable_tree f :=
  forall t, convert_tree (f t) <-> convert_tree t.

Section StableTree.

Variable chg_atom : RAtom -> RAtom.

Fixpoint transform_tree_atom (t : RTree) : RTree :=
  match t with
  | rtTrue => rtTrue
  | rtFalse => rtFalse
  | rtAtom a => rtAtom (chg_atom a)
  | rtNot t => rtNot (transform_tree_atom t)
  | rtAnd t1 t2 => rtAnd (transform_tree_atom t1) (transform_tree_atom t2)
  | rtOr t1 t2 => rtOr (transform_tree_atom t1) (transform_tree_atom t2)
  | rtImpl t1 t2 => rtImpl (transform_tree_atom t1) (transform_tree_atom t2)
  end.

Theorem transform_tree_atom_correct :
  stable_atom chg_atom ->
  stable_tree transform_tree_atom.
Proof.
intros Hs t.
induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2] ; simpl ; intuition.
now apply Hs.
now apply Hs.
Qed.

End StableTree.

Definition stable_atom_tree f :=
  forall a (pos : bool),
  (if pos then convert_atom a else not (convert_atom a)) ->
  convert_tree (f pos a).

Section StableTree'.

Variable chg_atom : bool -> RAtom -> RTree.

Fixpoint transform_tree_atom' (t : RTree) : RTree :=
  match t with
  | rtTrue => rtTrue
  | rtFalse => rtFalse
  | rtAtom a => chg_atom true a
  | rtNot (rtAtom a) => chg_atom false a
  | rtAnd t1 t2 => rtAnd (transform_tree_atom' t1) (transform_tree_atom' t2)
  | rtOr t1 t2 => rtOr (transform_tree_atom' t1) (transform_tree_atom' t2)
  | _ => t
  end.

Theorem transform_tree_atom'_correct :
  stable_atom_tree chg_atom ->
  forall t,
  convert_tree t -> convert_tree (transform_tree_atom' t).
Proof.
intros Hs t.
induction t as [| |a|t Ht|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2|t1 Ht1 t2 Ht2] ; simpl ; intuition.
destruct t ; intuition.
Qed.

End StableTree'.

Definition compact_posfloat2 m e :=
  match compact_float2 m e with
  | Float2 m1 0 => reInteger m1
  | Float2 m1 e1 =>
    match m1 with
    | Zneg m1 => reUnary uoNeg (reFloat2 (Zpos m1) e1)
    | _ => reFloat2 m1 e1
    end
  end.

Lemma compact_posfloat2_correct :
  forall m e, convert_expr (compact_posfloat2 m e) = (IZR m * bpow radix2 e)%R.
Proof.
intros m e.
unfold compact_posfloat2.
generalize (compact_float2_correct m e).
destruct compact_float2 as [m' e'].
destruct e'.
unfold float2R, F2R. simpl.
now rewrite Rmult_1_r.
destruct m' as [|m'|m'] ; try easy.
simpl.
now rewrite <- Gappa_dyadic.Fopp2_correct.
destruct m' as [|m'|m'] ; try easy.
simpl.
now rewrite <- Gappa_dyadic.Fopp2_correct.
Qed.

Definition compact_posfloat10 m e :=
  match compact_float10 m e with
  | Float10 m1 0 => reInteger m1
  | Float10 m1 e1 =>
    match m1 with
    | Zneg m1 => reUnary uoNeg (reFloat10 (Zpos m1) e1)
    | _ => reFloat10 m1 e1
    end
  end.

Lemma compact_posfloat10_correct :
  forall m e, convert_expr (compact_posfloat10 m e) = (IZR m * bpow radix10 e)%R.
Proof.
intros m e.
unfold compact_posfloat10.
generalize (compact_float10_correct m e).
destruct compact_float10 as [m' e'].
destruct e'.
unfold float10R, F2R. simpl.
now rewrite Rmult_1_r.
destruct m' as [|m'|m'] ; try easy.
simpl. unfold float10R, F2R. simpl.
now rewrite Ropp_mult_distr_l.
destruct m' as [|m'|m'] ; try easy.
simpl. unfold float10R, F2R. simpl.
now rewrite Ropp_mult_distr_l.
Qed.

(* transform INR and IZR into real integers, change a/b and a*2^b into floats *)
Definition gen_float_func t :=
  match t with
  | reUnary uoNeg (reInteger (Zpos x)) =>
    reInteger (Zneg x)
  | reBinary boDiv (reInteger x) (reInteger (Zpos y)) =>
    match float2_of_pos y with
    | Float2 1 (Zpos y') => compact_posfloat2 x (Zneg y')
    | _ => t
    end
  | reBinary boMul (reInteger x) (reBpow2 y) =>
    compact_posfloat2 x y
  | reBinary boMul (reInteger x) (reBpow10 y) =>
    compact_posfloat10 x y
  | reBinary boMul (reInteger x) (rePow2 y) =>
    compact_posfloat2 x y
  | reBinary boMul (reInteger x) (rePow10 y) =>
    compact_posfloat10 x y
  | reINR x =>
    reInteger (Zpos x)
  | reIZR x =>
    reInteger x
  | _ => t
  end.

Lemma gen_float_prop :
  stable_expr gen_float_func.
Proof.
intros [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try apply refl_equal.
(* unary ops *)
destruct o ; try apply refl_equal.
destruct x ; try apply refl_equal.
destruct z ; apply refl_equal.
(* binary ops *)
destruct o ; try apply refl_equal ;
  destruct x ; try apply refl_equal ;
  destruct y ; try apply refl_equal.
(* . x * 2^y *)
apply compact_posfloat2_correct.
(* . x * 10^y *)
apply compact_posfloat10_correct.
(* . x * 2^y *)
simpl.
rewrite <- (bpow_powerRZ radix2).
apply compact_posfloat2_correct.
(* . x * 10^y *)
simpl.
rewrite <- (bpow_powerRZ radix10).
apply compact_posfloat10_correct.
(* . x / 2*2*2*2 *)
destruct z0 ; try apply refl_equal.
generalize (float2_of_pos_correct p).
simpl.
destruct (float2_of_pos p) as ([|[m|m|]|m], [|e|e]) ; intros H ; try apply refl_equal.
rewrite compact_posfloat2_correct.
rewrite <- H.
unfold float2R, F2R. simpl.
now rewrite Rmult_1_l.
(* INR *)
simpl.
rewrite <- positive_nat_Z.
apply sym_eq, INR_IZR_INZ.
Qed.

(* remove pending powerRZ *)
Definition clean_pow_func t :=
  match t with
  | reBpow2 x => reFloat2 1 x
  | reBpow10 x => reFloat10 1 x
  | rePow2 x => reFloat2 1 x
  | rePow10 x => reFloat10 1 x
  | _ => t
  end.

Lemma clean_pow_prop :
  stable_expr clean_pow_func.
Proof.
intros [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try apply refl_equal.
apply (F2R_bpow radix2 x).
apply (F2R_bpow radix10 x).
simpl.
unfold float2R.
rewrite F2R_bpow.
apply bpow_powerRZ.
simpl.
unfold float10R.
rewrite F2R_bpow.
apply bpow_powerRZ.
Qed.

(* compute on constant terms, so that they are hopefully represented by a single float *)
Definition merge_float2_aux m e :=
  match compact_float2 m e with
  | Float2 m1 e1 => reFloat2 m1 e1
  end.

Definition merge_float2_func t :=
  match t with
  | reInteger x => merge_float2_aux x 0
  | reUnary uoNeg (reFloat2 x y) => merge_float2_aux (- x) y
  | reBinary boMul (reFloat2 x1 y1) (reFloat2 x2 y2) => merge_float2_aux (x1 * x2) (y1 + y2)
  | reFloat2 x y => merge_float2_aux x y
  | _ => t
  end.

Lemma merge_float2_prop :
  stable_expr merge_float2_func.
Proof.
assert (forall m e, convert_expr (merge_float2_aux m e) = convert_expr (reFloat2 m e)).
intros.
unfold merge_float2_aux.
generalize (compact_float2_correct m e).
now destruct (compact_float2 m e).
(* . *)
intros [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try apply refl_equal ; try exact (H x _).
(* integer *)
simpl.
unfold merge_float2_aux.
generalize (compact_float2_correct x 0).
rewrite <- (Rmult_1_r (IZR x)).
now destruct (compact_float2 x 0).
(* unary ops *)
destruct o ; try apply refl_equal.
destruct x ; try apply refl_equal.
simpl.
rewrite H.
now rewrite <- Gappa_dyadic.Fopp2_correct.
(* binary ops *)
destruct o ; try apply refl_equal.
destruct x ; try apply refl_equal.
destruct y ; try apply refl_equal.
simpl.
rewrite H.
now rewrite <- Gappa_dyadic.Fmult2_correct.
Qed.

(* change /a into 1/a *)
Definition remove_inv_func t :=
  match t with
  | reUnary uoInv x => reBinary boDiv (reInteger 1) x
  | _ => t
  end.

Lemma remove_inv_prop :
  stable_expr remove_inv_func.
Proof.
intros [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try apply refl_equal.
destruct o ; try apply refl_equal.
exact (Rmult_1_l _).
Qed.

Definition get_float2_bound b := transform_expr merge_float2_func (transform_expr clean_pow_func
  (transform_expr gen_float_func (transform_expr remove_inv_func b))).

Lemma get_float2_bound_correct :
  stable_expr get_float2_bound.
Proof.
intros b.
unfold get_float2_bound.
rewrite (transform_expr_correct _ merge_float2_prop).
rewrite (transform_expr_correct _ clean_pow_prop).
rewrite (transform_expr_correct _ gen_float_prop).
now rewrite (transform_expr_correct _ remove_inv_prop).
Qed.

Definition change_abs_func a :=
  match a with
  | raLe (reUnary uoAbs u as u') v => raBound (Some (reFloat2 0 0)) u' (Some v)
  | _ => a
  end.

Lemma change_abs_prop :
  stable_atom change_abs_func.
Proof.
intros [l v u|x y l u|v w|v w|f x|f x] ; try easy.
destruct v as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try easy.
destruct o ; try easy.
split.
now intros (_,H).
split.
replace (convert_expr (reFloat2 0 0)) with R0.
apply Rabs_pos.
apply eq_sym, Rmult_0_l.
exact H.
Qed.

Definition change_le_func a :=
  match a with
  | raLe x y =>
    match get_float2_bound x with
    | reFloat2 _ _ as x => raBound (Some x) y None
    | _ =>
      match get_float2_bound y with
      | reFloat2 _ _ as y => raBound None x (Some y)
      | _ => a
      end
    end
  | _ => a
  end.

Lemma change_le_prop :
  stable_atom change_le_func.
Proof.
intros [l v u|x y l u|v w|v w|f x|f x] ; try easy.
simpl.
assert (Hv := get_float2_bound_correct v).
assert (Hw := get_float2_bound_correct w).
destruct (get_float2_bound v) as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ;
  destruct (get_float2_bound w) as [x'|x'|x' y'|x' y'|o' x'|o' x' y'|x'|x'|x'|x'|x'|x'|f' m' x'] ;
  try easy ; try (now rewrite <- Hw) ; now rewrite <- Hv.
Qed.

Lemma change_rel_aux:
  forall x y b, (0 <= b /\ Rabs (x - y) <= b * Rabs y)%R <-> (exists eps, -b <= eps <= b /\ x = y * (1 + eps))%R.
Proof.
intros x y b.
split.
(* . *)
intros (H1, H2).
destruct (Req_dec y 0) as [Hy|Hy].
exists 0%R.
repeat split.
rewrite <- Ropp_0.
now apply Ropp_le_contravar.
apply H1.
rewrite Hy, Rmult_0_l.
destruct (Req_dec x 0) as [Hx|Hx] ; try exact Hx.
elim Rabs_no_R0 with (1 := Hx).
apply Rle_antisym.
now rewrite Hy, Rminus_0_r, Rabs_R0, Rmult_0_r in H2.
apply Rabs_pos.
exists ((x - y) / y)%R.
split.
2: now field.
apply Rabs_def2b.
apply Rmult_le_reg_l with (Rabs y).
now apply Rabs_pos_lt.
rewrite <- Rabs_mult.
replace (y * ((x - y) / y))%R with (x - y)%R by now field.
now rewrite Rmult_comm.
(* . *)
intros (eps, (H1, H2)).
repeat split.
destruct (Rle_or_lt 0 b) as [H|H] ; try exact H.
apply Ropp_le_cancel.
apply Rle_trans with b.
now apply Rle_trans with eps.
apply Rlt_le.
now rewrite Ropp_0.
rewrite H2.
replace (y * (1 + eps) - y)%R with (eps * y)%R by ring.
rewrite Rabs_mult.
apply Rmult_le_compat_r.
apply Rabs_pos.
unfold Rabs.
destruct (Rcase_abs eps) as [H|H].
apply Ropp_le_cancel.
now rewrite Ropp_involutive.
apply H1.
Qed.

Definition change_rel_func a :=
  match a with
  | raLe (reUnary uoAbs (reBinary boSub er ex)) (reBinary boMul u (reUnary uoAbs ex')) =>
    if RExpr_beq ex ex' then
      match get_float2_bound u with
      | reFloat2 (Zpos m) e => raRel er ex (reFloat2 (Zneg m) e) (reFloat2 (Zpos m) e)
      | _ => a
      end
    else a
  | _ => a
  end.

Lemma change_rel_prop :
  stable_atom change_rel_func.
Proof.
unfold change_rel_func.
intros [l v u|x y l u|v w|v w|f x|f x] ; try easy.
destruct v as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try easy.
destruct o ; try easy.
destruct x as [x|x|x y|x y|o x|o x y|x|x|x|x|x|x|f m x] ; try easy.
destruct o ; try easy.
destruct w as [u|u|u v|u v|o u|o u v|u|u|u|u|u|u|f m u] ; try easy.
destruct o ; try easy.
destruct v as [v|v|v w|v w|o v|o v w|v|v|v|v|v|v|f m v] ; try easy.
destruct o ; try easy.
case_eq (RExpr_beq y v) ; try easy.
intros Hb.
rewrite <- internal_RExpr_dec_bl with (1 := Hb).
assert (H := get_float2_bound_correct u).
destruct (get_float2_bound u) as [u1|u1|m e|u1 u2|o u1|o u1 u2|u1|u1|u1|u1|u1|u1|f u1] ; try easy.
destruct m as [|m|m] ; try easy.
simpl in H |- *.
change (Float2 (Zneg m) e) with (Gappa_dyadic.Fopp2 (Float2 (Zpos m) e)).
rewrite Gappa_dyadic.Fopp2_correct.
rewrite H.
split ; intro H'.
now apply <- change_rel_aux.
apply -> change_rel_aux.
split.
rewrite <- H.
now apply (Gappa_dyadic.Fpos0_correct (Float2 (Zpos m) e)).
exact H'.
Qed.

Definition change_format_func (pos : bool) a :=
  let a' :=
    match a with
    | raGeneric (fFixed _ as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x
    | raGeneric (fFloat _ (Zpos _) as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x
    | raGeneric (fFloatx (Zpos _) as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x
    | raFormat (fFixed _ as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x
    | raFormat (fFloat _ (Zpos _) as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x
    | raFormat (fFloatx (Zpos _) as fmt) x => if pos then raEq x (reRound fmt mRndNE x) else raEq (reRound fmt mRndNE x) x
    | _ => a
    end in
  if pos then rtAtom a' else rtNot (rtAtom a').

Lemma change_format_prop :
  stable_atom_tree change_format_func.
Proof.
unfold change_format_func.
intros [l v u|x y l u|v w|v w|[em|em [|p|p]|[|p|p]] x|[em|em [|p|p]|[|p|p]] x] pos ; try (case pos ; easy) ; simpl ; intros H.
destruct pos ; simpl.
apply sym_eq, round_generic.
apply valid_rnd_N.
exact H.
contradict H.
rewrite <- H.
apply generic_format_round.
apply FIX_exp_valid.
apply valid_rnd_N.
destruct pos ; simpl.
apply sym_eq, round_generic.
apply valid_rnd_N.
exact H.
contradict H.
rewrite <- H.
apply generic_format_round.
now apply FLT_exp_valid.
apply valid_rnd_N.
destruct pos ; simpl.
apply sym_eq, round_generic.
apply valid_rnd_N.
exact H.
contradict H.
rewrite <- H.
apply generic_format_round.
now apply FLX_exp_valid.
apply valid_rnd_N.
destruct pos ; simpl.
apply sym_eq, round_generic.
apply valid_rnd_N.
now apply generic_format_FIX.
contradict H.
rewrite <- H.
apply FIX_format_generic.
apply generic_format_round.
apply FIX_exp_valid.
apply valid_rnd_N.
destruct pos ; simpl.
apply sym_eq, round_generic.
apply valid_rnd_N.
apply generic_format_FLT.
exact H.
contradict H.
rewrite <- H.
apply FLT_format_generic.
easy.
apply generic_format_round.
now apply FLT_exp_valid.
apply valid_rnd_N.
destruct pos ; simpl.
apply sym_eq, round_generic.
apply valid_rnd_N.
apply generic_format_FLX.
exact H.
contradict H.
rewrite <- H.
apply FLX_format_generic.
easy.
apply generic_format_round.
now apply FLX_exp_valid.
apply valid_rnd_N.
Qed.

Definition remove_unknown_func (pos : bool) a :=
  match a with
  | raBound l _ u =>
    match l with
    | Some (reFloat2 _ _)
    | None =>
      match u with
      | Some (reFloat2 _ _)
      | None => if pos then rtAtom a else rtNot (rtAtom a)
      | _ => rtTrue
      end
    | _ => rtTrue
    end
  | raRel _ _ (reFloat2 _ _) (reFloat2 _ _) => if pos then rtAtom a else rtNot (rtAtom a)
  | raEq _ _ => if pos then rtAtom a else rtNot (rtAtom a)
  | _ => rtTrue
  end.

Lemma remove_unknown_prop :
  stable_atom_tree remove_unknown_func.
Proof.
intros [[l|] v [u|]|x y l u|v w|v w|f x|f x] pos ; try (case pos ; easy) ; simpl ; intros H.
destruct l as [xl|xl|xl yl|xl yl|ol xl|ol xl yl|xl|xl|xl|xl|xl|xl|fl xl] ; try easy.
destruct u as [xu|xu|xu yu|xu yu|ou xu|ou xu yu|xu|xu|xu|xu|xu|xu|fu xu] ; try easy.
now destruct pos.
destruct l as [l|l|l l'|l l'|o l|o l l'|l|l|l|l|l|l|f l] ; try easy.
now destruct pos.
destruct u as [u|u|u u'|u u'|o u|o u u'|u|u|u|u|u|u|f u] ; try easy.
now destruct pos.
destruct l as [l|l|l l'|l l'|o l|o l l'|l|l|l|l|l|l|f l] ; try easy.
destruct u as [u|u|u u'|u u'|o u|o u u'|u|u|u|u|u|u|f u] ; try easy.
now destruct pos.
Qed.

End Convert.

Inductive Transform :=
  | trAtom (f : RAtom -> RAtom) : (forall uv, stable_atom uv f) -> Transform
  | trLeaf (f : bool -> RAtom -> RTree) : (forall uv, stable_atom_tree uv f) -> Transform
  | trBound (f : RExpr -> RExpr) : (forall uv, stable_expr uv f) -> Transform
  | trExpr (f : RExpr -> RExpr) : (forall uv, stable_expr uv f) -> Transform
  | trTree (f : RTree -> RTree) : (forall uv t, convert_tree uv t -> convert_tree uv (f t)) -> Transform.

Definition transform_once tr t :=
  match tr with
  | trAtom f _ => transform_tree_atom f t
  | trLeaf f _ => transform_tree_atom' f t
  | trBound f _ => transform_tree_atom (transform_atom_bound (transform_expr f)) t
  | trExpr f _ => transform_tree_atom (transform_atom_expr (transform_expr f)) t
  | trTree f _ => f t
  end.

Theorem transform_once_correct :
  forall uv tr t,
  convert_tree uv t ->
  convert_tree uv (transform_once tr t).
Proof.
intros uv [f Hf|f Hf|f Hf|f Hf|f Hf] t Ht ; simpl.
now apply transform_tree_atom_correct.
now apply transform_tree_atom'_correct.
apply transform_tree_atom_correct with (2 := Ht).
now apply transform_atom_bound_correct.
apply transform_tree_atom_correct with (2 := Ht).
now apply transform_atom_expr_correct.
now apply Hf.
Qed.

Definition transform :=
  fold_left (fun v t => transform_once t v).

Theorem transform_correct :
  forall l uv t,
  convert_tree uv t ->
  convert_tree uv (transform l t).
Proof.
intros l uv t Ht.
rewrite <- (rev_involutive l).
induction (rev l) as [|h l' Hl] ; simpl.
easy.
unfold transform.
rewrite fold_left_app.
simpl.
apply transform_once_correct.
apply Hl.
Qed.

Definition trans :=
  trAtom change_rel_func change_rel_prop ::
  trAtom change_abs_func change_abs_prop ::
  trBound remove_inv_func remove_inv_prop ::
  trBound gen_float_func gen_float_prop ::
  trBound clean_pow_func clean_pow_prop ::
  trBound merge_float2_func merge_float2_prop ::
  trExpr remove_inv_func remove_inv_prop ::
  trExpr gen_float_func gen_float_prop ::
  trExpr clean_pow_func clean_pow_prop ::
  trAtom change_le_func change_le_prop ::
  trLeaf change_format_func change_format_prop ::
  trLeaf remove_unknown_func remove_unknown_prop ::
  trTree simplify_tree simplify_tree_correct ::
  nil.

Theorem prepare_goal :
  forall uv t,
  convert_tree uv (rtNot (transform trans (normalize_tree t false))) ->
  convert_tree uv t.
Proof.
intros uv t.
change (not (convert_tree uv (transform trans (normalize_tree t false))) -> convert_tree uv t).
intros H.
destruct (decidable_tree uv t) as [H'|H'].
easy.
contradict H.
apply transform_correct.
now apply normalize_tree_correct.
Qed.

End Gappa_Private.

Import Gappa_Private.

Declare ML Module "gappatac".

Ltac gappa_prepare :=
  intros ; fold rndNE rndNA in * ;
  gappa_quote ;
  let convert_apply t :=
    match goal with
    | |- (convert_tree ?uv ?g) => t uv g
    end in
  let rec generalize_all m n l :=
    match l with
    | List.nil => clear
    | List.cons ?h ?q =>
      match n with
      | O =>
        generalize h ; clear ; intro ;
        convert_apply ltac:(fun uv _ => generalize_all (S m) (S m) uv)
      | S ?n => generalize_all m n q
      end
    end in
  convert_apply ltac:(fun uv _ => generalize_all O O uv) ;
  convert_apply ltac:(fun uv g => refine (prepare_goal uv g _)) ;
  convert_apply ltac:(fun uv g => let g := eval vm_compute in g in change (convert_tree uv g)).

Ltac gappa := abstract (gappa_prepare ; gappa_internal).