(* Control Flag *)
Variant _flag: Set :=
| _break
| _continue
| _fail
.

(* Internals *)
Lemma _equal_f (A B : Type) (f g : A -> B)
      x
      (EQ: f = g)
  :
    f x = g x.
Proof.
  subst. apply eq_refl.
Qed.

Lemma _einit (P Q: Prop)
      (EQ: P = Q)
  :
    Q -> P.
Proof.
  subst. apply id.
Qed.

Ltac _ctx n :=
  match n with
  | O => apply f_equal
  | S ?m => apply _equal_f; _ctx m
  end.

Ltac __prw red_tac success :=
  cbn;
  tryif (let f := fresh "f" in
         evar (f:_flag);
         etransitivity;
         [red_tac f|
          match goal with
          | [f0:= ?f1: _flag|- _] =>
            match f1 with
            | _continue => subst f; __prw red_tac true
            | _break => subst f; reflexivity
            | _fail => fail 2
            end
          end])
  then
    idtac
  else
    match success with
    | true => reflexivity
    | false => fail
    end.

Ltac _prw k0 k1 X :=
  match X with
  | O => eapply _einit; [(k0; k1)|]
  | S ?n => _prw ltac:(k0; _ctx n) k1
  end.

Ltac _rwb k X :=
  match X with
  | O => k
  | _ => _rwb ltac:(fun f => ltac:(k f || (instantiate (f:=_break); eapply X; fail)))
  end.

Ltac _rwc k X :=
  match X with
  | O => k
  | _ => _rwc ltac:(fun f => ltac:(k f || (instantiate (f:=_continue); eapply X; fail)))
  end.

Ltac _rwa k X :=
  match X with
  | O => k
  | (?H, ?_f) => _rwa ltac:(fun f => ltac:(k f || (instantiate (f:=_f); eapply H; fail)))
  end.

(* Main Tactic *)
Ltac prw red_tac X := _prw ltac:(idtac) ltac:(__prw red_tac false) X.

Ltac rwbl X := _rwb ltac:(fun f => fail) X.
Ltac rwcl X := _rwc ltac:(fun f => fail) X.
Ltac rwal X := _rwa ltac:(fun f => fail) X.
Ltac rrw X _f := ltac:(fun f => instantiate (f:=_f); eapply X; fail).

Module TUTORIAL.
  Section FOO.
    (* Variables *)
    Variable A B C: Type.
    Variable a b c d: A.
    Variable x y z: B.
    Variable p q: C.

    Variable sim: A -> (nat * B) * C -> nat -> Prop.

    (* First Step: Prove Reduction Lemmas *)
    Hypothesis foo_red0: a = b.
    Hypothesis foo_red1: b = c.
    Hypothesis foo_red2: c = d.
    Hypothesis foo_red3: x = y.
    Hypothesis foo_red4: y = z.
    Hypothesis foo_red5: p = q.

    (* Second Step: Define Reduction Strategy (= red_tac) *)
    Ltac red_A f := (* f is a flag indicating continue/break/fail. Must set f before return *)
      ((instantiate (f:=_continue); apply foo_red0; fail) ||
       (instantiate (f:=_break); apply foo_red1; fail) ||
       (instantiate (f:=_fail); apply foo_red2; fail)).

    (* We also give more conenient syntax *)
    Ltac red_A' := (* = red_A *)
      rwal (foo_red0, _continue)
           (foo_red1, _break)
           (foo_red2, _break)
           0.

    Ltac red_B :=
      rwcl foo_red3
           foo_red4
           0.

    Ltac red_B' f := (* = red_B *)
      ((instantiate (f:=_continue); apply foo_red3; fail) ||
       (instantiate (f:=_continue); apply foo_red4; fail)).

    Ltac red_C :=
      rrw foo_red5 _break.

    Ltac red_C' := (* = red_C *)
      rwbl
        foo_red5
        0.

    Ltac red_C'' f := (* = red_C *)
      (instantiate (f:=_break); apply foo_red5; fail).

    (* Done. Let's use it! *)
    Lemma foo: forall (n: nat) (H: sim c ((n, z), q) n),
        sim a ((n, x), p) n.
    Proof.
      intros n H.
      (* goal = sim a (n, x, p) n *)
      prw red_B 2 2 1 0.
      (* prw [red_tac (= red_r)] [l_0 (= 2)] [l_1 (= 2)] [l_2 (= 1)] ... 0 =>
         - find the right l_0th term x0 (= ((n, x), p)) in the goal
         - find the right l_1th term x1 (=  (n, x)    ) in the   x0
         - find the right l_2th term x2 (=      x     ) in the   x1
         ...
         - the last argument must be 0. reduce the x2 following _red_r *)
      (* goal = sim a (n, z, p) n *)
      prw red_A 3 0.
      (* goal = sim c (n, z, p) n *)
      prw red_C 2 1 0.
      (* goal = sim c (n, z, q) n *)
      exact H.
    Qed.
  End FOO.
End TUTORIAL.


(*
(C) Copyright 2010, COQTAIL team

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

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

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

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

Require Import Cprop_base.
Require Import Cnorm.
Require Import Ctacfield.
Require Import Canalysis_def.

Open Scope C_scope.

(**********)
Lemma uniqueness_step1 : forall f (x v l1 l2 : C), v <> 0 ->
    limit1_in (fun u => (f (x + u) - f x) / u) (fun u => u <> 0 /\ exists h:R, h * u = v) l1 0 ->
    limit1_in (fun u => (f (x + u) - f x) / u) (fun u => u <> 0 /\ exists h:R, h * u = v) l2 0 ->
    l1 = l2.
Proof.
intros f x v l1 l2 v_neq Hl1 Hl2 ;
 apply (single_limit (fun u => (f (x + u) - f x) / u) (fun u => u <> 0 /\ exists h:R, h * u = v) l1 l2 0);
 try assumption.
 intros alp alp_pos.
  case (Rlt_le_dec (Cnorm v) alp) ; intro alp_bd.
  exists v ; repeat split.
  assumption.
  exists 1%R ; CusingR_f.
  unfold C_dist ; rewrite Cminus_0_r ; assumption.
  exists (v * ((alp / 2) / Cnorm v)) ; repeat split.
  unfold Cdiv ; repeat apply Cmult_integral_contrapositive_currified.
  assumption.
  apply IRC_neq_0_compat ; apply Rgt_not_eq ; assumption.
  apply Cinv_neq_0_compat ; apply IRC_neq_0_compat ;
  apply Rgt_not_eq ; lra.
  apply Cinv_neq_0_compat ; apply IRC_neq_0_compat ;
  apply Cnorm_no_R0 ; assumption.
  exists (2 * Cnorm v / alp)%R.
  unfold Rdiv, Cdiv.
  CusingR_f ; try split.
  apply Cnorm_no_R0 ; assumption.
  apply Rgt_not_eq ; assumption.
  apply Cnorm_no_R0 ; assumption.
  apply Rgt_not_eq ; assumption.
  unfold C_dist ; rewrite Cminus_0_r.
  unfold Cdiv ; rewrite Cmult_comm ; repeat rewrite Cnorm_Cmult.
  repeat rewrite Cnorm_inv.
  rewrite Cnorm_invol, Rmult_assoc, Rinv_l.
  rewrite Rmult_1_r ; rewrite <- Cnorm_inv.
  rewrite <- Cnorm_Cmult.
  replace (alp * / 2)%C with (IRC (alp / 2)%R).
  rewrite Cnorm_IRC_Rabs, Rabs_right.
  lra.
  lra.
  clear ; CusingR_f.
  apply IRC_neq_0_compat ; apply Rgt_not_eq ; lra.
  apply Cnorm_no_R0 ; assumption.
  apply IRC_neq_0_compat ; apply Cnorm_no_R0 ; assumption.
  apply IRC_neq_0_compat ; apply Rgt_not_eq ; lra.
Qed.

Lemma uniqueness_step2 : forall f (x : C) (v : C) (l : C), v <> 0 ->
    differentiable_pt_lim f x v l ->
    limit1_in (fun u => (f (x + u) - f x) / u) (fun u => u <> 0 /\ exists h:R, h * u = v) l 0.
Proof.
unfold derivable_pt_lim, limit1_in, limit_in.
intros f x v l v_neq Hf_deriv eps eps_pos ; destruct (Hf_deriv v_neq eps eps_pos) as
 ([alpha alpha_pos], Halpha) ; clear Hf_deriv ; exists (alpha * Cnorm v)%R ; split.
 apply Rmult_lt_0_compat ; [| apply Cnorm_pos_lt]; eauto with *.
 intros h [[h_neq [u h_rew]] Hh] ; simpl in * ; unfold C_dist in *.
 assert (u_neq : (u <> 0)%R).
  intro Hf ; apply v_neq ; rewrite <- h_rew, Hf ; CusingR_f.
 replace h with ((/u)%R * v).
 apply (Halpha (/u)%R).
 apply Rinv_neq_0_compat ; assumption.
 rewrite Cminus_0_r in Hh.
 replace (Rabs (/u))%R with (Cnorm h / Cnorm v)%R.
 apply Rlt_le_trans with (alpha * Cnorm v * / Cnorm v)%R.
 unfold Rdiv ; apply Rmult_lt_compat_r.
 apply Rinv_0_lt_compat ; apply Cnorm_pos_lt ; assumption.
 assumption.
 right ; field ; apply Cnorm_no_R0 ; assumption.
 rewrite <- h_rew.
 unfold Rdiv ; rewrite <- Cnorm_inv.
 rewrite <- Cnorm_Cmult.
 replace (h * / (u * h)) with (IRC (/ u)).
 apply Cnorm_IRC_Rabs.
 rewrite Cinv_mult_distr, Cmult_comm, Cmult_assoc, Cinv_l, Cmult_1_r.
 clear -u_neq ; CusingR ; field ; assumption.
 assumption.
 apply IRC_neq_0_compat ; assumption.
 assumption.
 apply Cmult_integral_contrapositive_currified ; [apply IRC_neq_0_compat |] ;
 assumption.
 rewrite <- h_rew.
 replace (IRC (/ u)) with (/ u).
 field ; apply IRC_neq_0_compat ; assumption.
 CusingR_f ; assumption.
Qed.

Lemma uniqueness_step3 : forall f x v l,
    limit1_in (fun u => (f (x + u) - f x) / u) (fun u => u <> 0 /\ exists h:R, h * u = v) l 0 ->
    differentiable_pt_lim f x v l.
Proof.
unfold limit1_in, derivable_pt_lim, limit_in, C_dist ; simpl ; unfold C_dist ;
intros f x v l Hf_lim v_neq eps eps_pos ; destruct (Hf_lim eps eps_pos) as
 (alpha, [alpha_pos Halpha]) ; clear Hf_lim.
 assert (alpha'_pos : 0 < alpha / Cnorm v).
  unfold Rdiv ; apply Rlt_mult_inv_pos ; [| apply Cnorm_pos_lt] ;
  assumption.
 exists (mkposreal (alpha / Cnorm v)%R alpha'_pos) ; intros h h_neq Hyp ;
 apply Halpha ; rewrite Cminus_0_r ; repeat split.
 apply Cmult_integral_contrapositive_currified ; [apply IRC_neq_0_compat |] ;
 assumption.
 exists (/h)%R.
 rewrite <- Cmult_assoc.
 replace ((/ h)%R * h) with C1.
 apply Cmult_1_l.
 CusingR_f ; assumption.
 rewrite Cnorm_Cmult ; apply Rlt_le_trans with (alpha / Cnorm v * Cnorm v)%R.
 apply Rmult_lt_compat_r.
 apply Cnorm_pos_lt ; assumption.
 rewrite Cnorm_IRC_Rabs ; apply Hyp.
 right ; field ; apply Cnorm_no_R0 ; assumption.
Qed.

Lemma uniqueness_limite : forall f (x v l1 l2 : C), v <> 0 ->
    differentiable_pt_lim f x v l1 -> differentiable_pt_lim f x v l2 -> l1 = l2.
Proof.
intros f x v l1 l2 v_neq Hf_deriv1 Hf_deriv2 ;
 assert (H1 := uniqueness_step2 _ _ _ _ v_neq Hf_deriv1) ;
 assert (H2 := uniqueness_step2 _ _ _ _ v_neq Hf_deriv2) ;
 apply uniqueness_step1 with f x v ; assumption.
Qed.

Lemma differential_pt_eq : forall f x v l (pr:differentiable_pt f x v), v <> 0 ->
    (differential_pt f x v pr = l <-> differentiable_pt_lim f x v l).
Proof.
intros f x v l pr v_neq ; split ; intro Hf_deriv.
 assert (H := proj2_sig pr) ; unfold derive_pt in Hf_deriv ;
 rewrite Hf_deriv in H ; assumption.
 assert (H := proj2_sig pr) ; unfold derivable_pt_abs in H.
 assert (H' := uniqueness_limite _ _ _ _ (proj1_sig pr) v_neq Hf_deriv H) ;
 symmetry ; assumption.
Qed.

(**********)
Lemma differential_pt_eq_0 : forall f x v l (pr:differentiable_pt f x v),
    v <> 0 -> differentiable_pt_lim f x v l -> differential_pt f x v pr = l.
Proof.
intros f x v l pr v_neq ; destruct (differential_pt_eq f x v l pr) ; assumption.
Qed.

(**********)
Lemma differential_pt_eq_1 : forall f x v l (pr:differentiable_pt f x v),
    v <> 0 -> differential_pt f x v pr = l -> differentiable_pt_lim f x v l.
Proof.
intros f x v l pr v_neq ; destruct (differential_pt_eq f x v l pr) ; assumption.
Qed.

(***********************************)
(** * differentiability -> continuity along an axis *)
(***********************************)

Lemma differentiable_continuous_along_axis : forall f (x v : C),
      differentiable_pt f x v -> continuity_along_axis_pt f v x.
Proof.
intros f x v f_diff.
 destruct (Ceq_dec v C0) as [v_eq | v_neq] ; intros eps eps_pos.
  exists (mkposreal R1 Rlt_0_1) ;
   intros h h_ub ; simpl ; unfold C_dist, Cminus ; rewrite v_eq, Cmult_0_r,
    Cadd_0_r, Cadd_opp_r, Cnorm_C0 ; assumption.
   destruct f_diff as (l, f_diff) ; destruct (Ceq_dec l C0) as [l_eq | l_neq].
  assert (eps_2_pos : eps / 2 > 0) by lra ;
  destruct (f_diff v_neq (eps / 2)%R eps_2_pos) as ([alpha alpha_pos], Halpha).
  assert (delta_pos : 0 < Rmin (/ (2 * Cnorm v)) alpha).
   apply Rmin_pos.
   rewrite Rinv_mult_distr.
   apply Rlt_mult_inv_pos ; [lra | apply Cnorm_pos_lt ; assumption].
   apply Rgt_not_eq ; lra.
   apply Rgt_not_eq ; apply Cnorm_pos_lt ; assumption.
   assumption.
  exists (mkposreal (Rmin (/(2 * Cnorm v)) alpha) delta_pos).
  intros h h_ub ; simpl ; unfold C_dist ; destruct (Ceq_dec h 0) as [h_eq | h_neq].
  rewrite h_eq, Cmult_0_l, Cadd_0_r,
  Cminus_diag_eq ; [| reflexivity] ; rewrite Cnorm_C0 ; assumption.
   apply Rlt_trans with (Cnorm (h * v) *eps)%R.
   apply Rle_lt_trans with (Cnorm (f (x + h * v)%C - f x) * (/ Cnorm (h * v) * Cnorm (h * v)))%R.
   right ; field ; apply Rgt_not_eq ; apply Cnorm_pos_lt ;
   apply Cmult_integral_contrapositive_currified ; assumption.
   unfold Rdiv ; rewrite  <- Rmult_assoc ; rewrite <- Cnorm_inv, <- Cnorm_Cmult.
   rewrite Rmult_comm ; apply Rmult_lt_compat_l.
   apply Cnorm_pos_lt ; apply Cmult_integral_contrapositive_currified ; assumption.
   replace ((f (x + h * v) - f x) * / (h * v)) with ((f (x + h * v) - f x) / (h *v) - l).
   apply Rlt_trans with (eps / 2)%R.
   apply Halpha.
   intro Hf ; apply h_neq ; rewrite Hf ; intuition.
   subst ; apply Rlt_le_trans with (Rmin (/(2* Cnorm v)) alpha) ; [apply h_ub | apply Rmin_r].
   lra.
   rewrite l_eq ; field ; split ; assumption.
   apply Cmult_integral_contrapositive_currified ; assumption.
   rewrite Cnorm_Cmult.
   apply Rlt_trans with ((Rmin (/(2 * Cnorm v)) alpha) * Cnorm v * eps)%R.
   repeat apply Rmult_lt_compat_r ; [| apply Cnorm_pos_lt | rewrite Cnorm_IRC_Rabs] ;
   assumption.
   apply Rle_lt_trans with (eps / 2)%R.
   unfold Rdiv ; rewrite Rmult_comm ; apply Rmult_le_compat_l ; intuition ;
   apply Rle_trans with (/(2*Cnorm v) * Cnorm v)%R.
   apply Rmult_le_compat_r ; [apply Cnorm_pos | apply Rmin_l].
   right ; field.
   apply Rgt_not_eq ; apply Cnorm_pos_lt ; assumption.
   lra.
   assert (eps_2_pos : eps / 2 > 0) by lra ;
   destruct (f_diff v_neq (eps / 2)%R eps_2_pos) as ([alpha alpha_pos], Halpha).
   pose (delta1 := Rmin (eps / (2 * Cnorm l)) (Rmin (1/2) alpha)).
   assert (delta1_pos : 0 < delta1).
    unfold delta1 ; repeat apply Rmin_pos.
    apply Rlt_mult_inv_pos ; [| apply Rmult_lt_0_compat] ;
    [| lra | apply Cnorm_pos_lt] ; assumption.
    lra.
    assumption.
   pose (delta := Rmin (delta1 / Cnorm v)%R delta1).
   assert (delta_pos : 0 < delta).
    unfold delta ; apply Rmin_pos.
    unfold Rdiv ; apply Rlt_mult_inv_pos ; [| apply Cnorm_pos_lt] ; assumption.
    assumption.
   exists (mkposreal delta delta_pos) ; intros h h_ub ; simpl ; unfold C_dist, Cminus.
   destruct (Ceq_dec h 0) as [h_eq | h_neq].
   rewrite h_eq, Cmult_0_l, Cadd_0_r, Cadd_opp_r, Cnorm_C0 ; assumption.
  apply Rlt_trans with (Cnorm (h * v) * eps + Cnorm (h * v) * Cnorm l )%R.
  apply Rle_lt_trans with (Cnorm (f (x + h * v)%C - f x) * (/ Cnorm (h * v) * Cnorm (h * v)))%R.
  right ; rewrite Rinv_l, Rmult_1_r ; [reflexivity |].
  apply Cnorm_no_R0 ; apply Cmult_integral_contrapositive_currified ;
  assumption.
   unfold Rdiv ; rewrite  <- Rmult_assoc ; rewrite <- Cnorm_inv, <- Cnorm_Cmult.
   apply Rle_lt_trans with ((Cnorm ((f (x + h * v)%C - f x) * / (h * v)) + (- Cnorm l + Cnorm l)) * Cnorm (h*v))%R.
   right ; field.
   repeat rewrite Rmult_plus_distr_r.
   replace (Cnorm l * Cnorm (h * v))%R with (Cnorm (h *v) * Cnorm l)%R
      by (apply Rmult_comm).
   rewrite <- Rplus_assoc ; apply Rplus_lt_compat_r.
   apply Rle_lt_trans with (Cnorm ((f (x +h * v)%C - f x) / (h * v) - l)* Cnorm (h * v))%R.
   rewrite <- Rmult_plus_distr_r ; apply Rmult_le_compat_r ;
   [apply Cnorm_pos | apply Cnorm_triang_rev_l].
   rewrite Rmult_comm ; apply Rmult_lt_compat_l.
   apply Cnorm_pos_lt ; apply Cmult_integral_contrapositive_currified ; assumption.
   apply Rlt_trans with (eps /2)%R ; [apply Halpha | lra].
   intro Hf ; apply h_neq ; rewrite Hf ; intuition.
   apply Rlt_le_trans with delta ; [apply h_ub |].
   apply Rle_trans with delta1 ; [apply Rmin_r |].
   apply Rle_trans with (Rmin (1/2) alpha) ; apply Rmin_r.
   apply Cmult_integral_contrapositive_currified ; assumption.
   apply Rlt_trans with (eps / 2 + Cnorm (h*v) * Cnorm l)%R.
   apply Rplus_lt_compat_r.
   unfold Rdiv ; rewrite Rmult_comm ; apply Rmult_lt_compat_l ;
   [assumption |].
   apply Rlt_le_trans with delta1.
   unfold delta1.
   apply Rlt_le_trans with (delta * Cnorm v)%R.
   rewrite Cnorm_Cmult ; apply Rmult_lt_compat_r ; [apply Cnorm_pos_lt ; assumption |] ;
   rewrite Cnorm_IRC_Rabs ; assumption.
   apply Rle_trans with (delta1 / Cnorm v * Cnorm v)%R.
   apply Rmult_le_compat_r ; [apply Cnorm_pos | apply Rmin_l].
   unfold Rdiv ; rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
   right ; reflexivity.
   apply Cnorm_no_R0 ; assumption.
 apply Rle_trans with (Rmin (1/2) alpha) ; [apply Rmin_r | apply Rle_trans with (1/2)%R ;
   [apply Rmin_l | right ; field]].
   apply Rlt_le_trans with (eps / 2 + eps / 2)%R ; [apply Rplus_lt_compat_l | right ; field].
   replace (eps / 2)%R with ((eps / (2 * Cnorm l)) * Cnorm l)%R
       by (field ; apply Cnorm_no_R0 ; assumption).
   apply Rmult_lt_compat_r.
   apply Cnorm_pos_lt ; assumption.
   apply Rlt_le_trans with (Rmin (eps / (2 * Cnorm l)) (Rmin (1 / 2) alpha)).
   apply Rlt_le_trans with (delta * Cnorm v)%R.
   rewrite Cnorm_Cmult ; apply Rmult_lt_compat_r ; [apply Cnorm_pos_lt ; assumption |] ;
   rewrite Cnorm_IRC_Rabs ; assumption.
   apply Rle_trans with (delta1 / Cnorm v * Cnorm v)%R.
   apply Rmult_le_compat_r ; [apply Cnorm_pos | apply Rmin_l].
   unfold Rdiv ; rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
   right ; reflexivity.
   apply Cnorm_no_R0 ; assumption.
   apply Rmin_l.
Qed.

(****************************************************************)
(** *                    Main rules                             *)
(****************************************************************)

Lemma differentiable_pt_lim_plus : forall f1 f2 x v l1 l2, v <> C0 ->
    differentiable_pt_lim f1 x v l1 -> differentiable_pt_lim f2 x v l2 ->
    differentiable_pt_lim (f1 + f2) x v (l1 + l2).
Proof.
intros f1 f2 x v l1 l2 v_neq H H0.
 apply uniqueness_step3.
 assert (H1 := uniqueness_step2 _ _ _ _ v_neq H).
 assert (H2 := uniqueness_step2 _ _ _ _ v_neq H0).
 unfold plus_fct in |- *.
  cut
    (forall h,
      (f1 (x + h) + f2 (x + h) - (f1 x + f2 x)) / h =
      (f1 (x + h) - f1 x) / h + (f2 (x + h) - f2 x) / h).
  intro H3 ; generalize
    (limit_plus (fun h' => (f1 (x + h') - f1 x) / h')
    (fun h' => (f2 (x + h') - f2 x) / h')
    (fun u => u <> 0 /\ (exists h : R, h * u = v)) l1 l2 0 H1 H2).
 intros H4 eps eps_pos.
  elim (H4 eps eps_pos); intros x0 Hx0.
  exists x0.
  destruct Hx0 as [x0_pos Hx0'].
  split.
  assumption.
  intros; rewrite H3; apply Hx0'; assumption.
  intro; unfold Cdiv ; ring.
Qed.

Lemma differentiable_pt_lim_opp : forall f x v l,
     v <> C0 -> differentiable_pt_lim f x v l ->
     differentiable_pt_lim (- f) x v (- l).
Proof.
intros f x v l v_neq H.
 apply uniqueness_step3.
 assert (H1 := uniqueness_step2 _ _ _ _ v_neq H).
  unfold opp_fct in |- * ;
  cut (forall h, (- f (x + h) - - f x) / h = - ((f (x + h) - f x) / h)).
  intro.
  generalize
    (limit_opp (fun h => (f (x + h) - f x) / h)
    (fun u => u <> 0 /\ (exists h : R, h * u = v)) l 0 H1).
  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
    simpl in |- *; unfold R_dist in |- *; intros.
  elim (H2 eps H3); intros.
  exists x0.
  elim H4; intros.
  split.
  assumption.
  intros; rewrite H0; apply H6; assumption.
  intro; unfold Cdiv in |- *; ring.
Qed.

Lemma differentiable_pt_lim_minus : forall f1 f2 x v l1 l2, v <> C0 ->
    differentiable_pt_lim f1 x v l1 -> differentiable_pt_lim f2 x v l2 ->
    differentiable_pt_lim (f1 - f2) x v (l1 - l2).
Proof.
  intros f1 f2 x v l1 l2 v_neq H H0.
  apply uniqueness_step3.
  assert (H1 := uniqueness_step2 _ _ _ _ v_neq H).
  assert (H2 := uniqueness_step2 _ _ _ _ v_neq H0).
  unfold minus_fct in |- *.
  cut
    (forall h,
      (f1 (x + h) - f1 x) / h - (f2 (x + h) - f2 x) / h =
      (f1 (x + h) - f2 (x + h) - (f1 x - f2 x)) / h).
  intro.
  generalize
    (limit_minus (fun h' => (f1 (x + h') - f1 x) / h')
      (fun h' => (f2 (x + h') - f2 x) / h')
      (fun u => u <> 0 /\ (exists h : R, h * u = v)) l1 l2 0 H1 H2).
  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
    simpl in |- *; unfold R_dist in |- *; intros.
  elim (H4 eps H5); intros.
  exists x0.
  elim H6; intros.
  split.
  assumption.
  intros; rewrite <- H3; apply H8; assumption.
  intro; unfold Cdiv in |- *; ring.
Qed.

Lemma differentiable_pt_lim_const : forall a x v, differentiable_pt_lim (fct_cte a) x v 0.
Proof.
  intros; unfold fct_cte, derivable_pt_lim in |- *.
  intros; exists (mkposreal 1 Rlt_0_1); intros; unfold Cminus in |- *;
  rewrite Cadd_opp_r; unfold Cdiv in |- * ; rewrite Cmult_0_l;
  rewrite Cadd_opp_r; rewrite Cnorm_C0; assumption.
Qed.

Lemma differentiable_pt_lim_mult : forall f1 f2 x v l1 l2,
    differentiable_pt_lim f1 x v l1 ->
    differentiable_pt_lim f2 x v l2 ->
    differentiable_pt_lim (f1 * f2) x v (l1 * f2 x + f1 x * l2).
Proof.
intros f1 f2 x v l1 l2 Hf1 Hf2 v_neq eps eps_pos.
 assert (Hrew : forall h, h <> 0 -> ((f1 * f2)%F (x + h * v) - (f1 * f2)%F x) / (h * v) -
     (l1 * f2 x + f1 x * l2) = ((f1 (x + h * v) - f1 x) / (h * v)) * f2 (x + h * v)
     - l1 * f2 (x + h * v) + l1 * f2 (x + h * v) - l1 * f2 x + (f1 x) * (f2 (x + h * v) - f2 x) / (h * v) - (f1 x) * l2).
  clear - v_neq.
  intros h h_neq.
  unfold Cminus, Cdiv, mult_fct ; ring.
 assert (Main : forall h : C, h <> 0 ->((f1 * f2)%F (x + h * v) - (f1 * f2)%F x) / (h * v) -
     (l1 * f2 x + f1 x * l2) = ((f1 (x + h * v) - f1 x) / (h * v) - l1) * f2 x +
     ((f1 (x + h * v) - f1 x) / (h * v) - l1) * (f2 (x + h*v) - f2 x) +
     l1 * (f2 (x + h * v) - f2 x) + f1 x * ((f2 (x + h * v) - f2 x) / (h * v) - l2)).
   clear - v_neq Hrew.
   intros h h_neq.
   unfold Cminus, Cdiv, mult_fct ; ring.
  clear Hrew.
  destruct (Ceq_dec l1 0) as [l1_eq | l1_neq].
  destruct (Ceq_dec (f1 x) 0) as [f1_eq | f1_neq].
  destruct (Ceq_dec (f2 x) 0) as [f2_eq | f2_neq].
  assert (Hf2' : differentiable_pt f2 x v).
   exists l2 ; apply Hf2.
  destruct (Rle_dec 1 eps) as [eps_lb | eps_ub].
  destruct (Hf1 v_neq (Rmin 1 eps)) as [delta1 Hdelta1] ; [apply Rmin_pos ; lra |].
  destruct (differentiable_continuous_along_axis f2 x v Hf2' (Rmin 1 eps)%R) as
  [delta2 Hdelta2] ; [apply Rmin_pos ; lra |].
  pose (delta := Rmin delta1 delta2) ; assert (delta_pos : 0 < delta) by
  (apply Rmin_pos ; [apply delta1 | apply delta2]).
  exists (mkposreal delta delta_pos) ; intros h h_neq h_ub.
  rewrite Main ; clear Main ; repeat rewrite l1_eq, f1_eq, f2_eq in * ;
  repeat rewrite Cmult_0_r ; repeat rewrite Cmult_0_l ;
  repeat rewrite Cadd_0_l ; repeat rewrite Cadd_0_r.
  apply Rlt_le_trans with 1%R ; [| assumption].
  rewrite Cnorm_Cmult ; apply Rle_lt_trans with (Cnorm (f2 (x + h * v) - 0)).
  rewrite <- Rmult_1_l ; apply Rmult_le_compat_r ; [apply Cnorm_pos |].
  apply Rle_trans with (Rmin 1 eps) ; [left ; apply Hdelta1 | apply Rmin_l].
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
  apply Rlt_le_trans with (Rmin 1 eps) ; [simpl in Hdelta2 ; unfold C_dist in Hdelta2 ;
  apply Hdelta2 | apply Rmin_l].
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_r].
  apply IRC_neq_0_compat ; assumption.
  assert (eps_lt_1 := Rnot_le_lt _ _ eps_ub) ; clear eps_ub.
  assert (eps_2_lt_eps : eps * eps < eps).
   rewrite <- Rmult_1_r ; apply Rmult_lt_compat_l ; assumption.
  destruct (Hf1 v_neq eps eps_pos) as [delta1 Hdelta1].
  destruct (differentiable_continuous_along_axis f2 x v Hf2' eps eps_pos) as
  [delta2 Hdelta2].
  pose (delta := Rmin delta1 delta2) ; assert (delta_pos : 0 < delta) by
  (apply Rmin_pos ; [apply delta1 | apply delta2]).
  exists (mkposreal delta delta_pos) ; intros h h_neq h_ub ;
  rewrite Main ; [| apply IRC_neq_0_compat ; assumption] ;
  clear Main ; repeat rewrite l1_eq, f1_eq, f2_eq in * ;
  repeat rewrite Cmult_0_r ; repeat rewrite Cmult_0_l ;
  repeat rewrite Cadd_0_l ; repeat rewrite Cadd_0_r.
  rewrite Cnorm_Cmult ; apply Rlt_trans with (eps * eps)%R ;
  [| assumption] ; clear eps_lt_1 eps_2_lt_eps.
  apply Rle_lt_trans with (eps * Cnorm (f2 (x + h * v)%C - C0))%R.
  apply Rmult_le_compat_r ; [apply Cnorm_pos |].
  left ; apply Hdelta1.
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
  apply Rmult_lt_compat_l ; [assumption |].
  simpl in Hdelta2 ; unfold C_dist in Hdelta2 ; apply Hdelta2.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_r].
  destruct (Hf1 v_neq (Rmin (eps/2)%R ((eps/2) / Cnorm (f2 x)))) as [delta1 Hdelta1].
  apply Rmin_pos ; [lra |].
  apply Rmult_lt_0_compat ; [lra | apply Rinv_0_lt_compat ; apply Cnorm_pos_lt] ;
  assumption.
  assert (Hf2' : differentiable_pt f2 x v).
   exists l2 ; apply Hf2.
  destruct (differentiable_continuous_along_axis f2 x v Hf2' R1 Rlt_0_1)
  as [delta2 Hdelta2].
  pose (delta := Rmin delta1 delta2) ; assert (delta_pos : 0 < delta) by
  (apply Rmin_pos ; [apply delta1 | apply delta2]).
  exists (mkposreal delta delta_pos) ; intros h h_neq h_ub ;
  rewrite Main ; [| apply IRC_neq_0_compat ; assumption] ;
  clear Main ; repeat rewrite l1_eq, f1_eq in * ;
  repeat rewrite Cmult_0_r ; repeat rewrite Cmult_0_l ;
  repeat rewrite Cadd_0_l ; repeat rewrite Cadd_0_r ;
  repeat rewrite Cminus_0_r in *.
  apply Rle_lt_trans with (Cnorm (f1 (x + h * v)%C / (h * v) * f2 x) +
   Cnorm (f1 (x + h * v)%C / (h * v) * (f2 (x + h * v)%C - f2 x)))%R.
  apply Cnorm_triang.
  apply Rlt_trans with (Cnorm (f1 (x + h * v)%C / (h * v) * f2 x) + eps / 2)%R.
  apply Rplus_lt_compat_l.
  rewrite Cnorm_Cmult.
  apply Rle_lt_trans with (Cnorm (f1 (x + h * v)%C / (h * v)))%R.
  rewrite <- Rmult_1_r ; apply Rmult_le_compat_l ; [apply Cnorm_pos |].
  left ; simpl in Hdelta2 ; unfold C_dist in Hdelta2 ; apply Hdelta2.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_r].
  apply Rlt_le_trans with (Rmin (eps / 2) (eps / 2 / Cnorm (f2 x))) ; [| apply Rmin_l].
  apply Rle_lt_trans with (Cnorm ((f1 (x + h * v) - 0) / (h * v) - 0)).
  right ; repeat rewrite Cminus_0_r ; reflexivity.
  apply Hdelta1.
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
  apply Rlt_le_trans with (eps / 2 + eps / 2)%R ; [| right ; field].
  apply Rplus_lt_compat_r.
  apply Rlt_le_trans with ((eps / 2 / Cnorm (f2 x)) * Cnorm (f2 x))%R.
  rewrite Cnorm_Cmult ; apply Rmult_lt_compat_r ; [apply Cnorm_pos_lt ; assumption |].
  apply Rlt_le_trans with (Rmin (eps / 2) (eps / 2 / Cnorm (f2 x))) ; [| apply Rmin_r].
  apply Rle_lt_trans with (Cnorm ((f1 (x + h * v)%C - 0) / (h * v) - 0))%R ;
  [right ; repeat rewrite Cminus_0_r ; reflexivity |] ; apply Hdelta1.
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
  right ; unfold Rdiv ; repeat rewrite Rmult_assoc ; rewrite Rinv_l.
  ring.
  apply Cnorm_no_R0 ; assumption.
  destruct (Ceq_dec (f2 x) 0) as [f2_eq | f2_neq].
  destruct (Hf1 v_neq (eps/2)%R) as [delta1 Hdelta1] ; [lra |].
  destruct (Hf2 v_neq ((eps / 2) / Cnorm (f1 x))%R) as [delta2 Hdelta2].
  apply Rmult_lt_0_compat ; [lra | apply Rinv_0_lt_compat ; apply Cnorm_pos_lt] ;
  assumption.
  assert (Hf2' : differentiable_pt f2 x v).
   exists l2 ; apply Hf2.
  destruct (differentiable_continuous_along_axis f2 x v Hf2' R1 Rlt_0_1)
  as [delta3 Hdelta3].
  pose (delta := Rmin delta1 (Rmin delta2 delta3)) ; assert (delta_pos : 0 < delta) by
  (repeat apply Rmin_pos ; [apply delta1 | apply delta2 | apply delta3]).
  exists (mkposreal delta delta_pos) ; intros h h_neq h_ub ;
  rewrite Main ; [| apply IRC_neq_0_compat ; assumption] ;
  clear Main ; repeat rewrite l1_eq, f2_eq in * ;
  repeat rewrite Cmult_0_r ; repeat rewrite Cmult_0_l ;
  repeat rewrite Cadd_0_l ; repeat rewrite Cadd_0_r ;
  repeat rewrite Cminus_0_r in *.
  apply Rle_lt_trans with (Cnorm ((f1 (x + h * v)%C - f1 x) / (h * v) * f2 (x + h * v)%C) +
   Cnorm (f1 x * (f2 (x + h * v)%C / (h * v) - l2)))%R ; [apply Cnorm_triang |].
  apply Rlt_trans with (eps / 2 + Cnorm (f1 x * (f2 (x + h * v)%C / (h * v) - l2)))%R.
  apply Rplus_lt_compat_r.
  rewrite Cnorm_Cmult ; apply Rle_lt_trans with (eps / 2 * Cnorm (f2 (x + h * v)%C))%R.
  apply Rmult_le_compat_r ; [apply Cnorm_pos |].
  apply Rle_trans with (Cnorm ((f1 (x + h * v)%C - f1 x) / (h * v) - C0))%R ;
  [right ; rewrite Cminus_0_r ; reflexivity | left ; apply Hdelta1].
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
  rewrite <- Rmult_1_r ; apply Rmult_lt_compat_l ; [lra |].
  apply Rle_lt_trans with (dist C_met (f2 (x + h * v)) C0) ; [right ; simpl ; unfold C_dist ;
  rewrite Cminus_0_r ; reflexivity | apply Hdelta3].
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rle_trans with (Rmin delta2 delta3) ;
  [apply Rmin_r | apply Rmin_r]].
  apply Rlt_le_trans with (eps / 2 + eps / 2)%R ; [| right ; field].
  apply Rplus_lt_compat_l ; rewrite Cnorm_Cmult.
  apply Rlt_le_trans with (Cnorm (f1 x) * (/Cnorm (f1 x) * eps / 2))%R.
  apply Rmult_lt_compat_l ; [apply Cnorm_pos_lt ; assumption |].
  apply Rlt_le_trans with (eps / 2 / Cnorm (f1 x))%R ; [| right ; field].
  apply Rle_lt_trans with (Cnorm ((f2 (x + h * v) - 0) / (h * v) - l2)) ; [right ;
  rewrite Cminus_0_r ; reflexivity |] ; apply Hdelta2.
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rle_trans with (Rmin delta2 delta3) ;
  [apply Rmin_r | apply Rmin_l]].
  apply Cnorm_no_R0 ; assumption.
  right ; field ; apply Cnorm_no_R0 ; assumption.
  destruct (Hf1 v_neq (Rmin(eps/3) ((eps/3) / Cnorm (f2 x)))%R) as [delta1 Hdelta1].
  apply Rmin_pos ; [lra |] ; apply Rmult_lt_0_compat ;
  [lra | apply Rinv_0_lt_compat ; apply Cnorm_pos_lt] ; assumption.
  destruct (Hf2 v_neq ((eps / 3) / Cnorm (f1 x))%R) as [delta2 Hdelta2].
  apply Rmult_lt_0_compat ;
  [lra | apply Rinv_0_lt_compat ; apply Cnorm_pos_lt] ; assumption.
  assert (Hf2' : differentiable_pt f2 x v).
   exists l2 ; apply Hf2.
  destruct (differentiable_continuous_along_axis f2 x v Hf2' R1 Rlt_0_1)
  as [delta3 Hdelta3].
  pose (delta := Rmin delta1 (Rmin delta2 delta3)) ; assert (delta_pos : 0 < delta) by
  (repeat apply Rmin_pos ; [apply delta1 | apply delta2 | apply delta3]).
  exists (mkposreal delta delta_pos) ; intros h h_neq h_ub ;
  rewrite Main ; [| apply IRC_neq_0_compat ; assumption] ;
  clear Main ; repeat rewrite l1_eq in * ;
  repeat rewrite Cmult_0_r ; repeat rewrite Cmult_0_l ;
  repeat rewrite Cadd_0_l ; repeat rewrite Cadd_0_r ;
  repeat rewrite Cminus_0_r in *.
  apply Rlt_le_trans with (eps/3 + eps/3 + eps/3)%R ; [| right ; field].
  apply Rle_lt_trans with (Cnorm ((f1 (x + h * v)%C - f1 x) / (h * v) * f2 x +
   (f1 (x + h * v)%C - f1 x) / (h * v) * (f2 (x + h * v)%C - f2 x)) +
   Cnorm (f1 x * ((f2 (x + h * v)%C - f2 x) / (h * v) - l2)))%R ; [apply Cnorm_triang |].
  apply Rlt_trans with (Cnorm ((f1 (x + h * v)%C - f1 x) / (h * v) * f2 x +
   (f1 (x + h * v)%C - f1 x) / (h * v) * (f2 (x + h * v)%C - f2 x)) + eps / 3)%R.
  apply Rplus_lt_compat_l.
  rewrite Cnorm_Cmult ; apply Rlt_le_trans with (Cnorm (f1 x) * (eps / 3 / Cnorm (f1 x)))%R.
  apply Rmult_lt_compat_l ; [apply Cnorm_pos_lt ; assumption |].
  apply Hdelta2.
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rle_trans with (Rmin delta2 delta3) ;
  [apply Rmin_r | apply Rmin_l]].
  right ; field ; apply Cnorm_no_R0 ; assumption.
  apply Rplus_lt_compat_r.
  apply Rle_lt_trans with (Cnorm ((f1 (x + h * v)%C - f1 x) / (h * v) * f2 x) +
   Cnorm ((f1 (x + h * v)%C - f1 x) / (h * v) * (f2 (x + h * v)%C - f2 x)))%R ;
  [apply Cnorm_triang |].
 apply Rlt_trans with (Cnorm ((f1 (x + h * v)%C - f1 x) / (h * v) * f2 x) + eps / 3)%R.
 apply Rplus_lt_compat_l.
 rewrite Cnorm_Cmult ; apply Rle_lt_trans with (eps / 3 * Cnorm (f2 (x + h * v)%C - f2 x))%R.
 apply Rmult_le_compat_r ; [apply Cnorm_pos |].
 apply Rle_trans with (Rmin (eps / 3) (eps / 3 / Cnorm (f2 x))) ; [| apply Rmin_l].
 apply Rle_trans with (Cnorm ((f1 (x + h * v)%C - f1 x) / (h * v) - 0))%R ;
 [right ; rewrite Cminus_0_r ; reflexivity |] ; left ; apply Hdelta1.
 assumption.
 apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
 rewrite <- Rmult_1_r ; apply Rmult_lt_compat_l ; [lra |] ;
 simpl in Hdelta3 ; unfold C_dist in Hdelta3 ; apply Hdelta3.
 apply Rlt_le_trans with delta ; [apply h_ub | apply Rle_trans with (Rmin delta2 delta3) ;
 apply Rmin_r].
 apply Rplus_lt_compat_r ; rewrite Cnorm_Cmult.
 apply Rlt_le_trans with ((eps / 3 / Cnorm (f2 x)) * Cnorm (f2 x))%R.
 apply Rmult_lt_compat_r ; [apply Cnorm_pos_lt ; assumption |].
 apply Rlt_le_trans with (Rmin (eps / 3) (eps / 3 / Cnorm (f2 x))) ; [| apply Rmin_r].
 apply Rle_lt_trans with (Cnorm ((f1 (x + h * v) - f1 x) / (h * v) - 0)) ; [right ;
 rewrite Cminus_0_r ; reflexivity |].
 apply Hdelta1.
 assumption.
 apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
 right ; field ; apply Cnorm_no_R0 ; assumption.
  destruct (Ceq_dec (f1 x) 0) as [f1_eq | f1_neq].
  destruct (Ceq_dec (f2 x) 0) as [f2_eq | f2_neq].
  destruct (Hf1 v_neq (eps / 2)%R) as [delta1 Hdelta1] ; [lra |].
  assert (Hf2' : differentiable_pt f2 x v).
   exists l2 ; apply Hf2.
  destruct (differentiable_continuous_along_axis f2 x v Hf2'
  (Rmin R1 ((eps / 2) / Cnorm l1))) as [delta2 Hdelta2].
  apply Rmin_pos ; [lra |].
  apply Rmult_lt_0_compat ; [lra | apply Rinv_0_lt_compat ;
  apply Cnorm_pos_lt ; assumption].
  pose (delta := Rmin delta1 delta2) ; assert (delta_pos : 0 < delta) by
  (apply Rmin_pos ; [apply delta1 | apply delta2]) ; exists (mkposreal delta
  delta_pos) ; intros h h_neq h_ub ;
  rewrite Main ; [| apply IRC_neq_0_compat ; assumption] ;
  clear Main ; repeat rewrite f1_eq, f2_eq in * ;
  repeat rewrite Cmult_0_r ; repeat rewrite Cmult_0_l ;
  repeat rewrite Cadd_0_l ; repeat rewrite Cadd_0_r ;
  repeat rewrite Cminus_0_r in *.
  apply Rle_lt_trans with (Cnorm ((f1 (x + h * v)%C / (h * v) - l1) * f2 (x + h * v)%C) +
  Cnorm (l1 * f2 (x + h * v)%C))%R ; [apply Cnorm_triang |].
  apply Rlt_le_trans with (eps / 2 +  eps / 2)%R ; [| right ; field].
  apply Rle_lt_trans with (Cnorm ((f1 (x + h * v)%C / (h * v) - l1) *
  f2 (x + h * v)%C) + eps / 2)%R.
  apply Rplus_le_compat_l.
  rewrite Cnorm_Cmult ; apply Rle_trans with (Cnorm l1 * ((eps / 2) / Cnorm l1))%R.
  apply Rmult_le_compat_l ; [apply Cnorm_pos |].
  apply Rle_trans with (Rmin 1 (eps / 2 / Cnorm l1)) ; [| apply Rmin_r].
  apply Rle_trans with (dist C_met (f2 (x + h * v)) C0) ; [simpl ; unfold C_dist ; right ;
  rewrite Cminus_0_r ; reflexivity | left ; apply Hdelta2].
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_r].
  right ; field ; apply Cnorm_no_R0 ; assumption.
  apply Rplus_lt_compat_r ; rewrite Cnorm_Cmult ; apply Rle_lt_trans with
  (eps / 2 * Cnorm (f2 (x + h * v)%C))%R.
  apply Rmult_le_compat_r ; [apply Cnorm_pos |].
  apply Rle_trans with (Cnorm ((f1 (x + h * v) - 0) / (h * v) - l1)) ; [rewrite Cminus_0_r ;
  right ; reflexivity | left ; apply Hdelta1].
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
  rewrite <- Rmult_1_r ; apply Rmult_lt_compat_l ; [lra |].
  apply Rle_lt_trans with (dist C_met (f2 (x + h * v)) C0) ; [simpl ; unfold C_dist ;
  rewrite Cminus_0_r ; right ; reflexivity |].
  apply Rlt_le_trans with (Rmin 1 (eps / 2 / Cnorm l1)) ; [apply Hdelta2 |
  apply Rmin_l].
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_r].
  destruct (Hf1 v_neq (Rmin (eps / 3) (eps / 3 / Cnorm (f2 x)))) as [delta1 Hdelta1].
  apply Rmin_pos ; [lra |] ; apply Rmult_lt_0_compat ;
  [lra | apply Rinv_0_lt_compat ; apply Cnorm_pos_lt] ; assumption.
  assert (Hf2' : differentiable_pt f2 x v).
   exists l2 ; apply Hf2.
  destruct (differentiable_continuous_along_axis f2 x v Hf2' (Rmin 1 (eps / 3 / Cnorm l1)))
  as [delta2 Hdelta2].
  apply Rmin_pos ; [apply Rlt_0_1 | apply Rmult_lt_0_compat ;
  [lra | apply Rinv_0_lt_compat ; apply Cnorm_pos_lt] ; assumption].
  pose (delta := Rmin delta1 delta2) ; assert (delta_pos : 0 < delta) by
  (apply Rmin_pos ; [apply delta1 | apply delta2]) ;
  exists (mkposreal delta delta_pos) ; intros h h_neq h_ub ;
  rewrite Main ; [| apply IRC_neq_0_compat ; assumption] ;
  clear Main ; repeat rewrite f1_eq in * ;
  repeat rewrite Cmult_0_r ; repeat rewrite Cmult_0_l ;
  repeat rewrite Cadd_0_l ; repeat rewrite Cadd_0_r ;
  repeat rewrite Cminus_0_r in *.
  apply Rle_lt_trans with (Cnorm ((f1 (x + h * v)%C / (h * v) - l1) * f2 x) +
   Cnorm ((f1 (x + h * v)%C / (h * v) - l1) * (f2 (x + h * v)%C - f2 x) +
   l1 * (f2 (x + h * v)%C - f2 x)))%R ; [rewrite Cadd_assoc ; apply Cnorm_triang |].
  apply Rle_lt_trans with (Cnorm ((f1 (x + h * v)%C / (h * v) - l1) * f2 x) +
   Cnorm ((f1 (x + h * v)%C / (h * v) - l1) * (f2 (x + h * v)%C - f2 x)) +
   Cnorm (l1 * (f2 (x + h * v)%C - f2 x)))%R.
  rewrite Rplus_assoc ; apply Rplus_le_compat_l ; apply Cnorm_triang.
  apply Rlt_trans with (eps/3 + Cnorm ((f1 (x + h * v)%C / (h * v) - l1) *
  (f2 (x + h * v)%C - f2 x)) + Cnorm (l1 * (f2 (x + h * v)%C - f2 x)))%R.
  repeat apply Rplus_lt_compat_r ; rewrite Cnorm_Cmult ;
  apply Rlt_le_trans with ((eps / 3 / Cnorm (f2 x)) * Cnorm (f2 x))%R.
  apply Rmult_lt_compat_r ; [apply Cnorm_pos_lt ; assumption |].
  apply Rlt_le_trans with (Rmin (eps / 3) (eps / 3 / Cnorm (f2 x))) ;
  [| apply Rmin_r].
  apply Rle_lt_trans with (Cnorm ((f1 (x + h * v) - 0) / (h * v) - l1)) ;
  [rewrite Cminus_0_r ; right ; reflexivity | apply Hdelta1].
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
  right ; field ; apply Cnorm_no_R0 ; assumption.
  apply Rlt_trans with (eps / 3 + eps / 3 + Cnorm (l1 * (f2 (x + h * v)%C - f2 x)))%R ;
  [apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l |].
  rewrite Cnorm_Cmult ; apply Rle_lt_trans with
  (eps / 3 * Cnorm ((f2 (x + h * v)%C - f2 x)))%R ; [apply Rmult_le_compat_r ;
  [apply Cnorm_pos |]|].
  apply Rle_trans with (Rmin (eps / 3) (eps / 3 / Cnorm (f2 x))) ; [| apply Rmin_l] ;
  apply Rle_trans with (Cnorm ((f1 (x + h * v)%C - C0) / (h * v) - l1))%R ; [right ;
  rewrite Cminus_0_r ; reflexivity | left ; apply Hdelta1].
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
  rewrite <- Rmult_1_r ; apply Rmult_lt_compat_l ; [lra |].
  apply Rle_lt_trans with (dist C_met (f2 (x + h * v)) (f2 x)) ; [right ;
  simpl ; unfold C_dist ; reflexivity |].
  apply Rlt_le_trans with (Rmin 1 (eps / 3 / Cnorm l1)) ; [apply Hdelta2 | apply Rmin_l].
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_r].
  apply Rlt_le_trans with (eps / 3 + eps / 3 + eps / 3)%R ; [apply Rplus_lt_compat_l |
  right ; field].
  rewrite Cnorm_Cmult ; apply Rlt_le_trans with (Cnorm l1 * (eps / 3 / Cnorm l1))%R.
  apply Rmult_lt_compat_l ; [apply Cnorm_pos_lt ; assumption |].
  apply Rle_lt_trans with (dist C_met (f2 (x + h * v)) (f2 x)) ; [simpl ; unfold C_dist ;
  right ; reflexivity | apply Rlt_le_trans with (Rmin 1 (eps / 3 / Cnorm l1)) ;
  [apply Hdelta2 | apply Rmin_r]].
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_r].
  right ; field ; apply Cnorm_no_R0 ; assumption.
  destruct (Ceq_dec (f2 x) 0) as [f2_eq | f2_neq].
  destruct (Hf1 v_neq (eps / 3)%R) as [delta1 Hdelta1] ; [lra |].
  destruct (Hf2 v_neq (eps / 3 / Cnorm (f1 x))%R) as [delta2 Hdelta2].
  apply Rmult_lt_0_compat ; [lra | apply Rinv_0_lt_compat ;
  apply Cnorm_pos_lt] ; assumption.
  assert (Hf2' : differentiable_pt f2 x v).
   exists l2 ; apply Hf2.
  destruct (differentiable_continuous_along_axis f2 x v Hf2' (Rmin 1 (eps / 3 / Cnorm l1)))
  as [delta3 Hdelta3].
  apply Rmin_pos ; [apply Rlt_0_1 |] ; apply Rmult_lt_0_compat ;
  [lra | apply Rinv_0_lt_compat ; apply Cnorm_pos_lt] ; assumption.
  pose (delta := Rmin delta1 (Rmin delta2 delta3)) ; assert (delta_pos : 0 < delta) by
  (repeat apply Rmin_pos ; [apply delta1 | apply delta2 | apply delta3]) ;
  exists (mkposreal delta delta_pos) ; intros h h_neq h_ub ;
  rewrite Main ; [| apply IRC_neq_0_compat ; assumption] ;
  clear Main ; repeat rewrite f2_eq in * ;
  repeat rewrite Cmult_0_r ; repeat rewrite Cmult_0_l ;
  repeat rewrite Cadd_0_l ; repeat rewrite Cadd_0_r ;
  repeat rewrite Cminus_0_r in *.
  apply Rle_lt_trans with (Cnorm (((f1 (x + h * v)%C - f1 x) / (h * v) - l1) * f2 (x + h * v)%C +
   l1 * f2 (x + h * v)%C) + Cnorm (f1 x * (f2 (x + h * v)%C / (h * v) - l2)))%R ;
   [apply Cnorm_triang |] ; apply Rle_lt_trans with (Cnorm
   (((f1 (x + h * v)%C - f1 x) / (h * v) - l1) * f2 (x + h * v)%C) +
   Cnorm (l1 * f2 (x + h * v)%C) + Cnorm (f1 x * (f2 (x + h * v)%C / (h * v) - l2)))%R ;
   [apply Rplus_le_compat_r ; apply Cnorm_triang |].
  apply Rle_lt_trans with (eps / 3 + Cnorm (l1 * f2 (x + h * v)%C) +
  Cnorm (f1 x * (f2 (x + h * v)%C / (h * v) - l2)))%R ; [repeat apply Rplus_le_compat_r |].
  rewrite Cnorm_Cmult ; apply Rle_trans with (eps / 3 * Cnorm (f2 (x + h * v)%C))%R ;
  [apply Rmult_le_compat_r ; [apply Cnorm_pos | left ; apply Hdelta1] |].
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
  rewrite <- Rmult_1_r ; apply Rmult_le_compat_l ; [lra |] ;
  apply Rle_trans with (dist C_met (f2 (x + h * v)) C0) ; [simpl ; unfold C_dist ; rewrite
  Cminus_0_r ; right ; reflexivity |] ; apply Rle_trans with (Rmin 1 (eps / 3 / Cnorm l1)) ;
  [left ; apply Hdelta3 | apply Rmin_l].
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rle_trans with (Rmin delta2 delta3) ;
  apply Rmin_r].
  apply Rle_lt_trans with (eps / 3 + eps / 3 +
  Cnorm (f1 x * (f2 (x + h * v)%C / (h * v) - l2)))%R ;
  [apply Rplus_le_compat_r ; apply Rplus_le_compat_l |].
  rewrite Cnorm_Cmult ; apply Rle_trans with (Cnorm l1 * (eps / 3 / Cnorm l1))%R ;
  [apply Rmult_le_compat_l ; [apply Cnorm_pos|] |].
  apply Rle_trans with (dist C_met (f2 (x + h * v)) C0) ; [simpl ; unfold C_dist ; rewrite
  Cminus_0_r ; right ; reflexivity |] ; apply Rle_trans with (Rmin 1 (eps / 3 / Cnorm l1)) ;
  [left ; apply Hdelta3 | apply Rmin_r].
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rle_trans with (Rmin delta2 delta3) ;
  apply Rmin_r].
  right ; field ; apply Cnorm_no_R0 ; assumption.
  apply Rlt_le_trans with (eps / 3 + eps / 3 + eps /3)%R ; [repeat rewrite Rplus_assoc ;
  repeat apply Rplus_lt_compat_l | right ; field].
  rewrite Cnorm_Cmult ; apply Rlt_le_trans with (Cnorm (f1 x) * (eps / 3 / Cnorm (f1 x)))%R.
  apply Rmult_lt_compat_l ; [apply Cnorm_pos_lt ; assumption |].
  apply Rle_lt_trans with (Cnorm ((f2 (x + h * v)%C - 0) / (h * v) - l2))%R ;
  [rewrite Cminus_0_r ; right ; reflexivity | apply Hdelta2].
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rle_trans with (Rmin delta2 delta3) ;
  [apply Rmin_r | apply Rmin_l]].
  right ; field ; apply Cnorm_no_R0 ; assumption.
  destruct (Hf1 v_neq (Rmin (eps / 4) (eps / 4 / Cnorm (f2 x)))) as [delta1 Hdelta1].
  apply Rmin_pos ; [lra |] ; apply Rmult_lt_0_compat ; [lra | apply Rinv_0_lt_compat ;
  apply Cnorm_pos_lt] ; assumption.
  destruct (Hf2 v_neq (eps / 4 / Cnorm (f1 x))%R) as [delta2 Hdelta2].
  apply Rmult_lt_0_compat ; [lra | apply Rinv_0_lt_compat ;
  apply Cnorm_pos_lt] ; assumption.
  assert (Hf2' : differentiable_pt f2 x v).
   exists l2 ; apply Hf2.
  destruct (differentiable_continuous_along_axis f2 x v Hf2' (Rmin 1 (eps / 4 / Cnorm l1)))
  as [delta3 Hdelta3].
  apply Rmin_pos ; [apply Rlt_0_1 |] ; apply Rmult_lt_0_compat ;
  [lra | apply Rinv_0_lt_compat ; apply Cnorm_pos_lt] ; assumption.
  pose (delta := Rmin delta1 (Rmin delta2 delta3)) ; assert (delta_pos : 0 < delta) by
  (repeat apply Rmin_pos ; [apply delta1 | apply delta2 | apply delta3]) ;
  exists (mkposreal delta delta_pos) ; intros h h_neq h_ub ;
  rewrite Main ; [| apply IRC_neq_0_compat ; assumption] ;
  clear Main.
  apply Rle_lt_trans with (Cnorm (((f1 (x + h * v)%C - f1 x) / (h * v) - l1) * f2 x +
   ((f1 (x + h * v)%C - f1 x) / (h * v) - l1) * (f2 (x + h * v)%C - f2 x) +
   l1 * (f2 (x + h * v)%C - f2 x)) + Cnorm (f1 x * ((f2 (x + h * v)%C - f2 x) / (h * v) - l2)))%R ;
  [apply Cnorm_triang |].
  apply Rle_lt_trans with (Cnorm (((f1 (x + h * v)%C - f1 x) / (h * v) - l1) * f2 x +
   ((f1 (x + h * v)%C - f1 x) / (h * v) - l1) * (f2 (x + h * v)%C - f2 x)) + Cnorm (
   l1 * (f2 (x + h * v)%C - f2 x)) + Cnorm (f1 x * ((f2 (x + h * v)%C - f2 x) / (h * v) - l2)))%R ;
  [apply Rplus_le_compat_r ; apply Cnorm_triang |].
  apply Rle_lt_trans with (Cnorm (((f1 (x + h * v)%C - f1 x) / (h * v) - l1) * f2 x) +
   Cnorm (((f1 (x + h * v)%C - f1 x) / (h * v) - l1) * (f2 (x + h * v)%C - f2 x)) + Cnorm (
   l1 * (f2 (x + h * v)%C - f2 x)) + Cnorm (f1 x * ((f2 (x + h * v)%C - f2 x) / (h * v) - l2)))%R ;
  [repeat apply Rplus_le_compat_r ; apply Cnorm_triang |].
  apply Rle_lt_trans with (eps / 4 +
  Cnorm (((f1 (x + h * v)%C - f1 x) / (h * v) - l1) * (f2 (x + h * v)%C - f2 x)) +
  Cnorm (l1 * (f2 (x + h * v)%C - f2 x)) +
  Cnorm (f1 x * ((f2 (x + h * v)%C - f2 x) / (h * v) - l2)))%R ;
  [repeat apply Rplus_le_compat_r |].
  rewrite Cnorm_Cmult ; apply Rle_trans with ((eps / 4 / Cnorm (f2 x)) * Cnorm (f2 x))%R ;
  [apply Rmult_le_compat_r ; [apply Cnorm_pos |] |].
  apply Rle_trans with (Rmin (eps / 4) (eps / 4 / Cnorm (f2 x))) ; [left ; apply Hdelta1 |
  apply Rmin_r].
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
  right ; field ; apply Cnorm_no_R0 ; assumption.
  apply Rle_lt_trans with (eps / 4 + eps / 4 + Cnorm (l1 * (f2 (x + h * v)%C - f2 x)) +
  Cnorm (f1 x * ((f2 (x + h * v)%C - f2 x) / (h * v) - l2)))%R ;
  [repeat apply Rplus_le_compat_r ; apply Rplus_le_compat_l |].
  rewrite Cnorm_Cmult ; apply Rle_trans with (eps / 4 *
  Cnorm ((f2 (x + h * v)%C - f2 x)))%R ; [apply Rmult_le_compat_r ;
  [apply Cnorm_pos |] |].
  apply Rle_trans with (Rmin (eps / 4) (eps / 4 / Cnorm (f2 x))) ; [left ;
  apply Hdelta1 | apply Rmin_l].
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rmin_l].
  rewrite <- Rmult_1_r ; apply Rmult_le_compat_l ; [lra |] ;
  apply Rle_trans with (Rmin 1 (eps / 4 / Cnorm l1)) ; [| apply Rmin_l].
  apply Rle_trans with (dist C_met (f2 (x + h * v)) (f2 x)) ; [simpl ; unfold C_dist ;
  right ; reflexivity | left ; apply Hdelta3].
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rle_trans with
  (Rmin delta2 delta3) ; apply Rmin_r].
  apply Rle_lt_trans with (eps / 4 + eps / 4 + eps / 4 +
  Cnorm (f1 x * ((f2 (x + h * v)%C - f2 x) / (h * v) - l2)))%R ;
  [repeat apply Rplus_le_compat_r ; apply Rplus_le_compat_l |].
  rewrite Cnorm_Cmult ; apply Rle_trans with (Cnorm l1 * (eps / 4 / Cnorm l1))%R ;
  [apply Rmult_le_compat_l ; [apply Cnorm_pos |] | right ; field ;
  apply Cnorm_no_R0 ; assumption].
  apply Rle_trans with (Rmin 1 (eps / 4 / Cnorm l1)) ; [| apply Rmin_r].
  apply Rle_trans with (dist C_met (f2 (x + h * v)) (f2 x)) ; [simpl ;
  unfold C_dist ; right ; reflexivity | left ; apply Hdelta3].
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rle_trans with
  (Rmin delta2 delta3) ; apply Rmin_r].
  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4)%R ; [| right ; field].
  apply Rplus_lt_compat_l.
  rewrite Cnorm_Cmult ; apply Rlt_le_trans with (Cnorm (f1 x) *
  (eps / 4 / Cnorm (f1 x)))%R ; [apply Rmult_lt_compat_l  ; [apply Cnorm_pos_lt ;
  assumption |] | right ; field ; apply Cnorm_no_R0 ; assumption] ;
  apply Hdelta2.
  assumption.
  apply Rlt_le_trans with delta ; [apply h_ub | apply Rle_trans with
  (Rmin delta2 delta3) ; [apply Rmin_r | apply Rmin_l]].
Qed.

Lemma differentiable_pt_lim_scal : forall f a x v l, v <> C0 ->
    differentiable_pt_lim f x v l -> differentiable_pt_lim (fun x => a * f x) x v (a * l).
Proof.
  intros f a x v l v_neq f_diff.
  assert (H0 := differentiable_pt_lim_const a x v).
  replace (mult_real_fct a f) with (fct_cte a * f)%F.
  replace (a * l) with (C0 * f x + a * l); [ idtac | ring ].
  apply (differentiable_pt_lim_mult (fct_cte a) f x v 0 l) ; assumption.
  unfold mult_real_fct, mult_fct, fct_cte in |- *; reflexivity.
Qed.

Lemma differentiable_pt_lim_id : forall x v, differentiable_pt_lim id x v C1.
Proof.
  intros x v v_neq ; unfold differentiable_pt_lim in |- *.
  intros eps Heps; exists (mkposreal eps Heps); intros h H1 H2;
    unfold id in |- *; replace ((x + h * v - x) / (h * v) - C1) with C0.
    rewrite Cnorm_C0 ; assumption.
    replace (x + h * v - x) with (h * v) by ring.
  replace (h *v / (h *v)) with C1.
  unfold Cminus ; rewrite Cadd_opp_r ; reflexivity.
  unfold Cdiv ; rewrite Cinv_r ; trivial.
  apply Cmult_integral_contrapositive_currified ; [apply IRC_neq_0_compat |] ;
  assumption.
Qed.


(*
(C) Copyright 2010, COQTAIL team

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

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

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

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

Require Import Coq.Relations.Relation_Definitions.
Require Import SetoidClass.
Require Import Reals.
Require Import Type_class_definition_beta.
Require Import Omega.

(*proof that nat = semiring_commutative*)

(* begin hide *)
Ltac int_hierarchy := match goal with
  | |- forall a, ?b => intro; int_hierarchy
  | |- ?a = ?b => rewrite mult_plus_distr_l; int_hierarchy
  | |- ?a = ?b => rewrite mult_plus_distr_r; int_hierarchy
  | |- ?a = ?b => progress auto
  | |- ?a = ?b => omega
  | |- ?a = ?b => progress auto with *
  | |- ?a = ?b => subst; progress trivial
  | |- _ => constructor; int_hierarchy
  | |- _ => intro; int_hierarchy
end.
(* end hide *)

Open Scope nat_scope.

Lemma aux_plus_0_l : forall x : nat, (fun _ : nat => True) x -> 0 + x = x.
Proof.
intros.
exact (plus_0_l x).
Qed.

Program Instance monoid_nat : Monoid nat (fun n:nat => True) eq plus 0 :=
{monoid_iden_l := aux_plus_0_l}.
Solve All Obligations with int_hierarchy.

Program Instance monoid_commutative_nat : Monoid_Commutative nat (fun n:nat => True) eq plus 0 :=
{monoid_comm_monoid := monoid_nat}.
Solve All Obligations with int_hierarchy.

Lemma aux_mult_1_l : forall x : nat, (fun _ : nat => True) x -> 1 * x = x.
Proof.
intros.
exact (mult_1_l x).
Qed.

Program Instance monoid_nat_mult_1 : Monoid nat (fun n:nat => True) eq mult 1 :=
{monoid_iden_l := aux_mult_1_l }.
Solve All Obligations with int_hierarchy.

Program Instance semiring_nat : SemiRing nat (fun n:nat => True) eq plus mult 0 1 :=
{semiring_monoid_comm := monoid_commutative_nat}.
Solve All Obligations with int_hierarchy.

Program Instance semiring_commutative_nat : SemiRing_Commutative nat (fun n:nat => True) eq plus mult 0 1 :=
{semiring_comm_semiring := semiring_nat}.
Solve All Obligations with int_hierarchy.


(** IotaDescription.v : Russel's iota operator and definite description*)

From Babel Require Import TerminalDogma.

From Coq Require Export Description.

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

Module Iota.
Section ClassDef.

Definition mixin_of (T : Type) (P : T -> Prop) := exists! x, P x.
Notation class_of := mixin_of (only parsing).

Structure type (T : Type) := Pack {
    obj : T -> Prop;
    _ : class_of obj;
}.

Local Coercion obj : type >-> Funclass.

Variable (T : Type) (P : type T).

Definition class :=
    let: Pack _ c as cT' := P return class_of cT' in c.

Definition pack := Pack.

Definition iota_sigma :=
    constructive_definite_description P class.

Definition iota_term := proj1_sig iota_sigma.
Definition iota_spec := proj2_sig iota_sigma : (P iota_term).

End ClassDef.

Module Exports.
#[reversible]
Coercion obj : type >-> Funclass.

Notation iota := type.
Notation Iota T m := (@pack _ T m).

Notation ι := iota_term.

(** understand [iota_spec] as [forall P: T -> Prop, P (ι P)] *)
Notation iota_spec := iota_spec.

End Exports.

End Iota.
Export Iota.Exports.

Lemma iota_eqP (T : Type) (P : iota T) (t : T) :
    ι(P) = t <-> P t.
Proof.
    split.
    move <-. by apply iota_spec.

    move : (Iota.class P).
    rewrite /Iota.mixin_of //= => [] [] x [] HPx H.
    move => HPt.
    transitivity x.
    symmetry. apply H. by apply iota_spec.
    by apply H.

Qed.


(* Definition of high-level semantics *)
Require Import List Relations CpdtTactics.

(* Model *)
Record HLocalState := HHonest {hhl_input: bool; hhl_decision: option bool}.

Definition HGlobalState := list HLocalState.

Definition wf_init_ls (ls : HLocalState) : Prop :=
  hhl_decision ls = None.

Definition wf_init_gs (gs : HGlobalState) : Prop := Forall wf_init_ls gs.

(* Semantics *)
Inductive HStep : HGlobalState -> HGlobalState -> Prop :=
| NOTHING : forall gs, HStep gs gs
| DECIDE : forall gs1 ls gs2 b,
    (forall ls', In ls' (gs1 ++ ls::gs2) -> hhl_decision ls' = None) ->
    HStep (gs1 ++ ls::gs2) (gs1 ++ (HHonest (hhl_input ls) (Some b))::gs2)
| AGREE : forall gs1 ls gs2 b ls',
    In ls' (gs1 ++ ls::gs2) ->
    hhl_decision ls' = Some b ->
    HStep (gs1 ++ ls::gs2) (gs1 ++ (HHonest (hhl_input ls) (Some b))::gs2).

(* Note, an alternative would be to remove NOTHING from HStep and define HSteps
   to be the reflexive, transitive closure instead of just the transitive closure. *)
Definition HSteps := clos_trans_1n _ HStep.

Record HInitialParams := HInitP {h_inputs : list bool}.

Definition HinitLS (b:bool) := HHonest b None.

Definition HinitGS (params : HInitialParams) :=
  List.map HinitLS (h_inputs params).

Definition HisValid (params : HInitialParams) (gs:HGlobalState) :=
  HSteps (HinitGS params) gs.

Definition hls_agree b (ls : HLocalState) : Prop :=
  match hhl_decision ls with
  | None => True
  | Some b' => b = b'
  end.

Definition hgs_agree b (gs : HGlobalState) : Prop := Forall (hls_agree b) gs.

Definition agree (gs : HGlobalState) : Prop := exists b, hgs_agree b gs.

Lemma hgs_agree_inv : forall b gs1 ls gs2, hgs_agree b (gs1 ++ ls::gs2) -> hls_agree b ls.
Proof.
  induction gs1 ; crush ; inversion H ; crush ; eauto.
Qed.

Lemma Hextract_agree : forall gs1 ls gs2 b, hhl_decision ls = Some b -> agree (gs1++ls::gs2) ->
                                            hgs_agree b (gs1 ++ ls :: gs2).
Proof.
  intros gs1 ls gs2 b H1 [b' H2].
  pose (hgs_agree_inv _ _ _ _ H2).
  destruct ls ; crush.
Qed.

Lemma in_hgs_agree : forall ls b b' gs, hhl_decision ls = Some b -> In ls gs -> hgs_agree b' gs -> b = b'.
Proof.
  induction gs ; crush ; inversion H1 ; subst.
  + destruct ls ; crush.
  + apply H3 ; crush.
Qed.

Lemma hgs_agree_app : forall b gs1 gs2, hgs_agree b (gs1 ++ gs2) <-> hgs_agree b gs1 /\ hgs_agree b gs2.
Proof.
 induction gs1 ; crush. constructor.
 inversion H ; clear H ; subst.
 apply Forall_cons ; crush.
 specialize (IHgs1 gs2). destruct IHgs1.
 specialize (H H3). destruct H. auto.
 inversion H ; clear H ; subst.
 specialize (IHgs1 gs2). destruct IHgs1.
 specialize (H H3). destruct H ; auto.
 inversion H0 ; clear H0 ; subst.
 apply Forall_cons ; crush.
 specialize (IHgs1 gs2).
 apply IHgs1 ; auto.
Qed.

Lemma hgs_agree_c : forall b gs1 ls gs2, hgs_agree b (gs1 ++ ls::gs2) <->
                                         hgs_agree b gs1 /\ hls_agree b ls /\ hgs_agree b gs2.
Proof.
  intros ; split ; intros.
  rewrite hgs_agree_app in H. destruct H.
  inversion H0 ; subst. crush.
  destruct H as [H1 [H2 H3]].
  rewrite hgs_agree_app. crush.
  apply Forall_cons ; crush.
Qed.

Lemma Hstep_keeps_agreement : forall gs gs', HStep gs gs' -> agree gs -> agree gs'.
Proof.
  intros gs gs' H.
  inversion H ; clear H ; crush.
  + clear H. exists b. induction gs1 ; crush.
    * apply Forall_cons. unfold hls_agree ; crush.
      induction gs2 ; crush.
      apply Forall_cons. unfold hls_agree. rewrite (H0 a) ; crush.
      apply IHgs2. crush.
    * apply Forall_cons.
      - unfold hls_agree. rewrite H0 ; crush.
      - apply IHgs1 ; crush.
 + destruct H as [b' H].
   generalize (in_hgs_agree _ _ _ _ H1 H0 H) ; intro ; subst.
   exists b'.
   rewrite hgs_agree_c in * ; crush.
Qed.

Lemma Hsteps_keeps_agreement : forall gs gs', HSteps gs gs' -> agree gs -> agree gs'.
Proof.
  induction 1 ; intros ; generalize (Hstep_keeps_agreement _ _ H) ; auto.
Qed.

Lemma HinitGS_keeps_agreement : forall input, agree (HinitGS (HInitP input)).
Proof.
  intros. exists true. unfold HinitGS ; simpl.
  induction input ; simpl. econstructor.
  apply Forall_cons ; crush.
  unfold HinitLS. unfold hls_agree. simpl. auto.
Qed.

Lemma HAgreement : forall params gs, HisValid params gs -> agree gs.
Proof.
  intros.
  apply (Hsteps_keeps_agreement (HinitGS params) gs H).
  apply HinitGS_keeps_agreement.
Qed.


(** * LogicBasic.v*)

From Babel Require Import TerminalDogma.

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

Lemma iff_True_R (P : Prop) :
    (P <-> True) <-> P.
Proof. split. by move ->. by move => HP; split. Qed.

Lemma iff_True_L (P : Prop) :
    (True <-> P) <-> P.
Proof. split.
    move => H. symmetry in H. by rewrite iff_True_R in H.
    by [].
Qed.


Require Import PlutusCert.Language.PlutusIR.
Import NamedTerm.

Require Export PlutusCert.Language.PlutusIR.Analysis.BoundVars.

Require Import Coq.Lists.List.
Require Import Coq.Strings.String.

Module Ty.

  Inductive appears_free_in : tyname -> Ty -> Prop :=
    | AFI_TyVar : forall X,
        appears_free_in X (Ty_Var X)
    | AFI_TyFun1 : forall X T1 T2,
        appears_free_in X T1 ->
        appears_free_in X (Ty_Fun T1 T2)
    | AFI_TyFun2 : forall X T1 T2,
        appears_free_in X T2 ->
        appears_free_in X (Ty_Fun T1 T2)
    | AFI_TyIFix1 : forall X F T,
        appears_free_in X F ->
        appears_free_in X (Ty_IFix F T)
    | AFI_TyIFix2 : forall X F T,
        appears_free_in X T ->
        appears_free_in X (Ty_IFix F T)
    | AFI_TyForall : forall X bX K T,
        X <> bX ->
        appears_free_in X T ->
        appears_free_in X (Ty_Forall bX K T)
    | AFI_TyLam : forall X bX K T,
        X <> bX ->
        appears_free_in X T ->
        appears_free_in X (Ty_Lam bX K T)
    | AFI_TyApp1 : forall X T1 T2,
        appears_free_in X T1 ->
        appears_free_in X (Ty_App T1 T2)
    | AFI_TyApp2 : forall X T1 T2,
        appears_free_in X T2 ->
        appears_free_in X (Ty_App T1 T2)
    .

  Definition closed (T : Ty) :=
    forall X, ~(appears_free_in X T).

End Ty.

Module Term.

  Inductive appears_free_in : name -> Term -> Prop :=
    | AFIT_Let : forall x r bs t,
        ~(In x (bvbs bs)) ->
        appears_free_in x t ->
        appears_free_in x (Let r bs t)
    | AFIT_LetNonRec : forall x bs t,
        appears_free_in__bindings_nonrec x bs ->
        appears_free_in x (Let NonRec bs t)
    | AFIT_LetRec : forall x bs t,
        ~(In x (bvbs bs)) ->
        appears_free_in__bindings_rec x bs ->
        appears_free_in x (Let Rec bs t)
    | AFIT_Var : forall x,
        appears_free_in x (Var x)
    | AFIT_TyAbs : forall x bX K t0,
        appears_free_in x t0 ->
        appears_free_in x (TyAbs bX K t0)
    | AFIT_LamAbs : forall x bx T t0,
        x <> bx ->
        appears_free_in x t0 ->
        appears_free_in x (LamAbs bx T t0)
    | AFIT_Apply1 : forall x t1 t2,
        appears_free_in x t1 ->
        appears_free_in x (Apply t1 t2)
    | AFIT_Apply2 : forall x t1 t2,
        appears_free_in x t2 ->
        appears_free_in x (Apply t1 t2)
    | AFIT_TyInst : forall x t0 T,
        appears_free_in x t0 ->
        appears_free_in x (TyInst t0 T)
    | AFIT_IWrap : forall x F T t0,
        appears_free_in x t0 ->
        appears_free_in x (IWrap F T t0)
    | AFIT_Unwrap : forall x t0,
        appears_free_in x t0 ->
        appears_free_in x (Unwrap t0)

  with appears_free_in__bindings_nonrec : name -> list Binding -> Prop :=
    | AFIT_ConsB1_NonRec : forall x b bs,
        appears_free_in__binding x b ->
        appears_free_in__bindings_nonrec x (b :: bs)
    | AFIT_ConsB2_NonRec : forall x b bs,
        ~(In x (bvb b)) ->
        appears_free_in__bindings_nonrec x bs ->
        appears_free_in__bindings_nonrec x (b :: bs)

  with appears_free_in__bindings_rec : name -> list Binding -> Prop :=
    | AFIT_ConsB1_Rec : forall x b bs,
        appears_free_in__binding x b ->
        appears_free_in__bindings_rec x (b :: bs)
    | AFIT_ConsB2_Rec : forall x b bs,
        appears_free_in__bindings_rec x bs ->
        appears_free_in__bindings_rec x (b :: bs)

  with appears_free_in__binding : name -> Binding -> Prop :=
    | AFIT_TermBind : forall x s vd t0,
        appears_free_in x t0 ->
        appears_free_in__binding x (TermBind s vd t0)
    .

  Definition closed (t : Term) :=
    forall x, ~(appears_free_in x t).

End Term.

Module Annotation.

  Fixpoint splitTy (T : Ty) : list Ty * Ty :=
    match T with
    | Ty_Fun Targ T' => (cons Targ (fst (splitTy T')), snd (splitTy T'))
    | Tr => (nil, Tr)
    end.

  Definition fromDecl (tvd : tvdecl tyname) : tyname * Kind :=
    match tvd with
    | TyVarDecl v K => (v, K)
    end.

  Inductive appears_free_in (X : tyname) : Term -> Prop :=
    | AFIA_Let : forall r bs t,
        ~(In X (btvbs bs)) ->
        appears_free_in X t ->
        appears_free_in X (Let r bs t)
    | AFIA_LetNonRec : forall bs t,
        appears_free_in__bindings_nonrec X bs ->
        appears_free_in X (Let NonRec bs t)
    | AFIA_LetRec : forall bs t,
        ~(In X (btvbs bs)) ->
        appears_free_in__bindings_rec X bs ->
        appears_free_in X (Let Rec bs t)
    | AFIA_TyAbs : forall bX K t0,
        X <> bX ->
        appears_free_in X t0 ->
        appears_free_in X (TyAbs bX K t0)
    | AFIA_LamAbs1 : forall bx T t0,
        Ty.appears_free_in X T ->
        appears_free_in X (LamAbs bx T t0)
    | AFIA_LamAbs2 : forall bx T t0,
        appears_free_in X t0 ->
        appears_free_in X (LamAbs bx T t0)
    | AFIA_Apply1 : forall t1 t2,
        appears_free_in X t1 ->
        appears_free_in X (Apply t1 t2)
    | AFIA_Apply2 : forall t1 t2,
        appears_free_in X t2 ->
        appears_free_in X (Apply t1 t2)
    | AFIA_TyInst1 : forall t0 T,
        Ty.appears_free_in X T ->
        appears_free_in X (TyInst t0 T)
    | AFIA_TyInst2 : forall t0 T,
        appears_free_in X t0 ->
        appears_free_in X (TyInst t0 T)
    | AFIA_IWrap1 : forall F T t0,
        Ty.appears_free_in X F ->
        appears_free_in X (IWrap F T t0)
    | AFIA_IWrap2 : forall F T t0,
        Ty.appears_free_in X T ->
        appears_free_in X (IWrap F T t0)
    | AFIA_IWrap3 : forall F T t0,
        appears_free_in X t0 ->
        appears_free_in X (IWrap F T t0)
    | AFIA_Unwrap : forall t0,
        appears_free_in X t0 ->
        appears_free_in X (Unwrap t0)

  with appears_free_in__constructor (X : tyname) : constructor -> Prop :=
    | AFIA_Constructor : forall x T ar Targs Tr,
        (Targs, Tr) = splitTy T ->
        (exists U, In U Targs /\ Ty.appears_free_in X U) ->
        appears_free_in__constructor X (Constructor (VarDecl x T) ar)

  with appears_free_in__bindings_nonrec (X : tyname) : list Binding -> Prop :=
    | AFIA_ConsB1_NonRec : forall b bs,
        appears_free_in__binding X b ->
        appears_free_in__bindings_nonrec X (b :: bs)
    | AFIA_ConsB2_NonRec : forall b bs,
        ~(In X (btvb b)) ->
        appears_free_in__bindings_nonrec X bs ->
        appears_free_in__bindings_nonrec X (b :: bs)

  with appears_free_in__bindings_rec (X : tyname) : list Binding -> Prop :=
    | AFIA_ConsB1_Rec : forall b bs,
        appears_free_in__binding X b ->
        appears_free_in__bindings_rec X (b :: bs)
    | AFIA_ConsB2_Rec : forall b bs,
        appears_free_in__bindings_rec X bs ->
        appears_free_in__bindings_rec X (b :: bs)

  with appears_free_in__binding (X: tyname) : Binding -> Prop :=
    | AFIA_TermBind1 : forall s x T t0,
        Ty.appears_free_in X T ->
        appears_free_in__binding X (TermBind s (VarDecl x T) t0)
    | AFIA_TermBind2 : forall s x T t0,
        appears_free_in X t0 ->
        appears_free_in__binding X (TermBind s (VarDecl x T) t0)
    | AFI_TypeBind : forall Y K T,
        Ty.appears_free_in X T ->
        appears_free_in__binding X (TypeBind (TyVarDecl Y K) T)
    | AFI_DatatypeBind : forall Y K ZKs matchFunc cs,
        ~ In X (map fst (rev (map fromDecl ZKs))) ->
        (exists c, In c cs /\ appears_free_in__constructor X c) ->
        appears_free_in__binding X (DatatypeBind (Datatype (TyVarDecl Y K) ZKs matchFunc cs))
  .

  Definition closed (t : Term) :=
    forall x, ~(appears_free_in x t).

End Annotation.

#[export] Hint Constructors
  Ty.appears_free_in
  : core.

#[export] Hint Constructors
  Term.appears_free_in
  Term.appears_free_in__bindings_nonrec
  Term.appears_free_in__bindings_rec
  Term.appears_free_in__binding
  : core.

#[export] Hint Constructors
  Annotation.appears_free_in
  Annotation.appears_free_in__constructor
  Annotation.appears_free_in__bindings_nonrec
  Annotation.appears_free_in__bindings_rec
  Annotation.appears_free_in__binding : core.

(** Full closedness of terms (and type annotations) *)
Definition closed (t : Term) :=
  (forall x, ~(Term.appears_free_in x t)) /\ (forall X, ~(Annotation.appears_free_in X t)).


Set Implicit Arguments.

Require Import Syntax.
Import String Memory IL SyntaxExpr.
Require Import Notations3.
Require Import Semantics.
Require Import GeneralTactics.
Import SemanticsExpr.

Require Import StringSet.
Import StringSet.
Require Import StringSetFacts.
Require Import StringSetTactics.

Definition SET := t.

Ltac openhyp' :=
  repeat match goal with
           | H : context [In_dec ?A ?B] |- _ => destruct (In_dec A B)
           | |- context [In_dec ?A ?B] => destruct (In_dec A B)
           | H : context [ { _ | _ } ] |- _ => destruct H
         end.

Ltac unfold_all :=
  repeat match goal with
           | H := _ |- _ => unfold H in *; clear H
         end.

Ltac f_equal' :=
  match goal with
    | |- (if ?E1 then _ else _) = (if ?E2 then _ else _) => replace E2 with E1; try reflexivity
  end.

Section TopSection.

  Notation "m %%- k" := (remove k m) (at level 60).
  Infix "<=" := Subset : set_scope.
  Infix "+" := union.
  Infix "-" := diff.
  Notation "! x" := (singleton x) (at level 40).
  Notation "[]" := (@empty _).
  Open Scope set_scope.
  Open Scope stmt_scope.
  Infix "<-" := Syntax.Assign.

  Fixpoint used_vars e :=
    match e with
      | Const _ => empty
      | Var x => !x
      | Binop _ a b => used_vars a + used_vars b
      | TestE _ a b => used_vars a + used_vars b
    end.

  Require Import Union.

  Fixpoint used_vars_stmt s :=
    match s with
      | skip => empty
      | a ;; b => used_vars_stmt a + used_vars_stmt b
      | Syntax.If e t f => used_vars e + used_vars_stmt t + used_vars_stmt f
      | Syntax.While e body => used_vars e + used_vars_stmt body
      | _ <- e => used_vars e
      | Syntax.Label _ _ => empty
      | Syntax.Call _ f args => used_vars f + union_list (List.map used_vars args)
    end.

  Require Import Option.

  Fixpoint elim_dead s used : Stmt * SET :=
    match s with
      | skip => (s, used)
      | a ;; b =>
        let result := elim_dead b used in
        let b := fst result in
        let used := snd result in
        let result := elim_dead a used in
        let a := fst result in
        let used := snd result in
        (a ;; b, used)
      | Syntax.If e t f =>
        let result := elim_dead t used in
        let t := fst result in
        let used_t := snd result in
        let result := elim_dead f used in
        let f := fst result in
        let used_f := snd result in
        (Syntax.If e t f, used_vars e + used_t + used_f)
      | Syntax.While e body =>
        let result := elim_dead body (used + used_vars e + used_vars_stmt body) in
        let body := fst result in
        let used' := snd result in
        (Syntax.While e body, used + used' + used_vars e)
      | x <- e =>
        if In_dec x used then
          (s, used - !x + used_vars e)
        else
          (skip, used)
      | Syntax.Label x _ =>
        (s, used - !x)
      | Syntax.Call x f args =>
        (s, used - (default empty (option_map singleton x)) + used_vars f + union_list (List.map used_vars args))
    end.

  Definition opt s retvar := fst (elim_dead s (!retvar)).

  Hint Extern 0 (Subset _ _) => progress (simpl; subset_solver).
  Hint Resolve union_subset_1.
  Hint Resolve union_subset_2.
  Hint Resolve diff_subset.

  Definition agree_in a b s := forall x, In x s -> Locals.sel a x = Locals.sel b x.

  Lemma agree_in_symm : forall a b s, agree_in a b s -> agree_in b a s.
    unfold agree_in; intros; symmetry; eauto.
  Qed.

  Hint Resolve agree_in_symm.

  Lemma agree_in_subset : forall a b s s', agree_in a b s -> s' <= s -> agree_in a b s'.
    unfold agree_in, Subset; intros; eauto.
  Qed.

  Hint Resolve agree_in_subset.

  Require Import GeneralTactics2.

  Lemma upd_same_agree_in : forall a b s x w, agree_in a b (s - !x) -> agree_in (upd a x w) (upd b x w) s.
    unfold agree_in; intros.
    destruct (string_dec x x0).
    subst.
    repeat rewrite sel_upd_eq; eauto.
    repeat rewrite sel_upd_ne.
    eapply H; eauto.
    eapply diff_iff.
    split; eauto.
    not_not.
    eapply singleton_iff in H1; eauto.
    eauto.
    eauto.
  Qed.

  Hint Resolve upd_same_agree_in.

  Lemma upd_out_agree_in : forall a b s x w, agree_in a b s -> ~ In x s -> agree_in (upd a x w) b s.
    unfold agree_in; intros.
    destruct (string_dec x x0).
    subst; intuition.
    repeat rewrite sel_upd_ne; eauto.
  Qed.

  Hint Resolve upd_out_agree_in.

  Lemma elim_dead_upper_bound :
    forall s used,
      let result := elim_dead s used in
      let used' := snd result in
      used' <= used + used_vars_stmt s.
  Proof.
    induction s; simpl; intros; openhyp'; intuition eauto using subset_trans.
    Grab Existential Variables.
    eapply empty.
  Qed.

  Hint Resolve elim_dead_upper_bound.

  Lemma eval_agree_in : forall e a b, agree_in a b (used_vars e) -> eval a e = eval b e.
    induction e; simpl; intuition.
    eapply H; eapply singleton_iff; eauto.
    f_equal; eauto.
    f_equal'; f_equal; eauto.
  Qed.

  Lemma eval_agree_in_list : forall es a b, agree_in a b (union_list (List.map used_vars es)) -> List.map (eval a) es = List.map (eval b) es.
    induction es; simpl; intuition.
    f_equal.
    eapply eval_agree_in; eauto.
    eauto.
  Qed.

End TopSection.

Require Import ADT.

Module Make (Import E : ADT).

  Require Import GoodOptimizer.
  Module Import GoodOptimizerMake := GoodOptimizer.Make E.
  Require Import Semantics.
  Import SemanticsMake.

  Section TopSection.

    Hint Unfold RunsTo.
    Hint Constructors Semantics.RunsTo.
    Hint Unfold Safe.
    Hint Constructors Semantics.Safe.

    Notation "m %%- k" := (remove k m) (at level 60).
    Infix "<=" := Subset : set_scope.
    Infix "+" := union.
    Infix "-" := diff.
    Notation "! x" := (singleton x) (at level 40).
    Notation "[]" := (@empty _).
    Open Scope set_scope.
    Open Scope stmt_scope.
    Infix "<-" := Syntax.Assign.

    Hint Extern 0 (Subset _ _) => progress (simpl; subset_solver).
    Hint Resolve union_subset_1.
    Hint Resolve union_subset_2.
    Hint Resolve diff_subset.
    Hint Resolve agree_in_symm.
    Hint Resolve agree_in_subset.
    Hint Resolve upd_same_agree_in.
    Hint Resolve upd_out_agree_in.
    Hint Resolve elim_dead_upper_bound.

    Lemma while_case :
      forall fs t v v',
        RunsTo fs t v v' ->
        forall e body used vs,
          let s := Syntax.While e body in
          let result := elim_dead s used in
          let s' := fst result in
          let used' := snd result in
          let vt := fst v in
          let heap := snd v in
          let vt' := fst v' in
          let heap' := snd v' in
          t = s' ->
          agree_in vs vt used' ->
          (
            let s := body in

            forall (used : SET) (vs vt : vals) (heap : Heap)
                   (vt' : vals) (heap' : Heap),
              let result := elim_dead s used in
              let t := fst result in
              let used' := snd result in
              RunsTo fs t (vt, heap) (vt', heap') ->
              agree_in vs vt used' ->
              exists vs' : vals,
                RunsTo fs s (vs, heap) (vs', heap') /\ agree_in vs' vt' used
          ) ->
          exists vs',
            RunsTo fs s (vs, heap) (vs', heap') /\
            agree_in vs' vt' used.
    Proof.
      induction 1; simpl; intros; unfold_all; subst; intuition.

      injection H2; intros; subst.
      destruct v; simpl in *.
      destruct v'; simpl in *.
      eapply H4 in H0; eauto; openhyp.
      destruct v''; simpl in *.
      edestruct IHRunsTo2; try reflexivity.
      2 : eauto.
      eauto using subset_trans.
      openhyp.
      descend.
      econstructor.
      simpl.
      repeat erewrite (@eval_agree_in _ vs w) by eauto.
      eauto.
      eauto.
      eauto.
      eauto.

      injection H0; intros; subst.
      descend.
      eapply RunsToWhileFalse.
      simpl.
      repeat erewrite (@eval_agree_in _ vs (fst v)) by eauto.
      eauto.
      eauto.
    Qed.

    Lemma subset_diff_empty : forall s, s <= s - empty.
      unfold Subset; intros.
      eapply diff_iff; split; eauto.
      nintro.
      eapply empty_iff in H0; intuition.
    Qed.

    Hint Resolve subset_diff_empty.

    Lemma elim_dead_is_bp :
      forall fs s used vs vt heap vt' heap',
        let result := elim_dead s used in
        let t := fst result in
        let used' := snd result in
        RunsTo fs t (vt, heap) (vt', heap') ->
        agree_in vs vt used' ->
        exists vs',
          RunsTo fs s (vs, heap) (vs', heap') /\
          agree_in vs' vt' used.
    Proof.
      induction s; simpl; intros.

      (* skip *)
      inversion H; unfold_all; subst.
      descend.
      eauto.
      eauto.

      (* seq *)
      inversion H; unfold_all; subst.
      destruct v'; simpl in *.
      eapply IHs1 in H3; eauto; openhyp.
      eapply IHs2 in H6; eauto; openhyp.
      descend.
      eauto.
      eauto.

      (* if *)
      inversion H; unfold_all; subst.
      simpl in *.
      eapply IHs1 in H7; eauto; openhyp.
      descend.
      eapply RunsToIfTrue.
      simpl.
      repeat erewrite (@eval_agree_in _ vs vt) by eauto.
      eauto.
      eauto.
      eauto.

      simpl in *.
      eapply IHs2 in H7; eauto; openhyp.
      descend.
      eapply RunsToIfFalse.
      simpl.
      repeat erewrite (@eval_agree_in _ vs vt) by eauto.
      eauto.
      eauto.
      eauto.

      (* while *)
      eapply while_case in H; eauto.

      Focus 3.
      (* assign *)
      openhyp'; simpl in *.
      inversion H; unfold_all; subst.
      descend; intuition.
      econstructor.
      erewrite eval_agree_in by eauto.
      simpl in *; eauto.

      inversion H; unfold_all; subst.
      descend; intuition.
      econstructor.
      simpl in *; eauto.

      (* call *)
      destruct o; simpl in *.
      inversion H; unfold_all; subst; simpl in *.
      descend.
      eapply RunsToCallInternal; simpl in *; eauto.
      repeat erewrite (@eval_agree_in _ vs vt) by eauto.
      eauto.
      repeat erewrite (@eval_agree_in_list _ vs vt) by eauto.
      eauto.
      simpl in *.
      eauto.

      simpl in *.
      descend.
      eapply RunsToCallForeign; simpl in *; eauto.
      repeat erewrite (@eval_agree_in _ vs vt) by eauto.
      eauto.
      repeat erewrite (@eval_agree_in_list _ vs vt) by eauto.
      eauto.
      simpl in *.
      eauto.

      inversion H; unfold_all; subst; simpl in *.
      descend.
      eapply RunsToCallInternal; simpl in *; eauto.
      repeat erewrite (@eval_agree_in _ vs vt) by eauto.
      eauto.
      repeat erewrite (@eval_agree_in_list _ vs vt) by eauto.
      eauto.
      simpl in *.
      eauto.

      simpl in *.
      descend.
      eapply RunsToCallForeign; simpl in *; eauto.
      repeat erewrite (@eval_agree_in _ vs vt) by eauto.
      eauto.
      repeat erewrite (@eval_agree_in_list _ vs vt) by eauto.
      eauto.
      simpl in *.
      eauto.

      (* label *)
      openhyp'; simpl in *.
      inversion H; unfold_all; subst.
      descend; intuition.
      econstructor; eauto.
      simpl in *; eauto.

    Qed.

    Lemma elim_dead_is_sp :
      forall fs s used vs vt heap,
        let result := elim_dead s used in
        let t := fst result in
        let used' := snd result in
        Safe fs s (vs, heap) ->
        agree_in vs vt used' ->
        Safe fs t (vt, heap).
    Proof.
      induction s.

      Focus 4.
      intros.
      unfold_all.
      eapply
        (Safe_coind
           (fun t v =>
              (exists vs c b used,
                 let s := While c b in
                 let result := elim_dead s used in
                 let s' := fst result in
                 let used' := snd result in
                 let vt := fst v in
                 let heap := snd v in
                 Safe fs s (vs, heap) /\
                 agree_in vs vt used' /\
                 (let s := b in
                  forall (used : SET) (vs vt : vals) (heap : Heap),
                    Safe fs s (vs, heap) ->
                    agree_in vs vt (snd (elim_dead s used)) ->
                    Safe fs (fst (elim_dead s used)) (vt, heap)
                 ) /\
                 t = s') \/
              Safe fs t v
        )); [ .. | left; descend; simpl in *; intuition eauto ]; clear; simpl; intros; openhyp.

      (* seq *)
      intuition.

      inversion H; unfold_all; subst; intuition eauto.

      (* if *)
      intuition.

      inversion H; subst.
      unfold_all; openhyp.
      intuition eauto.
      right; intuition eauto.

      (* while *)
      injection H2; intros; subst.
      inversion H; unfold_all; subst.
      destruct v; simpl in *.
      left.
      repeat split.
      repeat erewrite (@eval_agree_in _ v x) by eauto.
      eauto.
      eauto.

      intros.
      left.
      destruct v'; simpl in *.
      eapply elim_dead_is_bp in H3; eauto; openhyp.
      descend.
      4 : eauto.
      eauto.
      eauto using subset_trans.
      eauto.

      simpl in *.
      right.
      destruct v; simpl in *.
      repeat erewrite (@eval_agree_in _ v x) by eauto.
      eauto.

      inversion H; unfold_all; subst.
      intuition eauto.
      right.
      intuition eauto.

      (* call *)
      intuition.

      inversion H; unfold_all; subst; eauto.

      left; descend; intuition eauto.
      right; descend; intuition eauto.

      (* label *)
      intuition.

      inversion H; unfold_all; subst; intuition eauto.

      (* end of while case *)

      (* skip *)
      simpl; intros.
      eauto.

      (* seq *)
      simpl in *; intros.
      inversion H; unfold_all; subst.
      econstructor.
      eapply IHs1; eauto.
      intros.
      destruct v'; simpl in *.
      eapply elim_dead_is_bp in H1; eauto; openhyp.
      eapply IHs2; eauto.

      (* if *)
      simpl in *; intros.
      inversion H; unfold_all; subst.
      openhyp.
      econstructor.
      left.
      split.
      simpl in *.
      repeat erewrite (@eval_agree_in _ vt vs) by eauto.
      eauto.
      eapply IHs1; eauto.

      econstructor.
      right.
      split.
      simpl in *.
      repeat erewrite (@eval_agree_in _ vt vs) by eauto.
      eauto.
      eapply IHs2; eauto.

      Focus 3.
      (* assign *)
      simpl; intros; openhyp'; simpl in *; eauto.

      (* call *)
      simpl; intros.
      inversion H; unfold_all; subst.
      econstructor; simpl in *; eauto.
      repeat erewrite (@eval_agree_in _ vt vs) by eauto.
      eauto.
      repeat erewrite (@eval_agree_in_list _ vt vs) by eauto.
      eauto.

      eapply SafeCallForeign; simpl in *; eauto.
      repeat erewrite (@eval_agree_in _ vt vs) by eauto.
      eauto.
      repeat erewrite (@eval_agree_in_list _ vt vs) by eauto.
      eauto.

      (* label *)
      simpl; intros; openhyp'; simpl in *; eauto.
      inversion_clear H.
      econstructor; eauto.
    Qed.

    Require Import FreeVars.

    Lemma elim_dead_footprint : forall s m, free_vars (fst (elim_dead s m)) <= free_vars s.
    Proof.
      induction s; simpl; intros; openhyp'; simpl in *; subset_solver; eauto using subset_trans.
    Qed.

    Open Scope nat.

    Require Import Depth.
    Require Import Le.
    Require Import MaxFacts.

    Hint Extern 0 (le _ _) => progress (simpl; max_solver).
    Hint Resolve both_le le_n_S.

    Lemma elim_dead_depth : forall s m, depth (fst (elim_dead s m)) <= depth s.
    Proof.
      induction s; simpl; intros; openhyp'; simpl in *; max_solver; eauto using le_trans.
    Qed.

    Require Import GoodOptimizer.

    Lemma same_agree_in : forall a s, agree_in a a s.
      unfold agree_in; intros; eauto.
    Qed.

    Hint Resolve same_agree_in.

    Lemma agree_in_singleton : forall a b x, agree_in a b (!x) -> sel a x = sel b x.
      intros.
      eapply H.
      eapply singleton_iff; eauto.
    Qed.

    Hint Resolve agree_in_singleton.

    Lemma PreserveRunsTo_opt : PreserveRunsTo opt.
      unfold PreserveRunsTo, opt; intros.
      destruct v.
      destruct v'; simpl in *.
      eapply elim_dead_is_bp in H; openhyp; eauto.
    Qed.

    Lemma PreserveSafe_opt : PreserveSafe opt.
      unfold PreserveSafe, opt; intros.
      destruct v.
      eapply elim_dead_is_sp in H; openhyp; eauto.
    Qed.

    Require Import GetLocalVars.
    Require Import GetLocalVarsFacts.
    Import NPeano.Nat.

    Lemma PreserveGoodSize_opt : PreserveGoodSize opt.
      unfold PreserveGoodSize, opt; intros.
      eapply goodSize_weaken; eauto.
      eapply add_le_mono.
      2 : eapply elim_dead_depth.
      eapply get_local_vars_cardinal.
      eapply elim_dead_footprint; eauto.
    Qed.

    Require Import CompileStmtSpec.
    Require Import SetoidListFacts.
    Require Import GeneralTactics2.

    Require Import WellFormed.

    Hint Constructors args_not_too_long.

    Lemma opt_wellformed : forall s m, wellformed s -> wellformed (fst (elim_dead s m)).
      unfold wellformed.
      induction s; simpl; intuition; openhyp'; inversion_clear H; simpl in *; eauto.
    Qed.

    Lemma PreserveSynReq_opt : PreserveSynReq opt.
      unfold PreserveSynReq, opt; intros.
      unfold syn_req in *.
      unfold in_scope in *.
      openhyp.
      repeat split; eauto.
      eapply get_local_vars_subset; eauto.
      eapply opt_wellformed; eauto.
    Qed.

    Lemma good_optimizer : GoodOptimizer opt.
      unfold GoodOptimizer.
      split.
      eapply PreserveRunsTo_opt.
      split.
      eapply PreserveSafe_opt.
      split.
      eapply PreserveGoodSize_opt.
      eapply PreserveSynReq_opt.
    Qed.

  End TopSection.

End Make.


(* Written by Sosuke Moriguchi (chiguri), Kwansei Gakuin University *)

(** * Functor from Network Topology to a CCN protocol on the network *)

Require Import List.
Import ListNotations.

Require CCNTopology.

Module CCN_Protocol (N : CCNTopology.CCN_Network).
Import N.

(** Packet in network *)
Inductive Packet : Set :=
| Interest : Node -> Node -> Content_Name -> Packet
| Data : Node -> Node -> forall c : Content_Name, Content c -> Packet.

(** Event in CCS Network *)
Inductive Event :=
| Request : Node -> Content_Name -> Event
| ForwardInterest : Node -> Content_Name -> Event
| AddPIT : Node -> Node -> Content_Name -> Event
| ReplyData : Node -> Content_Name -> Event
| ForwardData : Node -> Content_Name -> Event (* ForwardData delete PIT entries for the Content_Name *)
| StoreData : Node -> forall c : Content_Name, Content c -> Event.
(* You may introduce deletions of contents in CS.
   If doing so, you should care about InitCS. *)
(* Droping packet is not an event in this formalization, but it is not matter. *)

(** Get Content : If this returns None, the content is not stored, i.e., CS match fails *)
Fixpoint Content_get (v : Node) (c : Content_Name) (es : list Event) : option (Content c) :=
match es with
| nil =>
   match InitCS_dec v c with
   | left x => Some (InitContent_Data v c x)
   | right _ => None
   end
| StoreData v' c' C :: es' =>
   match (Node_eq_dec v v', Content_Name_eq_dec c c') with
   | (left _, left x) => eq_rec_r (fun t => option (Content t)) (Some C) x
   | _ => Content_get v c es'
   end
| _ :: es' => Content_get v c es'
end.

(** Get PIT list : If this returns nil, no PIT entries are added / PIT match fails *)
Fixpoint PIT_list (v : Node) (c : Content_Name) (es : list Event) : list Node :=
match es with
| nil => nil
| AddPIT v1 v2 c' :: es' =>
    match Node_eq_dec v v1 with
    | left _ => match Content_Name_eq_dec c c' with
                | left _ => v2 :: PIT_list v c es'
                | right _ => PIT_list v c es'
                end
    | right _ => PIT_list v c es'
    end
| ForwardData v' c' :: es' =>
    match Node_eq_dec v v' with
    | left _ => match Content_Name_eq_dec c c' with
                | left _ => nil
                | right _ => PIT_list v c es'
                end
    | right _ => PIT_list v c es'
    end
| _ :: es' => PIT_list v c es'
end.

(** List of interest packet for [c] sent by user [v] *)
Definition Broadcast_Interest (v : Node) (c : Content_Name) : list Packet :=
  map (fun v' => Interest v v' c) (Connected_list v).

(** List of interest packet for [c] forwarded by user [v] *)
Definition FIB_Interest (v : Node) (c : Content_Name) : list Packet :=
  map (fun v' => Interest v v' c) (FIB_list v c).

(** List of data packet for [c] forwarded by user [v] to nodes in PIT entries *)
Definition PIT_Data (v : Node) (c : Content_Name) (C : Content c) (es : list Event) : list Packet :=
  map (fun v' => Data v v' c C) (PIT_list v c es).

(** Definition of behaviors of the CCN protocol *)
Inductive CCNprotocol : list Event -> list Packet -> Prop :=
| ccn_init : CCNprotocol nil nil
| ccn_request : forall (v : Node) (c : Content_Name) (es : list Event) (ps ps' : list Packet),
   CCNprotocol es ps ->
    Content_get v c es = None ->
    ps' = Broadcast_Interest v c ++ ps ->
    CCNprotocol (Request v c :: es) ps'
| ccn_forward_interest : forall (v v' : Node) (c : Content_Name) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Interest v v' c :: ps2) ->
    Content_get v' c es = None ->
    PIT_list v' c es = nil ->
    FIB_list v' c <> nil ->
    ps' = FIB_Interest v' c ++ ps1 ++ ps2 ->
    CCNprotocol (ForwardInterest v' c :: AddPIT v' v c :: es) ps'
| ccn_add_pit : forall (v v' : Node) (c : Content_Name) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Interest v v' c :: ps2) ->
    Content_get v' c es = None ->
    PIT_list v' c es <> nil ->
    ~ In v (PIT_list v' c es) ->
    FIB_list v' c <> nil ->
    ps' = ps1 ++ ps2 ->
    CCNprotocol (AddPIT v' v c :: es) ps'
| ccn_drop_interest_fib : forall (v v' : Node) (c : Content_Name) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Interest v v' c :: ps2) ->
    Content_get v' c es = None ->
    FIB_list v' c = nil ->
    ps' = ps1 ++ ps2 ->
    CCNprotocol es ps'
| ccn_drop_interest_pit : forall (v v' : Node) (c : Content_Name) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Interest v v' c :: ps2) ->
    Content_get v' c es = None ->
    In v (PIT_list v' c es) ->
    ps' = ps1 ++ ps2 ->
    CCNprotocol es ps'
| ccn_reply_data : forall (v v' : Node) (c : Content_Name) (C : Content c) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Interest v v' c :: ps2) ->
    Content_get v' c es = Some C ->
    ps' = Data v' v c C :: ps1 ++ ps2 ->
    CCNprotocol (ReplyData v' c :: es) ps'
| ccn_store_data : forall (v v' : Node) (c : Content_Name) (C : Content c) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Data v v' c C :: ps2) ->
    Content_get v' c es = None ->
    In (Request v' c) es ->
    PIT_list v' c es = nil ->
    ps' = ps1 ++ ps2 ->
    CCNprotocol (StoreData v' c C :: es) ps'
| ccn_forward_data : forall (v v' : Node) (c : Content_Name) (C : Content c) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Data v v' c C :: ps2) ->
    Content_get v' c es = None ->
    ~ In (Request v' c) es ->
    PIT_list v' c es <> nil ->
    ps' = (PIT_Data v' c C es) ++ ps1 ++ ps2 ->
    CCNprotocol (StoreData v' c C :: ForwardData v' c :: es) ps'
| ccn_store_forward : forall (v v' : Node) (c : Content_Name) (C : Content c) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Data v v' c C :: ps2) ->
    Content_get v' c es = None ->
    In (Request v' c) es ->
    PIT_list v' c es <> nil ->
    ps' = (PIT_Data v' c C es) ++ ps1 ++ ps2 ->
    CCNprotocol (StoreData v' c C :: ForwardData v' c :: es) ps'
| ccn_drop_data : forall (v v' : Node) (c : Content_Name) (C : Content c) (es : list Event) (ps1 ps2 ps' : list Packet),
   CCNprotocol es (ps1 ++ Data v v' c C :: ps2) ->
    Content_get v' c es <> None ->
    ps' = ps1 ++ ps2 ->
    CCNprotocol es ps'.

End CCN_Protocol.