(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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 General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.transc.TaylorSeries.

Opaque Min Max.

(**
* Exponential and Logarithmic Functions

The main properties of the exponential and logarithmic functions.

** Properties of Exponential

Exponential is strongly extensional and well defined.
*)

Lemma Exp_strext : forall x y : IR, Exp x [#] Exp y -> x [#] y.
Proof.
 intros x y H.
 exact (un_op_strext_unfolded _ _ _ _ H).
Qed.

Lemma Exp_wd : forall x y : IR, x [=] y -> Exp x [=] Exp y.
Proof.
 intros x y H.
 unfold Exp in |- *; algebra.
Qed.

#[global]
Hint Resolve Exp_wd: algebra.

Lemma Exp_zero : Exp [0] [=] [1].
Proof.
 unfold Exp in |- *; simpl in |- *.
 set (h := (fun n : nat => match n with | O => [1] | S p => [0] end):nat -> IR) in *.
 cut (forall n : nat, h n [=] ([1][/] _[//]nring_fac_ap_zero _ n) [*]nexp _ n ([0][-][0])).
  intro H.
  cut (convergent h).
   intro H0.
   apply eq_transitive_unfolded with (series_sum h H0).
    apply series_sum_wd; algebra.
   unfold series_sum in |- *.
   apply eq_symmetric_unfolded.
   eapply eq_transitive_unfolded.
    apply Lim_const.
   apply Lim_seq_eq_Lim_subseq with (f := fun n : nat => S n).
     auto with arith.
    intro n; exists (S n); split; auto with arith.
   intro n; simpl in |- *.
   induction  n as [| n Hrecn]; simpl in |- *; [ algebra | Step_final (OneR[+][0]) ].
  apply convergent_wd with (fun n : nat =>
    ([1][/] _[//]nring_fac_ap_zero IR n) [*]nexp _ n ([0][-][0])).
   algebra.
  exact (fun_series_conv_imp_conv [0] [0] (leEq_reflexive IR [0]) Exp_ps
    (Exp_conv [0] [0] (leEq_reflexive IR [0]) (compact_single_iprop realline [0] I)) [0]
      (compact_single_prop [0]) (fun_series_inc_IR realline Exp_ps Exp_conv [0] I)).
 simple destruct n; simpl in |- *; intros; rational.
Qed.

(** $e^1=e$#e1=e#, where [e] was defined a long time ago.
*)

Lemma Exp_one : Exp [1] [=] E.
Proof.
 unfold E, Exp, e_series in |- *; simpl in |- *.
 apply series_sum_wd; intro n.
 astepr (([1][/] _[//]nring_fac_ap_zero IR n) [*][1]); apply mult_wdr.
 astepl (([1][+][--]ZeroR) [^]n).
 eapply eq_transitive_unfolded.
  2: apply (one_nexp IR n).
 apply nexp_wd; rational.
Qed.

#[global]
Hint Resolve Exp_zero Exp_one: algebra.

(**
The exponential function is its own derivative, and continuous.
*)

Lemma Derivative_Exp : forall H, Derivative realline H Expon Expon.
Proof.
 intro H.
 unfold Expon, Exp_ps in |- *.
 cut (fun_series_convergent_IR realline
   (FPowerSeries' [0] (fun n : nat => (fun _ : nat => [1]) (S n)))).
  intro H0.
  eapply Derivative_wdr.
   2: apply Derivative_FPowerSeries1' with (a := fun _ : nat => OneR) (Hg := H0).
  FEQ.
  simpl in |- *.
  apply series_sum_wd; algebra.
 fold Exp_ps in |- *; apply Exp_conv.
Qed.

#[global]
Hint Resolve Derivative_Exp: derivate.

Lemma Continuous_Exp : Continuous realline Expon.
Proof.
 apply Derivative_imp_Continuous with I Expon.
 apply Derivative_Exp.
Qed.

#[global]
Hint Resolve Continuous_Exp: continuous.

(**
Negative numbers are projected into the interval [[0,1]].
*)

Lemma One_less_Exp : forall x : IR, [0] [<] x -> [1] [<] Exp x.
Proof.
 unfold Exp in |- *; simpl in |- *; intros x H.
 unfold series_sum in |- *.
 apply less_leEq_trans with ([1][+]x).
  astepl (OneR[+][0]); apply plus_resp_less_lft; auto.
 apply str_leEq_seq_so_leEq_Lim.
 exists 2; intros i Hi.
 simpl in |- *.
 unfold seq_part_sum in |- *.
 induction  i as [| i Hreci].
  exfalso; inversion Hi.
 clear Hreci.
 induction  i as [| i Hreci].
  exfalso; inversion Hi; inversion H1.
 clear Hreci.
 induction  i as [| i Hreci].
  simpl in |- *.
  apply eq_imp_leEq; rational.
 eapply leEq_transitive.
  apply Hreci; auto with arith.
 clear Hreci.
 eapply leEq_wdl.
  2: apply cm_rht_unit_unfolded.
 set (j := S (S i)) in *; clearbody j.
 simpl in |- *; apply plus_resp_leEq_lft.
 apply less_leEq; apply mult_resp_pos.
  apply recip_resp_pos; apply pos_nring_fac.
 astepr ((x[+][--][0]) [^]j); apply nexp_resp_pos.
 rstepr x; auto.
Qed.

Lemma One_leEq_Exp : forall x : IR, [0] [<=] x -> [1] [<=] Exp x.
Proof.
 intros x H.
 astepl (Exp [0]).
 apply resp_leEq_char; auto.
  algebra.
 intro H0; astepl OneR.
 apply One_less_Exp; auto.
Qed.

Lemma Exp_pos' : forall x : IR, [0] [<] x -> [0] [<] Exp x.
Proof.
 intros x H.
 apply less_leEq_trans with OneR.
  apply pos_one.
 apply One_leEq_Exp; apply less_leEq; auto.
Qed.

(**
Exponential is the unique function which evaluates to 1 at 0 and is
its own derivative.
*)

Lemma Exp_unique_lemma : forall H F,
 Derivative realline H F F -> forall n, Derivative_n n realline H F F.
Proof.
 intros H F H0 n; induction  n as [| n Hrecn].
  apply Derivative_n_O; Included.
 apply Derivative_n_plus with n 1 F; auto.
 apply Derivative_n_1; auto.
Qed.

Lemma Exp_bnd : Taylor_bnd (fun n => Expon).
Proof.
 apply bnd_imp_Taylor_bnd with Expon.
   intros n x Hx Hx'; apply eq_imp_leEq; algebra.
  Contin.
 Included.
Qed.

Lemma Exp_unique : forall F, Derivative realline I F F -> (forall H1, F [0] H1 [=] [1]) -> Feq realline Expon F.
Proof.
 intros F H H0.
 cut (forall n : nat, Derivative_n n realline I Expon Expon).
  intro derF.
  cut (Taylor_bnd (fun n : nat => Expon)); [ intro bndf | apply Exp_bnd ].
  cut (forall n : nat, Derivative_n n realline I F F).
   intros derG.
   apply Taylor_unique_crit with (f := fun _ : nat => Expon) (a := ZeroR) (g := fun n : nat => F)
     (bndf := bndf) (derF := derF); auto.
     apply bnd_imp_Taylor_bnd with F.
       intros; apply eq_imp_leEq; algebra.
      apply Derivative_n_imp_Continuous with I 1 F; auto with arith.
     intro n.
     change (included realline (Dom F)) in |- *.
     apply Derivative_n_imp_inc with I 1 F; auto with arith.
    intros; astepr OneR.
    astepr (Exp [0]).
    Opaque Expon.
    unfold Exp in |- *; simpl in |- *; algebra.
   Transparent Expon.
   apply Taylor_Series_conv_to_fun; auto.
  apply Exp_unique_lemma; auto.
 apply Exp_unique_lemma; apply Derivative_Exp.
Qed.

Opaque Expon.

Lemma Exp_plus_pos : forall z, [0] [<] z -> forall x, Exp (x[+]z) [=] Exp x[*]Exp z.
Proof.
 intros z H x.
 set (F := ([1][/] _[//]pos_ap_zero _ _ (Exp_pos' _ H)) {**} (Expon[o]FId{+}[-C-]z)) in *.
 apply eq_symmetric_unfolded.
 rstepr ((Exp (x[+]z) [/] _[//]pos_ap_zero _ _ (Exp_pos' _ H)) [*]Exp z).
 apply mult_wdl.
 unfold Exp at 1 in |- *.
 simpl in |- *.
 assert (H0 : Dom F x). repeat split; exists (I, I); apply Exp_domain.
  apply eq_transitive_unfolded with (Part F x H0).
  2: unfold F, Exp in |- *; simpl in |- *; rational.
 apply Feq_imp_eq with realline.
  apply Exp_unique.
   assert (H1 : Derivative realline I Expon Expon). apply Derivative_Exp.
    unfold F in |- *; Derivative_Help.
    apply eq_imp_Feq.
      apply included_FScalMult; apply included_FMult.
       apply included_FComp; Included.
      Included.
     apply included_FScalMult; apply included_FComp; Included.
    intros; simpl in |- *; rational.
   apply Derivative_scal.
   apply Derivative_comp with realline I; Deriv.
   red in |- *; intros a b Hab H2.
   exists (a[+]z); exists (b[+]z[+][1]).
   cut (a[+]z [<] b[+]z[+][1]).
    intro H3.
    exists H3; repeat split; simpl in |- *; try rename H4 into X; elim X; try intros H5 H6.
     apply plus_resp_leEq; auto.
    apply leEq_transitive with (b[+]z).
     apply plus_resp_leEq; auto.
    apply less_leEq; apply less_plusOne.
   apply leEq_less_trans with (b[+]z).
    apply plus_resp_leEq; auto.
   apply less_plusOne.
  intro H1; simpl in |- *.
  rational.
 split.
Qed.

(** The usual rules for computing the exponential of a sum. *)

Lemma Exp_plus : forall x y : IR, Exp (x[+]y) [=] Exp x[*]Exp y.
Proof.
 intros x y.
 set (z := Max [1] ([1][-]y)) in *.
 cut ([0] [<] z).
  intro H.
  apply mult_cancel_rht with (Exp z).
   apply Greater_imp_ap; apply Exp_pos'; auto.
  eapply eq_transitive_unfolded.
   apply eq_symmetric_unfolded; apply Exp_plus_pos; auto.
  astepl (Exp (x[+] (y[+]z))).
  eapply eq_transitive_unfolded.
   apply Exp_plus_pos.
   2: astepr (Exp x[*] (Exp y[*]Exp z)); apply mult_wdr; apply Exp_plus_pos; auto.
  unfold z in |- *.
  apply shift_less_plus'; astepl ( [--]y).
  apply less_leEq_trans with ([1][-]y).
   eapply less_wdr.
    apply less_plusOne.
   rational.
  apply rht_leEq_Max.
 apply less_leEq_trans with OneR.
  apply pos_one.
 unfold z in |- *; apply lft_leEq_Max.
Qed.

#[global]
Hint Resolve Exp_plus: algebra.

Lemma Exp_plus' : forall x y z : IR, z [=] x[+]y -> Exp z [=] Exp x[*]Exp y.
Proof.
 intros x y z H.
 Step_final (Exp (x[+]y)).
Qed.

Lemma Exp_inv_char : forall x : IR, Exp x[*]Exp [--]x [=] [1].
Proof.
 intro x.
 astepr (Exp [0]).
 apply eq_symmetric_unfolded; apply Exp_plus'.
 algebra.
Qed.

#[global]
Hint Resolve Exp_inv_char: algebra.

(** The exponential of any number is always positive---and thus apart
from zero.
*)

Lemma Exp_pos : forall x : IR, [0] [<] Exp x.
Proof.
 intro x.
 cut (Exp x[*]Exp [--]x [=] [1]); [ intro | apply Exp_inv_char ].
 cut ( [--][1] [<=] OneR).
  intro H0.
  cut (Continuous_I H0 Expon).
   intro H1.
   elim H1; intros Hinc contExp.
   elim (contExp _ (pos_half IR)); clear H1 Hinc contExp; intros d H1 H2.
   cut ([0] [<] Min d [1]); [ intro H3 | apply less_Min; auto; apply pos_one ].
   cut ( [--] (Min d [1]) [<] [0]); [ intro H4 | astepr ( [--]ZeroR); apply inv_resp_less; auto ].
   elim (less_cotransitive _ _ _ H4 x); intro H5.
    elim (less_cotransitive _ _ _ H3 x); intro H6.
     apply Exp_pos'; auto.
    apply less_leEq_trans with (Half:IR).
     apply pos_half.
    apply leEq_wdl with ([1][-] (Half:IR)).
     2: unfold Half in |- *; rational.
    apply shift_minus_leEq; apply shift_leEq_plus'.
    astepl (Exp [0][-]Exp x).
    eapply leEq_transitive.
     apply leEq_AbsIR.
    simpl in |- *; apply H2.
      split; apply less_leEq.
       astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one.
      apply pos_one.
     split; apply less_leEq.
      apply leEq_less_trans with ( [--] (Min d [1])).
       apply inv_resp_leEq; apply Min_leEq_rht.
      auto.
     apply less_leEq_trans with (Min d [1]).
      auto.
     apply Min_leEq_rht.
    astepl (AbsIR [--]x).
    eapply leEq_wdl.
     2: apply AbsIR_inv.
    simpl in |- *; unfold ABSIR in |- *; apply less_leEq; apply Max_less.
     apply less_leEq_trans with (Min d [1]); auto; apply Min_leEq_lft.
    apply less_leEq_trans with ( [--][--] (Min d [1])).
     apply inv_resp_less; auto.
    astepl (Min d [1]); apply Min_leEq_lft.
   clear H4 H3 H2 H1 d H0.
   apply mult_cancel_less with (Exp [--]x).
    apply Exp_pos'.
    astepl ( [--]ZeroR); apply inv_resp_less; auto.
   astepl ZeroR; astepr OneR; apply pos_one.
  apply included_imp_Continuous with realline; [ apply Continuous_Exp | repeat split ].
 apply leEq_transitive with ZeroR; [ astepr ( [--]ZeroR) | apply less_leEq; apply pos_one ].
 apply inv_resp_leEq; apply less_leEq; apply pos_one.
Qed.

Lemma Exp_ap_zero : forall x : IR, Exp x [#] [0].
Proof.
 intro; apply Greater_imp_ap; apply Exp_pos.
Qed.

Lemma pos_E : [0] [<] E.
Proof.
 astepr (Exp [1]).
 apply Exp_pos.
Qed.

(**
And the rules for the exponential of differences.
*)

Lemma Exp_inv : forall x : IR, Exp [--]x [=] ([1][/] _[//]Exp_ap_zero x).
Proof.
 intro x.
 apply mult_cancel_lft with (Exp x).
  apply Exp_ap_zero.
 rstepr OneR; algebra.
Qed.

#[global]
Hint Resolve Exp_inv: algebra.

Lemma Exp_minus : forall x y : IR, Exp (x[-]y) [=] (Exp x[/] _[//]Exp_ap_zero y).
Proof.
 intros x y.
 unfold cg_minus in |- *; astepl (Exp x[*]Exp [--]y).
 rstepr (Exp x[*] ([1][/] _[//]Exp_ap_zero y)).
 algebra.
Qed.

#[global]
Hint Resolve Exp_minus: algebra.

Lemma Exp_inv' : forall x y : IR, y [=] [--]x -> Exp y [=] ([1][/] _[//]Exp_ap_zero x).
Proof.
 intros x y Hxy.
 Step_final (Exp [--]x).
Qed.

Lemma Exp_minus' : forall x y z : IR, z [=] x[-]y -> Exp z [=] (Exp x[/] Exp y[//]Exp_ap_zero _).
Proof.
 intros x y z H.
 Step_final (Exp (x[-]y)).
Qed.

(** Exponential is a monotonous function. *)

Lemma Exp_less_One : forall x : IR, x [<] [0] -> Exp x [<] [1].
Proof.
 intros x H.
 astepr (Exp x[*]Exp [--]x).
 astepl (Exp x[*][1]).
 apply mult_resp_less_lft.
  apply One_less_Exp; astepl ( [--]ZeroR); apply inv_resp_less; auto.
 apply Exp_pos.
Qed.

Lemma Exp_leEq_One : forall x : IR, x [<=] [0] -> Exp x [<=] [1].
Proof.
 intros x H.
 astepr (Exp x[*]Exp [--]x).
 astepl (Exp x[*][1]).
 apply mult_resp_leEq_lft.
  apply One_leEq_Exp; astepl ( [--]ZeroR); apply inv_resp_leEq; auto.
 apply less_leEq; apply Exp_pos.
Qed.

Lemma Exp_resp_less : forall x y : IR, x [<] y -> Exp x [<] Exp y.
Proof.
 intros x y H.
 apply less_wdr with (Exp (x[+] (y[-]x))).
  2: apply Exp_wd; rational.
 astepr (Exp x[*]Exp (y[-]x)).
 astepl (Exp x[*][1]).
 apply mult_resp_less_lft.
  apply One_less_Exp.
  apply shift_less_minus; astepl x; auto.
 apply Exp_pos.
Qed.

Lemma Exp_resp_leEq : forall x y : IR, x [<=] y -> Exp x [<=] Exp y.
Proof.
 intros x y; apply resp_leEq_char.
  algebra.
 intro H; apply Exp_resp_less; auto.
Qed.

(**
** Properties of Logarithm

The logarithm is a continuous function with derivative [[1][/]x].
*)

Lemma Derivative_Log : forall H, Derivative (openl [0]) H Logarithm {1/}FId.
Proof.
 intro H.
 unfold Logarithm in |- *.
 Deriv.
Qed.

#[global]
Hint Resolve Derivative_Log: derivate.

Lemma Continuous_Log : Continuous (openl [0]) Logarithm.
Proof.
 apply Derivative_imp_Continuous with I ( {1/} (Fid IR)).
 Deriv.
Qed.

#[global]
Hint Resolve Continuous_Log: continuous.

(** Logarithm of [[1]]. *)

Lemma Log_one : forall H, Log [1] H [=] [0].
Proof.
 intro H; unfold Log in |- *; simpl in |- *.
 apply Integral_empty; algebra.
Qed.

#[global]
Hint Resolve Log_one: algebra.

(** The logarithm is (strongly) extensional. *)

Lemma Log_strext : forall (x y : IR) Hx Hy, Log x Hx [#] Log y Hy -> x [#] y.
Proof.
 intros x y Hx Hy H.
 unfold Log in H.
 exact (pfstrx _ _ _ _ _ _ H).
Qed.

Lemma Log_wd : forall (x y : IR) Hx Hy, x [=] y -> Log x Hx [=] Log y Hy.
Proof.
 intros x y Hx Hy H.
 unfold Log in |- *; algebra.
Qed.

#[global]
Hint Resolve Log_wd: algebra.

(** The rule for the logarithm of the product. *)

Lemma Log_mult : forall x y Hx Hy Hxy, Log (x[*]y) Hxy [=] Log x Hx[+]Log y Hy.
Proof.
 intros x y Hx Hy Hxy.
 set (G := (Logarithm[o]y{**}FId) {-}[-C-] (Log y Hy)) in *.
 cut (proper (openl [0])); [ intro H | simpl in |- *; auto ].
 cut (Derivative (openl [0]) H G {1/}FId).
  intro H0.
  cut (Derivative (openl [0]) H Logarithm {1/}FId); [ intro H1 | Deriv ].
  elim (FTC2 (openl [0]) {1/}FId log_defn_lemma [1] (pos_one IR) H G H0); intros c Hc.
  fold Logarithm in Hc.
  elim Hc; intros H2' H2''.
  elim H2''; intros H2 H5.
  clear Hc H2 H2' H2''.
  cut (c [=] [0]).
   intro H2.
   cut (forall z w t : IR, w[-] (z[-]t) [=] [0] -> z [=] w[+]t).
    intro H3.
    apply H3; clear H3.
    astepr c; clear H2.
    cut (Dom (Logarithm{-}G) x); [ intro H2 | repeat split; simpl in |- *; auto ].
     eapply eq_transitive_unfolded.
      2: apply (H5 x Hx H2 I).
     Opaque Logarithm.
     simpl in |- *; algebra.
    clear H5.
    exists (I, I); apply mult_resp_pos; auto.
   intros z w t H3.
   rstepl (z[-]t[+]t).
   apply bin_op_wd_unfolded.
    2: algebra.
   apply cg_inv_unique_2.
   astepr ( [--]ZeroR).
   rstepl ( [--] (w[-] (z[-]t))).
   apply un_op_wd_unfolded; auto.
  cut (Dom (Logarithm{-}G) [1]); [ intro H2 | repeat split; simpl in |- *; auto ].
    apply eq_symmetric_unfolded; eapply eq_transitive_unfolded.
     2: apply (H5 [1] (pos_one IR) H2 I).
    simpl in |- *.
    rstepl ([0][-] (Log y Hy[-]Log y Hy)).
    algebra.
   Transparent Logarithm.
   simpl in |- *; apply pos_one.
  exists (I, I); simpl in |- *; apply mult_resp_pos; auto; apply pos_one.
 unfold G in |- *.
 cut (Derivative (openl [0]) H Logarithm {1/}FId);
   [ intro H0 | unfold Logarithm in |- *; apply FTC1 ].
 Derivative_Help.
  apply eq_imp_Feq.
    repeat split.
    exists (I, I); simpl in |- *.
    repeat split.
    intros; apply Greater_imp_ap; apply mult_resp_pos; auto.
   Included.
  intros; simpl in |- *; rational.
 apply Derivative_minus.
  apply Derivative_comp with (openl [0]) H; Deriv.
  clear H0; red in |- *; intros a b Hab H0.
  simpl in |- *; exists (y[*]a); exists (y[*]b[+][1]).
  cut (y[*]a [<] y[*]b[+][1]).
   intro H1; exists H1; split.
    intros x0 H2.
    elim H2; intros H3 H4; simpl in |- *.
    apply less_leEq_trans with (y[*]a).
     apply mult_resp_pos; auto.
     apply H0; apply compact_inc_lft.
    auto.
   intros x0 Hx0 H2; elim H2; intros H3 H4; split.
    apply mult_resp_leEq_lft; auto.
    apply less_leEq; auto.
   apply leEq_transitive with (y[*]b).
    apply mult_resp_leEq_lft; auto.
    apply less_leEq; auto.
   apply less_leEq; apply less_plusOne.
  apply leEq_less_trans with (y[*]b).
   apply mult_resp_leEq_lft; auto.
   apply less_leEq; auto.
  apply less_plusOne.
 Deriv.
Qed.

#[global]
Hint Resolve Log_mult: algebra.

Lemma Log_mult' : forall x y z Hx Hy Hz, z [=] x[*]y -> Log z Hz [=] Log x Hx[+]Log y Hy.
Proof.
 intros.
 Step_final (Log (x[*]y) (mult_resp_pos _ _ _ Hx Hy)).
Qed.

Lemma Log_nexp : forall x n Hx Hxn, Log (x[^]n) Hxn [=] (nring n)[*]Log x Hx.
Proof.
 induction n.
  intros Hx Hn.
  simpl.
  rstepr ([0]:IR).
  apply Log_one.
 intros Hx Hn.
 assert (X:[0][<]x[^]n).
  apply nexp_resp_pos.
  assumption.
 stepl (Log _ X[+]Log x Hx); [| apply eq_symmetric; apply (Log_mult _ _ X Hx)].
 astepr ((nring n [+] [1])[*]Log x Hx).
 rstepr (nring n[*]Log x Hx[+]Log x Hx).
 apply bin_op_wd_unfolded; try apply eq_reflexive.
 apply IHn.
Qed.

#[global]
Hint Resolve Log_nexp: algebra.

(** A characterization of the domain of the logarithm. *)

Lemma Log_domain : forall x : IR, [0] [<] x -> Dom Logarithm x.
Proof.
 intros; auto.
Qed.

Opaque Expon Logarithm.

(** $\log(e^x)=x$#log(ex)=x# for all [x], both as a
numerical and as a functional equation.
*)

Lemma Log_Exp_inv : Feq realline (Logarithm[o]Expon) FId.
Proof.
 apply Feq_criterium with I (Fconst (S:=IR) [1]) ZeroR.
    cut (Derivative realline I Expon Expon); [ intro H | apply Derivative_Exp ].
    cut (Derivative (openl [0]) I Logarithm {1/}FId); [ intro H0 | apply Derivative_Log ].
    Derivative_Help.
     apply eq_imp_Feq.
       split; auto.
       exists I.
       split; auto.
       intro; simpl in |- *; apply Greater_imp_ap.
       apply less_wdr with (Exp x); [ apply Exp_pos | simpl in |- *; algebra ].
      Included.
     intros; simpl in |- *; rational.
    apply Derivative_comp with (openl [0]) I; Deriv.
    red in |- *; intros a b Hab H1.
    exists (Exp a); exists (Exp b[+][1]); exists
      (leEq_less_trans _ _ _ _ (Exp_resp_leEq _ _ Hab) (less_plusOne _ _)).
    split.
     red in |- *; intros x H2.
     elim H2; intros H3 H4.
     simpl in |- *.
     apply less_leEq_trans with (Exp a); auto.
     apply Exp_pos.
    intros x Hx H2; elim H2; intros H3 H4; split.
     apply leEq_wdr with (Exp x).
      apply Exp_resp_leEq; auto.
     simpl in |- *; algebra.
    apply less_leEq; apply leEq_less_trans with (Exp b).
     apply leEq_wdl with (Exp x).
      apply Exp_resp_leEq; auto.
     simpl in |- *; algebra.
    apply less_plusOne.
   Deriv.
  split.
 intros; simpl in |- *.
 astepr (Log [1] (pos_one _)).
 unfold Log in |- *; apply pfwdef.
 astepr (Exp [0]).
 simpl in |- *; algebra.
Qed.

Lemma Log_Exp : forall x H, Log (Exp x) H [=] x.
Proof.
 intros x H.
 cut (Dom (Logarithm[o]Expon) x).
  intro H0.
  unfold Log in |- *; simpl in |- *; apply eq_transitive_unfolded with (Part _ _ H0).
   simpl in |- *; algebra.
  astepr (Part FId x I).
  apply Feq_imp_eq with realline.
   apply Log_Exp_inv.
  split.
 exists I.
 apply Log_domain.
 apply less_wdr with (Exp x); auto.
 simpl in |- *; algebra.
Qed.

Transparent Logarithm.

#[global]
Hint Resolve Log_Exp: algebra.

Lemma Exp_Log_lemma : forall x y Hx Hy, [0] [=] Log y Hy[-]Log x Hx -> y [<=] x.
Proof.
 intros x y Hx Hy H; rewrite -> leEq_def; intro H0.
 cut ((y[-]x[/] _[//]pos_ap_zero _ _ Hy) [<=] [0]).
  intro H1.
  apply less_irreflexive_unfolded with (x := x).
  apply less_leEq_trans with y; auto.
  astepr (x[+][0]); apply shift_leEq_plus'.
  rstepl ((y[-]x[/] _[//]pos_ap_zero _ _ Hy) [*]y).
  apply shift_mult_leEq with (pos_ap_zero _ _ Hy); auto.
  rstepr ZeroR; auto.
 astepr (Log y Hy[-]Log x Hx).
 unfold Log in |- *; simpl in |- *.
 apply leEq_wdr with (Integral (prim_lemma _ _ log_defn_lemma x Hx y Hy)).
  2: rstepl (Integral (prim_lemma _ _ log_defn_lemma [1] (pos_one _) x Hx) [+]
    Integral (prim_lemma _ _ log_defn_lemma x Hx y Hy) [-]
      Integral (prim_lemma _ _ log_defn_lemma [1] (pos_one _) x Hx)).
  2: apply cg_minus_wd; algebra.
  2: apply eq_symmetric_unfolded; apply Integral_plus_Integral with (Min3_leEq_Max3 [1] y x).
  2: apply included_imp_Continuous with (openl [0]);
    [ apply log_defn_lemma | intros x0 H1; inversion_clear H1 ].
  2: simpl in |- *; apply less_leEq_trans with (Min (Min [1] y) x); auto;
    repeat apply less_Min; auto; apply pos_one.
 cut (Continuous_I (less_leEq _ _ _ H0) {1/}FId).
  intro H1.
  apply leEq_wdr with (integral _ _ _ _ H1).
   2: apply eq_symmetric_unfolded; apply Integral_integral.
  rstepl (([1][/] _[//]pos_ap_zero _ _ Hy) [*] (y[-]x)).
  apply lb_integral.
  intros x0 H2 Hx0; simpl in |- *.
  elim H2; intros H3 H4; apply recip_resp_leEq; auto.
  apply less_leEq_trans with x; auto.
 apply included_imp_Continuous with (openl [0]); [ apply log_defn_lemma | red in |- *; intros x0 X ].
 inversion_clear X; simpl in |- *; apply less_leEq_trans with x; auto.
Qed.

(** The converse expression. *)

Lemma Exp_Log : forall x H, Exp (Log x H) [=] x.
Proof.
 intros x H.
 set (y := Exp (Log x H)) in *.
 cut ([0] [<] y); [ intro H0 | unfold y in |- *; apply Exp_pos ].
 cut (Log y H0 [=] Log x H); [ intro H1 | unfold y in |- *; algebra ].
 cut ([0] [=] Log y H0[-]Log x H);
   [ clear H1; intro H1 | apply eq_symmetric_unfolded; apply x_minus_x; auto ].
 apply leEq_imp_eq.
  apply Exp_Log_lemma with H H0; auto.
 apply Exp_Log_lemma with H0 H.
 astepl ( [--]ZeroR); rstepr ( [--] (Log y H0[-]Log x H)); algebra.
Qed.

#[global]
Hint Resolve Exp_Log: algebra.

(** Exponential and logarithm are injective. *)

Lemma Exp_cancel : forall x y : IR, Exp x [=] Exp y -> x [=] y.
Proof.
 intros.
 astepl (Log (Exp x) (Exp_pos x)); Step_final (Log (Exp y) (Exp_pos y)).
Qed.

Lemma Log_cancel : forall (x y : IR) Hx Hy, Log x Hx [=] Log y Hy -> x [=] y.
Proof.
 intros.
 astepl (Exp (Log x Hx)); Step_final (Exp (Log y Hy)).
Qed.

Opaque Logarithm.

(** And the final characterization as inverse functions. *)

Lemma Exp_Log_inv : Feq (openl [0]) (Expon[o]Logarithm) FId.
Proof.
 apply eq_imp_Feq.
   red in |- *; intros x H.
   simpl in H; exists H; apply Exp_domain.
  Included.
 intros x H Hx Hx'; simpl in |- *.
 astepr (Exp (Log x H)).
 unfold Log in |- *; simpl in |- *; algebra.
Qed.

Lemma Log_E : forall He, Log E He [=] [1].
Proof.
 intro.
 Step_final (Log (Exp [1]) (Exp_pos [1])).
Qed.

#[global]
Hint Resolve Log_E: algebra.

(** Several rules regarding inequalities. *)

Lemma Log_cancel_less : forall x y Hx Hy, Log x Hx [<] Log y Hy -> x [<] y.
Proof.
 intros x y Hx Hy H.
 astepl (Exp (Log x Hx)).
 astepr (Exp (Log y Hy)).
 apply Exp_resp_less; auto.
Qed.

Lemma Log_cancel_leEq : forall x y Hx Hy, Log x Hx [<=] Log y Hy -> x [<=] y.
Proof.
 intros x y Hx Hy H.
 astepl (Exp (Log x Hx)).
 astepr (Exp (Log y Hy)).
 apply Exp_resp_leEq; auto.
Qed.

Lemma Log_resp_less : forall (x y : IR) Hx Hy, x [<] y -> Log x Hx [<] Log y Hy.
Proof.
 intros x y Hx Hy H.
 unfold Log in |- *; apply Derivative_imp_resp_less with (openl [0]) I ( {1/} (Fid IR));
   simpl in |- *; auto.
  apply Derivative_Log.
 intro contF.
 apply less_wdr with ([1][/] _[//]pos_ap_zero _ _ Hy).
  apply recip_resp_pos; auto.
 apply glb_charact.
 split.
  intros z Hz.
  elim Hz; intros t H1.
  elim H1; intros H2 H3.
  elim H3; clear Hz H1 H3; intros H1 H3.
  assert (H0 := H3 H1); simpl in H0.
  astepr ([1][/] t[//]ext2 (P:=fun _ : IR => True) H1).
  elim H2; intros HMin HMax.
  apply recip_resp_leEq; auto.
   apply less_leEq_trans with (Min x y); auto.
   apply less_Min; auto.
  apply leEq_wdr with (Max x y); auto.
  apply leEq_imp_Max_is_rht; apply less_leEq; auto.
 intros e He.
 exists ([1][/] _[//]pos_ap_zero _ _ Hy).
  exists y.
  split.
   split; [ apply Min_leEq_rht | apply rht_leEq_Max ].
  repeat split.
   intro; simpl in |- *; apply pos_ap_zero; auto.
  simpl in |- *; algebra.
 astepl ZeroR; auto.
Qed.

Lemma Log_resp_leEq : forall (x y : IR) Hx Hy, x [<=] y -> Log x Hx [<=] Log y Hy.
Proof.
 intros x y Hx Hy; apply resp_leEq_char' with (P := fun x : IR => [0] [<] x).
  algebra.
 apply Log_resp_less.
Qed.

Lemma Exp_cancel_less : forall x y, Exp x [<] Exp y -> x [<] y.
Proof.
 intros x y H.
 astepl (Log (Exp x) (Exp_pos x)).
 astepr (Log (Exp y) (Exp_pos y)).
 apply Log_resp_less; auto.
Qed.

Lemma Exp_cancel_leEq : forall x y : IR, Exp x [<=] Exp y -> x [<=] y.
Proof.
 intros x y H.
 astepl (Log (Exp x) (Exp_pos x)).
 astepr (Log (Exp y) (Exp_pos y)).
 apply Log_resp_leEq; auto.
Qed.

Lemma Log_less_Zero : forall (x : IR) Hx, x [<] [1] -> Log x Hx [<] [0].
Proof.
 intros x Hx H.
 astepr (Log (Exp [0]) (Exp_pos [0])).
 apply Log_resp_less.
 astepr OneR; auto.
Qed.

Lemma Log_leEq_Zero : forall (x : IR) Hx, x [<=] [1] -> Log x Hx [<=] [0].
Proof.
 intros x Hx H.
 astepr (Log (Exp [0]) (Exp_pos [0])).
 apply Log_resp_leEq.
 astepr OneR; auto.
Qed.

Lemma Zero_less_Log : forall (x : IR) Hx, [1] [<] x -> [0] [<] Log x Hx.
Proof.
 intros x Hx H.
 astepl (Log (Exp [0]) (Exp_pos [0])).
 apply Log_resp_less.
 astepl OneR; auto.
Qed.

Lemma Zero_leEq_Log : forall (x : IR) Hx, [1] [<=] x -> [0] [<=] Log x Hx.
Proof.
 intros x Hx H.
 astepl (Log (Exp [0]) (Exp_pos [0])).
 apply Log_resp_leEq.
 astepl OneR; auto.
Qed.

(** Finally, rules for logarithm of quotients. *)

Lemma Log_recip_char : forall x Hx Hx' Hx'', Log ([1][/] x[//]Hx) Hx'[+]Log x Hx'' [=] [0].
Proof.
 intros x Hx Hx' Hx''.
 astepl (Log _ (mult_resp_pos _ _ _ Hx' Hx'')).
 astepr (Log _ (pos_one IR)).
 apply Log_wd; rational.
Qed.

Lemma Log_recip : forall x Hx Hx' Hx'', Log ([1][/] x[//]Hx) Hx' [=] [--] (Log x Hx'').
Proof.
 intros x Hx Hx' Hx''.
 apply cg_inv_unique'; apply Log_recip_char.
Qed.

#[global]
Hint Resolve Log_recip: algebra.

Lemma Log_recip' : forall x y Hx Hx' Hy, y [=] ([1][/] x[//]Hx) -> Log y Hy [=] [--] (Log x Hx').
Proof.
 intros x y Hx Hx' Hy H.
 Step_final (Log ([1][/] _[//]Hx) (recip_resp_pos _ _ Hx Hx')).
Qed.

Lemma Log_div : forall x y Hx Hy Hy' Hxy, Log (x[/] y[//]Hy') Hxy [=] Log x Hx[-]Log y Hy.
Proof.
 intros x y Hx Hy Hy' Hxy.
 unfold cg_minus in |- *.
 apply eq_transitive_unfolded with (Log _ (mult_resp_pos _ _ _ Hx (recip_resp_pos _ _ Hy' Hy))).
  apply Log_wd; rational.
 Step_final (Log _ Hx[+]Log _ (recip_resp_pos _ _ Hy' Hy)).
Qed.

#[global]
Hint Resolve Log_div: algebra.

Lemma Log_div' : forall x y z Hx Hy Hy' Hz,
 z [=] (x[/] y[//]Hy') -> Log z Hz [=] Log x Hx[-]Log y Hy.
Proof.
 intros x y z Hx Hy Hy' Hz H.
 Step_final (Log _ (div_resp_pos _ _ _ Hy' Hy Hx)).
Qed.

Lemma Log_zexp : forall x n Hx Hx0 Hxn, Log ((x[//]Hx0)[^^]n) Hxn [=] (zring n)[*]Log x Hx.
Proof.
 intros x [|n|n] Hx Hx0 Hxn.
   simpl.
   rstepr ([0]:IR).
   algebra.
  assert (X:[0][<]x[^](nat_of_P n)).
   astepr ((x[//]Hx0)[^^]n).
   assumption.
  change (Log (x[^](nat_of_P n)) Hxn[=]zring (R:=IR) n[*]Log x Hx).
  astepl (nring (nat_of_P n)[*]Log x Hx).
  apply mult_wdl.
  apply eq_symmetric.
  rewrite <- inject_nat_convert.
  refine (zring_plus_nat IR (nat_of_P n)).
 simpl.
 change (Log (([1][/]x[//]Hx0)[^](nat_of_P n)) Hxn[=][--](zring n)[*]Log x Hx).
 assert (X:[0][<]([1][/]x[//]Hx0)).
  apply recip_resp_pos.
  assumption.
 astepl ((nring (nat_of_P n))[*](Log _ X)).
 astepl ((nring (nat_of_P n))[*]([--](Log _ Hx))).
 rstepl ([--](nring (nat_of_P n))[*](Log x Hx)).
 apply mult_wdl.
 apply un_op_wd_unfolded.
 rewrite <- inject_nat_convert.
 apply eq_symmetric.
 refine (zring_plus_nat IR (nat_of_P n)).
Qed.

#[global]
Hint Resolve Log_zexp: algebra.

Section Log_Series.

Definition Log_series_coef (n:nat) :=
match n with
| O => [0]
| (S n') => ([--][1])[^](S (S n'))[/](nring (S n'))[//]nringS_ap_zero IR n'
end.

Definition Log_ps := FPowerSeries [1] Log_series_coef.

Lemma Log_series_convergent_IR : fun_series_convergent_IR (olor [0] Two) Log_ps.
Proof.
 intros a b Hab Hinc.
 apply fun_ratio_test_conv.
  unfold Log_ps; unfold FPowerSeries; Contin.
 exists 1.
 pose (c:=Max (AbsIR (a[-][1])) (AbsIR (b[-][1]))).
 assert (Z0:c[<][1]).
  unfold c.
  destruct (Hinc _ (compact_inc_lft _ _ Hab)).
  destruct (Hinc _ (compact_inc_rht _ _ Hab)).
  apply Max_less; apply AbsIR_less; first [apply shift_minus_less; rstepr (Two:IR)
    |apply shift_less_minus; rstepl ([0]:IR)]; assumption.
 assert (Z1:[0][<=]c).
  unfold c.
  eapply leEq_transitive.
   apply AbsIR_nonneg.
  apply lft_leEq_Max.
 exists c.
  assumption.
 split.
  assumption.
 intros x [Hx0 Hx1] n Hn Hx Hx'.
 destruct n.
  exfalso; auto with *.
 unfold Log_ps, FPowerSeries, Log_series_coef.
 generalize (nringS_ap_zero IR (S n)).
 generalize (nringS_ap_zero IR (n)).
 intros Y0 Y1.
 stepl ( (nexp IR (S (S n)) (AbsIR (x[-][1])))[/]nring (R:=IR) (S (S n))[//]Y1).
  apply shift_div_leEq.
   apply nring_pos; auto with *.
  stepr ((((nexp IR (S n) (AbsIR (x[-][1]))[*]c)[*](nring (R:=IR) (S (S n))))[/]nring (R:=IR) (S n)[//]Y0)).
   apply shift_leEq_div.
    apply nring_pos; auto with *.
   apply mult_resp_leEq_both.
      apply (nexp_resp_nonneg _ (AbsIR (x[-][1])) (S (S n))).
      apply AbsIR_nonneg.
     apply nring_nonneg; auto with *.
    change (nexp IR (S (S n)) (AbsIR (x[-][1])))
      with ((nexp IR (S n) (AbsIR (x[-][1])))[*](AbsIR (x[-][1]))).
    apply mult_resp_leEq_lft.
     apply AbsSmall_imp_AbsIR.
     split.
      apply shift_zero_leEq_minus'.
      rstepr (c[-]([--](x[-][1]))).
      apply shift_zero_leEq_minus.
      unfold c.
      eapply leEq_transitive;[|apply lft_leEq_Max].
      eapply leEq_transitive;[|apply inv_leEq_AbsIR].
      apply inv_resp_leEq.
      apply minus_resp_leEq.
      assumption.
     unfold c.
     eapply leEq_transitive;[|apply rht_leEq_Max].
     eapply leEq_transitive;[|apply leEq_AbsIR].
     apply minus_resp_leEq.
     assumption.
    apply (nexp_resp_nonneg _ (AbsIR (x[-][1])) (S n)).
    apply AbsIR_nonneg.
   apply nring_leEq; auto with *.
  rstepl (c[*](nexp IR (S n) (AbsIR (x[-][1]))[/]
    nring (R:=IR) (S n)[//]Y0)[*]nring (R:=IR) (S (S n))).
  apply mult_wdl.
  apply mult_wdr.
  stepl (AbsIR ((x[-][1])[^](S n))[/]_[//](AbsIR_resp_ap_zero _ Y0)).
   eapply eq_transitive.
    apply eq_symmetric.
    apply (AbsIR_division ((x[-][1])[^]S n) _ Y0).
   stepr (AbsIR (([--][1])[^](S (S n)))[*]AbsIR ((x[-][1])[^]S n[/]nring (R:=IR) (S n)[//]Y0)).
    rstepl ([1][*]AbsIR ((x[-][1])[^]S n[/]nring (R:=IR) (S n)[//]Y0)).
    apply mult_wdl.
    csetoid_rewrite (AbsIR_nexp_op (S (S n)) ([--][1])).
    csetoid_replace (AbsIR ([--][1])) ([1]:IR).
     apply eq_symmetric.
     apply (one_nexp IR (S (S n))).
    rstepr ([--][--][1]:IR).
    apply AbsIR_eq_inv_x.
    apply shift_zero_leEq_minus'.
    rstepr ([1]:IR).
    apply less_leEq; apply pos_one.
   eapply eq_transitive.
    apply eq_symmetric; apply AbsIR_resp_mult.
   apply AbsIR_wd.
   change ((([--][1][^]S (S n)[/]nring (R:=IR) (S n)[//]Y0){**}(FId{-}[-C-][1]){^}S n) x Hx)
     with ((([--][1][^]S (S n)[/]nring (R:=IR) (S n)[//]Y0)[*](x[-][1])[^]S n)).
   rational.
  apply div_wd.
   apply (AbsIR_nexp (x[-][1]) (S n)).
  apply AbsIR_eq_x.
  apply nring_nonneg.
 stepl (AbsIR ((x[-][1])[^](S (S n)))[/]_[//](AbsIR_resp_ap_zero _ Y1)).
  eapply eq_transitive.
   apply eq_symmetric.
   apply (AbsIR_division ((x[-][1])[^]S (S n)) _ Y1).
  stepr (AbsIR (([--][1][^]S (S (S n))[*]((x[-][1])[^]S (S n)[/]_[//]Y1)))).
   eapply eq_transitive;[|apply eq_symmetric; apply AbsIR_resp_mult].
   rstepl ([1][*]AbsIR ((x[-][1])[^]S (S n)[/]nring (R:=IR) (S (S n))[//]Y1)).
   apply mult_wdl.
   csetoid_rewrite (AbsIR_nexp_op (S (S (S n))) [--][1]).
   csetoid_replace (AbsIR ([--][1])) ([1]:IR).
    apply eq_symmetric.
    apply (one_nexp IR).
   rstepr ([--][--][1]:IR).
   apply AbsIR_eq_inv_x.
   apply shift_zero_leEq_minus'.
   rstepr ([1]:IR).
   apply less_leEq; apply pos_one.
  apply AbsIR_wd.
  change ((([--][1][^]S (S (S n))[/]nring (R:=IR) (S (S n))[//]Y1){**}(FId{-}[-C-][1]){^}S (S n)) x Hx')
    with ((([--][1][^]S (S (S n))[/]nring (R:=IR) (S (S n))[//]Y1)[*](x[-][1])[^]S (S n))).
  rational.
 apply div_wd.
  apply (AbsIR_nexp (x[-][1]) (S (S n))).
 apply AbsIR_eq_x.
 apply nring_nonneg.
Qed.

Lemma Log_series : forall c : IR,
 forall (Hs:fun_series_convergent_IR (olor [0] Two) Log_ps) Hc0 Hc1,
 FSeries_Sum Hs c Hc0[=]Log c Hc1.
Proof.
 intros c Hs Hc0 Hc1.
 Transparent Logarithm.
 assert (Z:fun_series_convergent_IR (olor [0] Two) (fun n : nat => Log_ps (S n))).
  generalize Log_ps Hs.
  intros p Hp; clear - Hp.
  intros a b Hab Hinc.
  destruct (Hp a b Hab Hinc) as [A B].
  exists (fun n => (A (S n))).
  intros e He.
  destruct (B e He) as [C D].
  exists (C).
  intros m n Hm Hn x Hx.
  assert (D' := (D (S m) (S n))).
  stepl (AbsIR (fun_seq_part_sum p (S m) x (contin_imp_inc a b Hab (fun_seq_part_sum p (S m))
    (fun_seq_part_sum_cont a b Hab p A (S m)) x Hx)[-] fun_seq_part_sum p (S n) x
      (contin_imp_inc a b Hab (fun_seq_part_sum p (S n))
        (fun_seq_part_sum_cont a b Hab p A (S n)) x Hx))).
   apply D'; auto with *.
  apply AbsIR_wd.
  set (g:=(fun (y n0 : nat) => Part (p n0) x (contin_imp_inc a b Hab (fun_seq_part_sum p y)
    (fun_seq_part_sum_cont a b Hab p A y) x Hx n0))).
  set (g':=(fun y n0 : nat => Part (p (S n0)) x
    (contin_imp_inc a b Hab (fun_seq_part_sum (fun n1 : nat => p (S n1)) y)
      (fun_seq_part_sum_cont a b Hab (fun n1 : nat => p (S n1))
        (fun n1 : nat => A (S n1)) y) x Hx n0))).
  change (Sum0 (G:=IR) (S m) (g (S m))[-](Sum0 (G:=IR) (S n) (g (S n)))[=]
    Sum0 (G:=IR) m (g' m)[-]Sum0 (G:=IR) n (g' n)).
  stepr ((g (S m) 0[+]Sum0 (G:=IR) m (g' m))[-](g (S n) 0[+]Sum0 (G:=IR) n (g' n))).
   unfold cg_minus.
   apply eq_symmetric; apply bin_op_wd_unfolded; try apply un_op_wd_unfolded; apply Sum0_shift;
     intros i; unfold g', g; apply pfwdef; apply eq_reflexive.
  apply cg_cancel_lft with (g (S n) 0[-](Sum0 (G:=IR) m (g' m)[-]Sum0 (G:=IR) n (g' n))).
  rstepr (g (S n) 0).
  rstepl (g (S m) 0).
  unfold g; apply pfwdef; apply eq_reflexive.
 assert (Z0:=insert_series_sum _ _ Z).
 set (Hs':=(insert_series_conv (olor [0] Two) (fun n : nat => Log_ps (S n)) Z)) in *.
 apply eq_transitive with (FSeries_Sum (J:=olor [0] Two)
   (f:=insert_series (fun n : nat => Log_ps (S n))) Hs' c Hc0).
  simpl.
  apply series_sum_wd.
  intros [|n].
   simpl; rational.
  simpl; rational.
 apply eq_transitive with (FSeries_Sum Z c Hc0).
  apply Feq_imp_eq with (olor [0] Two).
   apply Feq_symmetric.
   apply (insert_series_sum _ _ Z).
  assumption.
 simpl.
 unfold series_sum.
 apply eq_symmetric.
 apply Limits_unique.
 simpl.
 unfold Log, Logarithm.
 simpl.
 assert (X:forall n, Continuous_I (Min_leEq_Max [1] c) (([-C-][1]{-}FId){^}n)).
  Contin.
 apply Cauchy_Lim_prop2_wd with (fun n => Integral (fun_seq_part_sum_cont _ _ _ _ X n)).
  assert (A0:Continuous (olor [0] Two) ({1/}FId)).
   apply Continuous_recip.
    Contin.
   intros a b Hab Hinc.
   split.
    Included.
   exists a.
    destruct (Hinc _ (compact_inc_lft _ _ Hab)); assumption.
   simpl.
   intros y _ Hy.
   stepr y.
    destruct Hy; assumption.
   apply eq_symmetric.
   apply AbsIR_eq_x.
   apply less_leEq; destruct (Hinc _ Hy); assumption.
  assert (A1:forall n : nat, Continuous (olor [0] Two) (fun_seq_part_sum (Fnth (R:=IR) ([-C-][1]{-}FId)) n)).
   intros n.
   split.
    repeat constructor.
   intros a b Hab Hinc.
   Contin.
  eapply (limit_of_Integral (olor [0] Two) _ _ A1 A0).
   unfold fun_seq_part_sum.
   assert (A2:fun_series_convergent_IR (olor [0] Two) (Fnth (R:=IR) ([-C-][1]{-}FId))).
    cut (fun_series_convergent_IR (olor [0] Two) (fun n => FId{^}n[o]([-C-][1]{-}FId))).
     apply fun_series_convergent_wd_IR.
     intros n.
     FEQ.
     intros x Hx.
     assert (W:Dom ([-C-][1]{-}FId) x).
      repeat constructor.
     exists W.
     repeat constructor.
    apply FSeries_Sum_comp_conv with (olor [--][1] [1]).
      intros a b Hab Hinc.
      exists ([1][-]b).
      exists ([1][-]a).
      assert (W:[1][-]b[<=][1][-]a).
       unfold cg_minus.
       apply plus_resp_leEq_lft.
       apply inv_resp_leEq.
       assumption.
      exists W.
      split.
       intros x [Hx0 Hx1].
       split.
        eapply less_leEq_trans;[|apply Hx0].
        apply shift_less_minus.
        apply shift_plus_less'.
        rstepr (Two:IR).
        destruct (Hinc _ (compact_inc_rht _ _ Hab)); assumption.
       eapply leEq_less_trans;[apply Hx1|].
       apply shift_minus_less.
       apply shift_less_plus'.
       rstepl ([0]:IR).
       destruct (Hinc _ (compact_inc_lft _ _ Hab)); assumption.
      intros x Hx [Hx0 Hx1].
      split; simpl.
       apply shift_leEq_minus'.
       apply shift_plus_leEq.
       rstepr b.
       assumption.
      apply shift_leEq_minus'.
      apply shift_plus_leEq.
      rstepr x.
      assumption.
     Contin.
    apply fun_power_series_conv_IR.
   assert (A3:Continuous (olor [0] Two)
     (FSeries_Sum (J:=olor [0] Two) (f:=Fnth (R:=IR) ([-C-][1]{-}FId)) A2)).
    Contin.
   eapply (conv_fun_seq'_wdr_IR);[|apply (FSeries_conv _ _ A2 A1 A3)].
   FEQ.
   assert (Y:AbsIR ([1][-]x)[<][1]).
    destruct X0.
    apply AbsIR_less.
     apply shift_minus_less.
     apply shift_less_plus'.
     rstepl ([0]:IR); assumption.
    apply shift_less_minus'.
    apply shift_plus_less.
    rstepr (Two:IR); assumption.
   assert (Y0:[1][-]([1][-]x)[#][0]).
    rstepl (x).
    apply Greater_imp_ap.
    destruct X0; assumption.
   apply eq_transitive with ([1][/]_[//]Y0).
    eapply eq_transitive;[|apply (power_series_sum _ Y Y0 (power_series_conv _ Y))].
    simpl.
    apply series_sum_wd.
    intros n; apply eq_reflexive.
   simpl.
   rational.
  intros x [Hx0 Hx1].
  split.
   apply less_leEq_trans with (Min [1] c); try assumption.
   apply less_Min; try assumption.
   apply pos_one.
  apply leEq_less_trans with (Max [1] c); try assumption.
  destruct Hc0.
  apply Max_less; try assumption.
  apply one_less_two.
 intros n.
 induction n.
  simpl.
  rstepr ([0][*](c[-][1])).
  eapply eq_transitive;[|apply (Integral_const _ _ (Min_leEq_Max [1] c) [0] (Continuous_I_const _ _ _ _))].
  apply Integral_wd.
  FEQ.
  auto with *.
 simpl.
 csetoid_rewrite_rev IHn.
 assert (Y:Continuous_I (Min_leEq_Max [1] c) (([-C-][1]{-}FId){^}n)).
  Contin.
 csetoid_replace ((nexp IR n [--][1][*][--][1][*][--][1][/]nring (R:=IR) n[+][1][//]
   nringS_ap_zero IR n)[*](nexp IR n (c[-][1])[*](c[-][1]))) (Integral Y).
  assert (Y0:=Continuous_I_plus _ _ _ _ _ (fun_seq_part_sum_cont (Min [1] c) (Max [1] c) (Min_leEq_Max [1] c)
    (Fnth (R:=IR) ([-C-][1]{-}FId)) X n) Y).
  stepl (Integral Y0).
   apply Integral_plus.
  apply Integral_wd.
  apply eq_imp_Feq; try Included.
   intros x Hx; split; constructor.
  intros x H Hx Hx'.
  simpl.
  apply eq_reflexive.
 rstepl ((nexp IR n [--][1][/]nring (R:=IR) n[+][1][//]
   nringS_ap_zero IR n)[*](nexp IR n (c[-][1])[*](c[-][1]))).
 change ((nexp IR n [--][1][/]nring (R:=IR) n[+][1][//]nringS_ap_zero IR n)[*]
   (nexp IR n (c[-][1])[*](c[-][1])))
     with (([--][1][^]n[/]_[//]nringS_ap_zero IR n)[*](c[-][1])[^](S n)).
 pose (G:=(([--][1][/]_[//]nringS_ap_zero IR n){**}([-C-][1]{-}FId){^}(S n))).
 assert (X0:Derivative (olor [0] Two) (pos_two IR) G (([-C-][1]{-}FId){^}n)).
  unfold G.
  eapply Derivative_wdr; simpl in |- *;
   [|apply Derivative_scal;refine (Derivative_nth _ _ _ _ _ _);Deriv].
  FEQ.
  repeat constructor.
 assert (X1:Continuous (olor [0] Two) (([-C-][1]{-}FId){^}n)).
  Contin.
 assert (X2:(olor [0] Two [1])).
  split.
   apply pos_one.
  apply one_less_two.
 eapply eq_transitive.
  2:apply eq_symmetric.
  2:apply (fun A => Barrow (olor [0] Two) _ X1 _ _ X0 _ _ A X2 Hc0).
 simpl.
 rstepr (([--][1][/]nring (R:=IR) n[+][1][//]nringS_ap_zero IR n)[*]
   (nexp IR n ([1][-]c)[*]([1][-]c))).
 change (([--][1][^]n[/]_[//]nringS_ap_zero IR n)[*] ((c[-][1])[^](S n))[=]
   ([--][1][/]_[//]nringS_ap_zero IR n)[*] (([1][-]c)[^](S n))).
 rstepr (([--][1][/]nring (R:=IR) (S n)[//]nringS_ap_zero IR n)[*] ([--][1][*](c[-][1]))[^]S n).
 csetoid_rewrite (mult_nexp IR ([--][1]) (c[-][1]) (S n)).
 simpl.
 rational.
Qed.

End Log_Series.


Add LoadPath "src".
Require Import Maps.
Require Import Context.

Import Context.Context.
Require Import Coq.Lists.List.
Require Import Smty.
Require Import LibTactics.
Require Import SSmty.

Import Smty.Smty.

Module SmtyP.
(* Nominal Typing. *)

Fixpoint rcd_cons_ty (rcd : list (id * ty)) (retty : ty) : ty :=
    match rcd with
    | nil => retty
    | (_, h)::t => TFun h (rcd_cons_ty t retty)
    end.

Fixpoint rcd_field_ty (rcd: list (id * ty)) (field : id) : option ty :=
    match rcd with
    | nil => None
    | (i, ret)::t  => if (eq_id_dec i field)
                        then Some ret
                        else rcd_field_ty t field
    end.

Inductive has_type : Context -> tm -> ty -> Prop :=
| ht_none :
    forall ctx,
        has_type ctx tnone TNone
| ht_if :
    forall vctx crit tb fb T,
    has_type vctx crit TBool ->
    has_type vctx tb T ->
    has_type vctx fb T ->
    has_type vctx (tif crit tb fb) T
| ht_var: forall ctx T i,
    byContext ctx i = Some T ->
    has_type ctx (tvar i) T
| ht_int : forall ctx n,
    has_type ctx (tint n) TNat
| ht_suc : forall ctx t,
    has_type ctx t TNat ->
    has_type ctx (tsuc t) TNat
| ht_dec : forall ctx t,
    has_type ctx t TNat ->
    has_type ctx (tdec t) TNat
| ht_ngt : forall ctx t0 t1,
    has_type ctx t0 TNat ->
    has_type ctx t1 TNat ->
    has_type ctx (tngt t0 t1) TBool
| ht_nlt : forall ctx t0 t1,
    has_type ctx t0 TNat ->
    has_type ctx t1 TNat ->
    has_type ctx (tnlt t0 t1) TBool
| ht_neq : forall ctx t0 t1,
    has_type ctx t0 TNat ->
    has_type ctx t1 TNat ->
    has_type ctx (tneq t0 t1) TBool
| ht_chr : forall ctx n,
    has_type ctx (tchr n) TChr
| ht_ceq : forall ctx t0 t1,
    has_type ctx t0 TChr ->
    has_type ctx t1 TChr ->
    has_type ctx (tceq t0 t1) TBool
| ht_fun : forall ctx i T body TO,
    has_type (update i T ctx) body TO ->
    has_type ctx (tfun i T body) (TFun T TO)
| ht_app : forall ctx t0 t1 T0 T1,
    has_type ctx t0 (TFun T0 T1) ->
    has_type ctx t1 T0 ->
    has_type ctx (tapp t0 t1) T1
| ht_let : forall ctx i T bind body T',
    has_type (update i T ctx) bind T ->
    has_type (update i T ctx) body T' ->
    has_type ctx (tlet i T bind body) T'
| ht_true : forall ctx,
    has_type ctx ttrue TBool
| ht_false : forall ctx,
    has_type ctx tfalse TBool
| ht_beq : forall ctx t0 t1,
    has_type ctx t0 TBool ->
    has_type ctx t1 TBool ->
    has_type ctx (tbeq t0 t1) TBool
| ht_left : forall ctx t0 TL TR,
    has_type ctx t0 TL ->
    has_type ctx (tleft t0 TR) (TSum TL TR)
| ht_right : forall ctx t0 TL TR,
    has_type ctx t0 TR ->
    has_type ctx (tright TL t0) (TSum TL TR)
| ht_case : forall ctx crit tl tr TL TR TO,
    has_type ctx crit (TSum TL TR) ->
    has_type ctx tl (TFun TL TO) ->
    has_type ctx tr (TFun TR TO) ->
    has_type ctx (tcase crit tl tr) TO
| ht_letrcd : forall ctx cons rcd tid suty body TO,
    inheritable suty ->
    has_type (update cons (rcd_cons_ty rcd (TRcd tid suty rcd)) ctx) body TO ->
    has_type ctx (tletrcd cons tid suty rcd body) TO
| ht_field : forall ctx rcd i tid suty T,
    rcd_field_ty rcd i = Some T ->
    has_type ctx (tfield (TRcd tid suty rcd) i) (TFun (TRcd tid suty rcd) T)
| ht_seq : forall ctx t0 t1 T0 T1,
    has_type ctx t0 T0 ->
    has_type ctx t1 T1 ->
    has_type ctx (tseq t0 t1) T1.

Hint Constructors has_type.

Definition check_inheritable (T : ty) : bool :=
match T with
| TNone => true
| TRcd _ _ _ => true
| _ => false
end.

Lemma cinh_t_inh :
forall t,
    check_inheritable t = true ->
    inheritable t.
intro t; induction t; intros; try discriminate; cbn in *; eauto.
Qed.

Lemma inh_cinh_t :
forall t,
    inheritable t ->
    check_inheritable t = true.
intros t h; induction h; intros; try discriminate; cbn in *; eauto.
Qed.

Lemma cinh_f_ninh :
forall t,
check_inheritable t = false ->
~inheritable t.

intro t; induction t; intros; intro h';
try (destruct h'; subst; eauto) ;try discriminate; cbn in *; eauto.
Qed.

Hint Resolve cinh_t_inh inh_cinh_t cinh_f_ninh.

Fixpoint nominal_typed (ctx: Context) (t : tm) : option ty :=
    match t with
    | tnone => Some TNone
    | tif crit tb fb =>
        match (nominal_typed ctx crit) with
            | Some TBool => match (nominal_typed ctx tb), (nominal_typed ctx fb) with
                            | Some a, Some b => if(eq_ty_dec a b) then Some a else None
                            | _, _ => None
                            end
            | _ => None
        end
    | tvar i => byContext ctx i
    | tint _ => Some TNat
    | tsuc n =>
        match (nominal_typed ctx n) with
            | Some TNat => Some TNat
            | _ => None
        end
    | tdec n =>
        match (nominal_typed ctx n) with
            | Some TNat => Some TNat
            | _ => None
        end
    | tngt a b =>
        match (nominal_typed ctx a), (nominal_typed ctx b) with
            | Some TNat, Some TNat => Some TBool
            | _, _ => None
        end
    | tnlt a b =>
        match (nominal_typed ctx a), (nominal_typed ctx b) with
            | Some TNat, Some TNat => Some TBool
            | _, _ => None
        end
    | tneq a b =>
        match (nominal_typed ctx a), (nominal_typed ctx b) with
            | Some TNat, Some TNat => Some TBool
            | _, _ => None
        end
    | tchr _ => Some TChr
    | tceq a b =>
        match (nominal_typed ctx a), (nominal_typed ctx b) with
            | Some TChr, Some TChr => Some TBool
            | _, _ => None
        end
    | tfun i T body =>
        match nominal_typed (update i T ctx) body with
            | Some TO => Some (TFun T TO)
            | _ => None
        end
    | tapp a b =>
        match (nominal_typed ctx a), (nominal_typed ctx b) with
            | Some (TFun i o), Some Ti => if(eq_ty_dec i Ti) then Some o else None
            | _, _ => None
        end
    | tlet i T bind body =>
        match (nominal_typed (update i T ctx) bind) with
        | Some Tbind => if (eq_ty_dec T Tbind) then nominal_typed (update i T ctx) body else None
        | _ => None
        end
    | ttrue => Some TBool
    | tfalse => Some TBool
    | tbeq a b=>
        match (nominal_typed ctx a), (nominal_typed ctx b) with
            | Some TBool, Some TBool => Some TBool
            | _, _ => None
        end
    | tleft t T =>
        match (nominal_typed ctx t) with
            | Some TL => Some (TSum TL T)
            | _ => None
        end
    | tright T t =>
        match (nominal_typed ctx t) with
            | Some TR => Some (TSum T TR)
            | _ => None
        end
    | tcase crit lb rb =>
        match (nominal_typed ctx crit), (nominal_typed ctx lb), (nominal_typed ctx rb) with
        | Some (TSum TL TR), Some (TFun TL0 TO0), Some (TFun TR0 TO1) =>
            if (andb (eq_ty_dec_bool TL TL0) (andb (eq_ty_dec_bool TR TR0) (eq_ty_dec_bool TO0 TO1)) )
            then Some TO0 else None
        | _, _, _ => None
        end
    | tletrcd cons' T suTy rcd body =>
        if(check_inheritable suTy) then
        nominal_typed (update cons' (rcd_cons_ty rcd (TRcd T suTy rcd)) ctx) body
        else None
    | tfield (TRcd a b rcd) i =>
        match (rcd_field_ty rcd i) with
        | Some TO => Some (TFun (TRcd a b rcd) TO)
        | _ => None
        end
    | tfield _ _ => None
    | tseq pre post =>
        match nominal_typed ctx pre with
        | Some _ => nominal_typed ctx post
        | _ => None
        end
    end.

Ltac keep_rewrite :=
    match goal with
    | h: _ = _ |- _ => rewrite h; clear h; keep_rewrite
    | h: _ = _ |- _ => try rewrite <- h; clear h; keep_rewrite
    | _ => idtac
    end.

Theorem typed__nominal_typed :
    forall t T,
    has_type empty t T ->
    nominal_typed empty t = Some T.

    intros t T h;
    induction h; try (eauto; fail);

    cbn;
    keep_rewrite; eauto using eq_ty_dec_id.

    repeat (rewrite eq_ty_dec_bool_true). cbn. eauto.
    poses' (inh_cinh_t _ H). rewrite H0; cbn; eauto.

Qed.

Ltac destruct_match :=
    match goal with
    | h: match ?A with  _ => _  end = _ |- _ => destruct A; destruct_match; subst; eauto
    | _ => idtac
    end.

Ltac apply_ctx ctx :=
    match goal with
    | h: forall x, _ |- _ =>
        let x := fresh "h" in
        (pose (h ctx) as x); generalize x; clear x; clear h; apply_ctx ctx
    | _ => idtac
    end; intros.

Ltac destruct_match_keep :=
    match goal with
    | h: match ?A with  _ => _  end = _ |- _ =>
        let k:= fresh in
        destruct A eqn: k; destruct_match_keep
    | _ => idtac
    end.

Ltac true_AND_has_to_be_true :=
    match goal with
    | h: (andb ?A  ?B) = true |- _ =>
    let a := fresh "A" in
    let b := fresh "B" in
    destruct A eqn:a;
    destruct B eqn:b;
    try rewrite a in h;
    try rewrite b in h;
    eauto; cbn in h;
    try discriminate;
    generalize dependent h; true_AND_has_to_be_true
    | _ => idtac
    end; intros.

Theorem nominal_typed__typed:
    forall t ctx T,
    nominal_typed ctx t = Some T ->
    has_type ctx t T.

    intros t.
    induction t; intros; eauto;
    try (cbn in H;
    apply_ctx ctx;
        destruct_match;
        try discriminate;
        match goal with
        | h : Some _ = Some _ |- _ => injection h; intros; subst; eauto
        | _ => idtac
        end; fail).
    (* Case TFun. I am lazy with abstraction... *)
    cbn in H.
    poses' (IHt (update i t ctx)).
    destruct_match.
    injection H;intros ;subst;eauto.
    try discriminate.

    (* Case tlet *)
    cbn in H.
    poses' (IHt1 (update i t1 ctx)).
    poses' (IHt2 (update i t1 ctx)).
    destruct_match; try discriminate.

    (* Case tcase *)
    apply_ctx ctx.
    cbn in H.
    destruct_match_keep; subst; eauto;
    try discriminate.
    forwards: h;
    forwards: h0;
    forwards: h1; eauto.
    injection H; intros; subst; eauto.
(*    let a := fresh "A" in
    let b := fresh "B" in
    destruct (eq_ty_dec_bool t0_1 t4_1) eqn:a;
    destruct (eq_ty_dec_bool t0_2 t5_1) eqn:b.
    rewrite a in H6;
    rewrite b in H6;
    eauto; cbn in H6;
    try discriminate;
    generalize dependent H6.*)
    true_AND_has_to_be_true.
    poses' (true_eq_ty_dec_bool _ _ A);
    poses' (true_eq_ty_dec_bool _ _ A0);
    poses' (true_eq_ty_dec_bool _ _ B0); subst; eauto.

    (* Case tletrcd*)
    cbn in H.
    poses' (IHt (update i (rcd_cons_ty l (TRcd t t0 l)) ctx));
    eauto.
    destruct (check_inheritable t0) eqn: h1; eauto; try discriminate.

    (* Case tfield *)
    cbn in H. destruct t; subst; eauto; try discriminate.
    destruct (rcd_field_ty l i) eqn: h1; eauto; try discriminate.
    injection H; intros; eauto. subst T.
    eauto.
Qed.

End SmtyP.


From stdpp Require Import prelude fin_maps natmap.
From Hammer Require Import Tactics.

(** * Ite expression *)

Inductive Ite : Set :=
| var : nat -> Ite
| lit : bool -> Ite
| ite : Ite -> Ite -> Ite -> Ite
.

Coercion var : nat >-> Ite.
Coercion lit : bool >-> Ite.

Instance Ite_eq : EqDecision Ite.
solve_decision.
Defined.

(** * Specification of Normalization *)

Inductive norm : Ite -> Prop :=
| NVar x : norm (var x)
| NLit l : norm (lit l)
| NIte x a b :
  norm a ->
  norm b ->
  a <> b ->
  norm (ite (var x) a b)
.

Fixpoint interp (m : nat -> bool) (e : Ite) : bool :=
  match e with
  | var x => m x
  | lit b => b
  | ite c a b =>
      if interp m c
      then interp m a
      else interp m b
  end.

(** * Normalization Procedure *)
(** Assume [c], [a] and [b] are in normal form. *)
Fixpoint combine (c a b : Ite) : Ite :=
  match c with
  | var x =>
      if decide (a = b)
      then a
      else ite x a b
  | lit l => if l then a else b
  | ite c' a' b' =>
      let a' := combine a' a b in
      let b' := combine b' a b in
      if decide (a' = b')
      then a'
      else ite c' a' b'
  end.

Fixpoint normalize (e : Ite) : Ite :=
  match e with
  | ite c a b =>
      combine (normalize c) (normalize a) (normalize b)
  | _ => e
  end.

(** * Theorems about normalization *)

(** ** Normalization *)

Lemma combine_normal c a b :
  norm c ->
  norm a ->
  norm b ->
  norm (combine c a b).
Proof.
  induction 1; intros; simpl; try case_split; auto using norm.
Qed.

Theorem normalize_normal e :
  norm (normalize e).
Proof.
  induction e; simpl; auto using norm, combine_normal.
Qed.

(** ** Correctness *)

Lemma combine_correctness m c a b :
  norm c ->
  interp m (combine c a b) = if interp m c
                             then interp m a
                             else interp m b.
Proof.
  induction 1; simpl;
    try case_decide; subst; auto;
    hauto.
Qed.

Theorem correctness m e :
  interp m (normalize e) = interp m e.
Proof.
  induction e; simpl; auto.
  rewrite combine_correctness by auto using normalize_normal.
  qauto.
Qed.

(** * Specification of Simplification *)

(** Assume everything is in normal form from now on. *)

Inductive not_appear_in : nat -> Ite -> Prop :=
| AVar x y : x <> y -> not_appear_in x (var y)
| ALit b x : not_appear_in x (lit b)
| AIte y a b x :
  x <> y ->
  not_appear_in x a ->
  not_appear_in x b ->
  not_appear_in x (ite (var y) a b)
.

Inductive simplified : Ite -> Prop :=
| SVar x : simplified (var x)
| SLit l : simplified (lit l)
| SIte x a b :
  not_appear_in x a ->
  not_appear_in x b ->
  simplified (ite (var x) a b)
.

(** * Simplification Procedure *)

Fixpoint simplify_ (m : natmap bool) (e : Ite) : Ite :=
  match e with
  | var x =>
      match m !! x with
      | Some b => lit b
      | None => var x
      end
  | lit l => lit l
  | ite (var x) a b =>
      match m !! x with
      | Some true => simplify_ m a
      | Some false => simplify_ m b
      | None =>
          let a' := simplify_ (<[x:=true]>m) a in
          let b' := simplify_ (<[x:=false]>m) b in
          if decide (a' = b')
          then a'
          else ite (var x) a' b'
      end
  (* Bogus *)
  | _ => false
  end.

Definition simplify := simplify_ ∅.

(** * Theorems about Simplification *)

(** ** Simplification *)

Lemma simplify_not_appear m e x b :
  norm e ->
  not_appear_in x (simplify_ (<[x:=b]>m) e).
Proof.
  intros H. revert m x b.
  induction H; intros; simpl; auto using not_appear_in.
  - case_split; auto using not_appear_in.
    select (_ !! _ = _) (fun H => apply lookup_insert_None in H).
    qauto ctrs: not_appear_in.
  - case_split. qauto.
    select (_ !! _ = _) (fun H => apply lookup_insert_None in H).
    simp_hyps.
    case_decide.
    by rewrite insert_commute by auto.
    econstructor; auto;
      by rewrite insert_commute by auto.
Qed.

Lemma simplify_simplified_ m e :
  norm e ->
  simplified (simplify_ m e).
Proof.
  intros H. revert m.
  induction H; intros; simpl; auto using simplified.
  qauto ctrs: simplified.
  case_split; try qauto.
  case_decide; auto using simplified, simplify_not_appear.
Qed.

Theorem simplify_simplified e :
  norm e ->
  simplified (simplify e).
Proof.
  eauto using simplify_simplified_.
Qed.

(** ** Normalization *)

Lemma simplify_norm_ m e :
  norm e ->
  norm (simplify_ m e).
Proof.
  intros H. revert m.
  induction H; intros; simpl; auto using norm.
  qauto ctrs: norm.
  case_split. qauto.
  case_decide; auto.
  econstructor; eauto.
Qed.

Theorem simplify_norm e :
  norm e ->
  norm (simplify e).
Proof.
  eauto using simplify_norm_.
Qed.

(** ** Correctness *)

Definition consistent (m : nat -> bool) (p : natmap bool) :=
  forall x b, p !! x = Some b -> m x = b.

Lemma insert_consistent m p x' b' :
  consistent m p ->
  m x' = b' ->
  consistent m (<[x':=b']>p).
Proof.
  intros; subst.
  hnf. intros.
  select (_ !! _ = Some _)
           (fun H => eapply lookup_insert_Some in H);
    intuition eauto.
Qed.

Lemma empty_consistent m :
  consistent m ∅.
Proof.
  hnf. intros. simplify_map_eq.
Qed.

Lemma simplify_correct_ m p e :
  norm e ->
  consistent m p ->
  interp m (simplify_ p e) = interp m e.
Proof.
  intros H Hc. revert p Hc.
  induction H; intros; simpl; auto.
  case_split; simpl; qauto unfold: consistent.
  case_split.
  select (_ !! _ = _) (fun H => apply Hc in H). qauto.
  case_decide; simpl;
    (case_match;
     [| try select (simplify_ _ _ = simplify_ _ _)
            (fun H => rewrite H) ]);
    (* Apply induction hypothesis. *)
    match goal with
    | IH : forall _, _ -> interp _ _ = ?e |- _ = ?e =>
        apply IH
    end;
    auto using insert_consistent.
Qed.

Theorem simplify_correct m e :
  norm e ->
  interp m (simplify e) = interp m e.
Proof.
  eauto using simplify_correct_, empty_consistent.
Qed.

(** * Examples *)

Module examples.

Definition m (n : nat) : bool :=
  match n with
  | 1 => false
  | 2 => true
  | 3 => false
  | 4 => true
  | 5 => false
  | 6 => true
  | 7 => false
  | _ => false
  end.

Definition e1 :=
  ite (ite 1 true false) (ite 1 3 4) (ite 5 1 7).

Compute (normalize e1).
Compute simplify (normalize e1).

Compute interp m e1.
Compute interp m (normalize e1).

Definition e2 :=
  ite 1 1 true.

Compute (normalize e2).
Compute simplify (normalize e2).

Compute interp m e2.
Compute interp m (normalize e2).

End examples.


Require Import Coq.Lists.List.
Require Import Omega.
Require Import Coq.Logic.ProofIrrelevance.

Require Export EnvLibA.

Import ListNotations.

Lemma valTyp_irrelevance : forall (T: Type) (p1 p2: ValTyp T), p1 = p2.
intros.
eapply proof_irrelevance.
Qed.

(*********************************************************************)

Inductive MatchEnvs {K V1 V2: Type} {h: DEq K} (rel: V1 -> V2 -> Prop) :
          Envr K V1 -> Envr K V2 -> Prop :=
| MatchEnvs_Nil : MatchEnvs rel nil nil
| MatchEnvs_Cons : forall ls1 ls2 k v1 v2,
                     rel v1 v2 ->
                     MatchEnvs rel ls1 ls2 ->
                     MatchEnvs rel ((k,v1)::ls1) ((k,v2)::ls2).

(*********************************************************************)

(** lemmas on MatchEnvs *)

Lemma consEnvLemma {K V1 V2: Type} {h: DEq K} (rel: V1 -> V2 -> Prop)
              (env1: Envr K V1) (env2: Envr K V2) (x: K)
                      (v1: V1) (v2: V2):
    MatchEnvs rel env1 env2 ->
    rel v1 v2 ->
    MatchEnvs rel ((x, v1)::env1) ((x, v2)::env2).
Proof.
  intros.
  constructor.
  assumption.
  assumption.
Defined.

Lemma updateEnvLemma {K V1 V2: Type} {h: DEq K} (rel: V1 -> V2 -> Prop)
              (env1: Envr K V1) (env2: Envr K V2) (x: K)
                      (v1: V1) (v2: V2):
    MatchEnvs rel env1 env2 ->
    rel v1 v2 ->
    MatchEnvs rel (updateE env1 x v1) (updateE env2 x v2).
Proof.
  unfold updateE.
  eapply consEnvLemma.
Defined.

Lemma app_cons_assoc {A: Type} (x: A) (ls1 ls2: list A):
       (x :: ls1) ++ ls2 = x :: (ls1 ++ ls2).
Proof.
simpl.
reflexivity.
Defined.

Lemma appEnvLemma {K V1 V2: Type} {h: DEq K} (rel: V1 -> V2 -> Prop):
     forall (env1A env1B: Envr K V1) (env2A env2B: Envr K V2),
  MatchEnvs rel env1A env2A ->
  MatchEnvs rel env1B env2B ->
  MatchEnvs rel (env1A ++ env1B) (env2A ++ env2B).
Proof.
  induction env1A.
  intros.
  induction env2A.
  simpl.
  assumption.
  inversion H.
  induction env2A.
  intros.
  inversion H.
  intros.
  simpl.
  destruct a.
  destruct a0.
  destruct (dEq k k0).
  Focus 2.
  inversion H; subst.
  intuition n.
  destruct e.
  inversion H; subst.
  constructor.
  assumption.
  apply IHenv1A.
  assumption.
  assumption.
Defined.

Lemma overrideEnvLemma {K V1 V2: Type} {h: DEq K} (rel: V1 -> V2 -> Prop):
     forall (env1A env1B: Envr K V1) (env2A env2B: Envr K V2),
  MatchEnvs rel env1A env2A ->
  MatchEnvs rel env1B env2B ->
  MatchEnvs rel (env1A ++ env1B) (env2A ++ env2B).
Proof.
  eapply appEnvLemma.
Defined.

Lemma RelatedByEnvEP {K V1 V2: Type} {h: DEq K} (rel: V1 -> V2 -> Prop)
                     (env1: Envr K V1) (env2: Envr K V2) (x: K)
                     (v1: V1) (v2: V2)
         : MatchEnvs rel env1 env2 -> findEP env1 x v1 ->
           findEP env2 x v2 -> rel v1 v2.
Proof.
  intros.
  inversion H0; subst.
  inversion H1; subst.
  induction H.
  inversion H2.
  inversion H3; subst.
  inversion H2; subst.
  destruct (dEq x k).
  inversion H6; subst.
  inversion H7; subst.
  assumption.
  apply IHMatchEnvs.
  constructor.
  assumption.
  constructor.
  assumption.
  assumption.
  assumption.
Defined.

Lemma RelatedByEnvEP2 {K V1 V2: Type} {h: DEq K} (rel: V1 -> V2 -> Prop)
                     (env1: Envr K V1) (env2: Envr K V2) (x: K)
                     (v1: V1) (v2: V2)
         : MatchEnvs rel env1 env2 -> findEP2 env1 x v1 ->
           findEP2 env2 x v2 -> rel v1 v2.
intros.
apply findEP2toEP in H0.
apply findEP2toEP in H1.
eapply RelatedByEnvEP.
eassumption.
eassumption.
assumption.
Defined.

Lemma ExRelVal {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
       (tenv: Envr K V2) (venv: Envr K V1) (x: K) (t: V2):
    MatchEnvs R venv tenv ->
    findEP tenv x t ->
    exists v: V1, findEP venv x v /\ R v t.
Proof.
  intros.
  induction H; subst.
  inversion H0.
  inversion H.
  inversion H0; subst.
  inversion H2; subst.
  rename v2 into t2.
  destruct (dEq x k).
  inversion H4; subst.
  exists v1.
  split.
  constructor.
  simpl.
  destruct (dEq k k).
  auto.
  intuition n.
  assumption.
  assert (findEP ls2 x t).
  constructor.
  auto.
  eapply IHMatchEnvs in H3.
  destruct H3.
  destruct H3.
  exists x0.
  split.
  constructor.
  simpl.
  destruct (dEq x k).
  rewrite e in n.
  intuition n.
  inversion H3; subst.
  assumption.
  assumption.
Defined.

Lemma ExRelValRev {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
       (tenv: Envr K V2) (venv: Envr K V1) (x: K) (v: V1):
    MatchEnvs R venv tenv ->
    findEP venv x v ->
    exists t: V2, findEP tenv x t /\ R v t.
Proof.
  intros.
  induction H; subst.
  inversion H0.
  inversion H.
  inversion H0; subst.
  inversion H2; subst.
  rename v2 into t1.
  destruct (dEq x k).
  inversion H4; subst.
  exists t1.
  split.
  constructor.
  simpl.
  destruct (dEq k k).
  auto.
  intuition n.
  assumption.
  assert (findEP ls1 x v).
  constructor.
  auto.
  eapply IHMatchEnvs in H3.
  destruct H3.
  destruct H3.
  exists x0.
  split.
  constructor.
  simpl.
  destruct (dEq x k).
  rewrite e in n.
  intuition n.
  inversion H3; subst.
  assumption.
  assumption.
Defined.

Lemma ExRelValNone {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
       (tenv: Envr K V2) (venv: Envr K V1) (x: K) (t: V2):
    MatchEnvs R venv tenv ->
    findE tenv x = None ->
    findE venv x = None.
Proof.
  intros.
  induction H; subst.
  simpl.
  reflexivity.
  inversion H0; subst.
  simpl.
  destruct (dEq x k).
  inversion H3.
  apply IHMatchEnvs.
  assumption.
Defined.

Lemma ExRelValProj1 {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
       (tenv: Envr K V2) (venv: Envr K V1) (x: K) (t: V2):
    MatchEnvs R venv tenv ->
    findEP tenv x t ->
    exists v: V1, findEP venv x v.
Proof.
  intros.
  eapply ExRelVal in H.
  destruct H.
  destruct H.
  eexists.
  eauto.
  eauto.
Defined.

(*******************************************************************)

Inductive MatchEnvs2 {K V1 V2: Type} {h: DEq K} (rel: V1 -> V2 -> Prop) :
          Envr K V1 -> Envr K V2 -> Prop :=
| MatchEnvs2_Nil : MatchEnvs2 rel nil nil
| MatchEnvs2_Cons : forall ls5 ls6 ls1 ls2 ls3 ls4 k v1 v2,
                     rel v1 v2 ->
                     MatchEnvs rel ls1 ls2 ->
                     MatchEnvs rel ls3 ls4 ->
                     findE ls2 k = None ->
                     ls5 = ls1 ++ ((k,v1)::ls3) ->
                     ls6 = ls2 ++ ((k,v2)::ls4) ->
            MatchEnvs2 rel ls5 ls6.

(********************************************************************)

(** lemmas on MatchEnvs2 *)

Lemma MatchEnvs1to2 {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
          (env1: Envr K V1) (env2: Envr K V2) :
  MatchEnvs R env1 env2 -> MatchEnvs2 R env1 env2.
intros.
inversion H; subst.
constructor.
eapply MatchEnvs2_Cons.
eassumption.
eapply MatchEnvs_Nil.
eapply H1.
simpl.
reflexivity.
simpl.
reflexivity.
simpl.
reflexivity.
Defined.

Lemma MatchEnvs2to1 {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
          (env1: Envr K V1) (env2: Envr K V2) :
  MatchEnvs2 R env1 env2 -> MatchEnvs R env1 env2.
  intros.
  inversion H; subst.
  constructor.
  destruct ls1.
  destruct ls2.
  simpl.
  constructor.
  assumption.
  assumption.
  inversion H1.
  destruct ls2.
  inversion H1.
  rewrite <- app_comm_cons.
  rewrite <- app_comm_cons.
  destruct p.
  destruct p0.
  inversion H1; subst.
  eapply MatchEnvs_Cons.
  assumption.

  eapply appEnvLemma.
  assumption.
  eapply consEnvLemma.
  assumption.
  assumption.
Defined.

(***********************************************************************)

Inductive MatchEnvs2B {K V1 V2: Type} {h: DEq K} (rel: V1 -> V2 -> Prop)
          (k: K) (v1: V1) (v2: V2) : Envr K V1 -> Envr K V2 -> Prop :=
| MatchEnvs2B_split : forall ls5 ls6 ls1 ls2 ls3 ls4,
                     rel v1 v2 ->
                     MatchEnvs rel ls1 ls2 ->
                     MatchEnvs rel ls3 ls4 ->
                     findE ls2 k = None ->
                     ls5 = ls1 ++ ((k,v1)::ls3) ->
                     ls6 = ls2 ++ ((k,v2)::ls4) ->
            MatchEnvs2B rel k v1 v2 ls5 ls6.

(**********************************************************************)

(** lemmas on MatchEnvs2B *)

Lemma MatchEnvsB2A {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
      (env1: Envr K V1) (env2: Envr K V2)
      (k: K) (v1: V1) (v2: V2):
  MatchEnvs2B R k v1 v2 env1 env2 -> MatchEnvs2 R env1 env2.
intros.
inversion H; subst.
econstructor.
eassumption.
exact H1.
exact H2.
eassumption.
reflexivity.
reflexivity.
Defined.

(*********************************************************************)

Inductive EnvPos {K V: Type} {h: DEq K} :
             Envr K V -> K -> option nat -> Prop :=
| EnvPos_Nil : forall k: K, EnvPos emptyE k None
| EnvPos_Same : forall (env: Envr K V) (k: K) (v: V),
                    EnvPos ((k,v)::env) k (Some 0)
| EnvPos_Diff : forall (env: Envr K V) (k1 k2: K)
                         (n: nat) (v: V),
                    k1 <> k2 ->
                    EnvPos env k1 (Some n) ->
                    EnvPos ((k2,v)::env) k1 (Some (n+1)).

Inductive EnvPrefix {K V: Type} {h: DEq K} :
             Envr K V -> K -> Envr K V -> Prop :=
| EnvPrefix_Nil : forall k: K, EnvPrefix emptyE k emptyE
| EnvPrefix_Same : forall (env: Envr K V) (k: K) (v: V),
                    EnvPrefix ((k,v)::env) k emptyE
| EnvPrefix_Diff : forall (env1 env2: Envr K V) (k1 k2: K)
                          (v: V),
                    k1 <> k2 ->
                    EnvPrefix env1 k1 env2 ->
                    EnvPrefix ((k2,v)::env1) k1 ((k2,v)::env2).

Inductive EnvSuffix {K V: Type} {h: DEq K} :
             Envr K V -> K -> Envr K V -> Prop :=
| EnvSuffix_Nil : forall k: K, EnvSuffix emptyE k emptyE
| EnvSuffix_Same : forall (env: Envr K V) (k: K) (v: V),
                    EnvSuffix ((k,v)::env) k env
| EnvSuffix_Diff : forall (env1 env2: Envr K V) (k1 k2: K)
                         (v: V),
                    k1 <> k2 ->
                    EnvSuffix env1 k1 env2 ->
                    EnvSuffix ((k2,v)::env1) k1 env2.

(********************************************************************)

(** lemmas for EnvPos, EnvPrefix and EnvSuffix *)

Lemma MatchEnvsPos {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
                    (env1: Envr K V1) (env2: Envr K V2) :
  MatchEnvs R env1 env2 ->
  forall (k: K) (n1 n2: option nat),
    EnvPos env1 k n1 ->
    EnvPos env2 k n2 ->
    n1 = n2.
Proof.
  intros.
  dependent induction H.
  inversion H0; subst.
  inversion H1; subst.
  reflexivity.
  inversion H1; subst.
  inversion H2; subst.
  reflexivity.
  intuition H8.
  inversion H2; subst.
  inversion H1; subst.
  omega.
  intuition H7.
  specialize (IHMatchEnvs k0 (Some n) (Some n0) H9 H11).
  inversion IHMatchEnvs; subst.
  reflexivity.
Defined.

Lemma MatchEnvsPrefix {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
                    (env1: Envr K V1) (env2: Envr K V2) :
  MatchEnvs R env1 env2 ->
  forall k env3 env4,
    EnvPrefix env1 k env3 ->
    EnvPrefix env2 k env4 ->
    MatchEnvs R env3 env4.
Proof.
  intros.
  dependent induction H.
  inversion H0; subst.
  inversion H1; subst.
  constructor.
  inversion H1; subst.
  inversion H2; subst.
  constructor.
  intuition H8.
  inversion H2; subst.
  intuition H8.
  constructor.
  assumption.
  apply (IHMatchEnvs k0).
  assumption.
  assumption.
Defined.

Lemma MatchEnvsSuffix {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
                    (env1: Envr K V1) (env2: Envr K V2) :
  MatchEnvs R env1 env2 ->
  forall k env3 env4,
    EnvSuffix env1 k env3 ->
    EnvSuffix env2 k env4 ->
    MatchEnvs R env3 env4.
Proof.
  intros.
  dependent induction H.
  inversion H0; subst.
  inversion H1; subst.
  constructor.
  inversion H1; subst.
  inversion H2; subst.
  assumption.
  intuition H8.
  inversion H2; subst.
  intuition H8.
  apply (IHMatchEnvs k0).
  assumption.
  assumption.
Defined.

Lemma IsEnvPrefix {K V: Type} {h: DEq K}
                   (env: Envr K V) (k: K) :
  forall ls1 ls2 v,
    env = ls1 ++ ((k,v)::ls2) ->
    findE ls1 k = None ->
    EnvPrefix env k ls1.
Proof.
  intros.
  revert H H0.
  revert k v ls2 env.
  induction ls1.
  intros.
  simpl in H.
  rewrite H.
  constructor.
  intros.
  rewrite <- app_comm_cons in H.
  induction env.
  inversion H.
  inversion H; subst.
  destruct a.
  constructor.
  inversion H0; subst.
  destruct (dEq k k0).
  inversion H2.
  assumption.
  eapply find_simpl2 in H0.
  eapply IHls1 in H0.
  eassumption.
  reflexivity.
Defined.

Lemma IsEnvSuffix {K V: Type} {h: DEq K}
                   (env: Envr K V) (k: K) :
  forall ls1 ls2 v,
    env = ls1 ++ ((k,v)::ls2) ->
    findE ls1 k = None ->
    EnvSuffix env k ls2.
Proof.
  intros.
  revert H H0.
  revert k v ls2 env.
  induction ls1.
  intros.
  simpl in H.
  rewrite H.
  constructor.
  intros.
  rewrite <- app_comm_cons in H.
  induction env.
  inversion H.
  inversion H; subst.
  destruct a.
  constructor.
  inversion H0; subst.
  destruct (dEq k k0).
  inversion H2.
  assumption.
  eapply find_simpl2 in H0.
  eapply IHls1 in H0.
  eassumption.
  reflexivity.
Defined.

(***************************************************************)

(** more lemmas on MatchEnvs *)

Lemma MatchEnvsApp {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
                    (env1: Envr K V1) (env2: Envr K V2) :
  MatchEnvs R env1 env2 ->
  forall ls1 ls2 ls3 ls4 k v1 v2,
    env1 = ls1 ++ ((k,v1)::ls3) ->
    env2 = ls2 ++ ((k,v2)::ls4) ->
    findE ls1 k = None ->
    findE ls2 k = None ->
    R v1 v2 /\ MatchEnvs R ls1 ls2 /\ MatchEnvs R ls3 ls4.
Proof.
  intros.
  assert (env1 = ls1 ++ (k, v1) :: ls3) as E1.
  auto.
  assert (env2 = ls2 ++ (k, v2) :: ls4) as E2.
  auto.
  eapply IsEnvPrefix in E1.
  eapply IsEnvPrefix in E2.
  intros.
  assert (env1 = ls1 ++ (k, v1) :: ls3) as F1.
  auto.
  assert (env2 = ls2 ++ (k, v2) :: ls4) as F2.
  auto.
  eapply IsEnvSuffix in F1.
  eapply IsEnvSuffix in F2.
  intros.
  assert (env1 = ls1 ++ (k, v1) :: ls3) as G1.
  auto.
  assert (env2 = ls2 ++ (k, v2) :: ls4) as G2.
  auto.
  eapply IsEnvEl in G1.
  eapply IsEnvEl in G2.
  split.
  eapply RelatedByEnvEP.
  eapply H.
  eapply G1.
  apply G2.
  split.
  eapply MatchEnvsPrefix.
  eapply H.
  eapply E1.
  apply E2.
  eapply MatchEnvsSuffix.
  eapply H.
  eapply F1.
  apply F2.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
Defined.

Lemma MatchEnvsApp1 {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
                    (env1: Envr K V1) (env2: Envr K V2) :
  MatchEnvs R env1 env2 ->
  forall ls1 ls2 ls3 ls4 k v1 v2,
    env1 = ls1 ++ ((k,v1)::ls3) ->
    env2 = ls2 ++ ((k,v2)::ls4) ->
    findE ls1 k = None ->
    findE ls2 k = None ->
    R v1 v2.
Proof.
eapply MatchEnvsApp.
Defined.

Lemma MatchEnvsApp2 {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
                    (env1: Envr K V1) (env2: Envr K V2) :
  MatchEnvs R env1 env2 ->
  forall ls1 ls2 ls3 ls4 k v1 v2,
    env1 = ls1 ++ ((k,v1)::ls3) ->
    env2 = ls2 ++ ((k,v2)::ls4) ->
    findE ls1 k = None ->
    findE ls2 k = None ->
    MatchEnvs R ls1 ls2.
Proof.
eapply MatchEnvsApp.
Defined.

Lemma MatchEnvsApp3 {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
                    (env1: Envr K V1) (env2: Envr K V2) :
  MatchEnvs R env1 env2 ->
  forall ls1 ls2 ls3 ls4 k v1 v2,
    env1 = ls1 ++ ((k,v1)::ls3) ->
    env2 = ls2 ++ ((k,v2)::ls4) ->
    findE ls1 k = None ->
    findE ls2 k = None ->
    MatchEnvs R ls3 ls4.
Proof.
eapply MatchEnvsApp.
Defined.

Lemma MatchEnvsA2B {K V1 V2: Type} {h: DEq K} (R: V1 -> V2 -> Prop)
          (env1: Envr K V1) (env2: Envr K V2) :
  MatchEnvs2 R env1 env2 ->
  forall (k: K) (v1: V1) (v2: V2), findEP env1 k v1 ->
                                   findEP env2 k v2 ->
                              MatchEnvs2B R k v1 v2 env1 env2.
Proof.
intros.
assert (findEP env1 k v1) as K1.
auto.
assert (findEP env2 k v2) as K2.
auto.
apply findEPtoEP2 in K1.
apply findEPtoEP2 in K2.
inversion K1.
rename H3 into K3.
inversion K2.
rename H3 into K4.
dependent induction H.
eapply (MatchEnvs2B_split R k v1 v2 nil nil nil nil nil nil).
inversion H0; subst.
inversion H.
inversion H0; subst.
inversion H.
inversion H0; subst.
inversion H.
inversion H0; subst.
inversion H.
inversion H0; subst.
inversion H.
inversion H0; subst.
inversion H.
assert (MatchEnvs R (ls1 ++ (k, v1) :: ls3) (ls2 ++ (k, v2) :: ls4)).
eapply appEnvLemma.
assumption.
eapply consEnvLemma.
assumption.
assumption.
rewrite H3 in H7.
rewrite H4 in K4.
econstructor.
(*
inversion H5; subst.
inversion H6; subst.
*)
eapply RelatedByEnvEP.
exact H11.
rewrite <- H3.
exact H5.
rewrite <- H4.
exact H6.
(***)
instantiate (1:=m2).
instantiate (1:=m0).
(*rewrite H3 in H7.
rewrite H4 in K4.*)
eapply MatchEnvsApp2.
eapply H11.
eapply H7.
eapply K4.
assumption.
assumption.
instantiate (1:=m3).
instantiate (1:=m1).
eapply MatchEnvsApp3.
eapply H11.
eapply H7.
eapply K4.
assumption.
assumption.
assumption.
rewrite H3.
assumption.
rewrite H4.
assumption.
Defined.

(*********************************************************************)

Inductive LiftRel {A B: Type} (R: A -> B -> Prop) :
                       option A -> option B -> Prop :=
| SLift : forall (v: A) (t: B), R v t ->
                          LiftRel R (Some v) (Some t)
| NLift : LiftRel R None None.

(**********************************************************************)

(** lemmas on LiftRel *)

Lemma nthErrorAux3 {A B: Type} (R : A -> B -> Prop)
        (ls1: list A) (ls2: list B) (a: A) (b: B): (forall n : nat,
    LiftRel R (nth_error (a :: ls1) n) (nth_error (b :: ls2) n)) ->
  (forall n : nat, LiftRel R (nth_error ls1 n) (nth_error ls2 n)).
Proof.
intros.
specialize (H (S n)).
simpl in H.
assumption.
Defined.

Lemma sameBehSameLengthB {A B: Type} (R : A -> B -> Prop)
        (ls1: list A) (ls2: list B) : (forall n : nat,
          LiftRel R (nth_error ls1 n) (nth_error ls2 n)) ->
            length ls1 = length ls2.
Proof.
  intros.
  dependent induction ls1.
  dependent induction ls2.
  reflexivity.
  specialize (H 0).
  simpl in H.
  inversion H; subst.
  dependent induction ls2.
  specialize (H 0).
  simpl in H.
  inversion H.
  specialize (IHls1 ls2).
  assert ((forall n : nat,
    LiftRel R (nth_error (a :: ls1) n) (nth_error (a0 :: ls2) n)) ->
  (forall n : nat, LiftRel R (nth_error ls1 n) (nth_error ls2 n))).
  apply (nthErrorAux3 R ls1 ls2 a a0).
  assert (forall n : nat, LiftRel R (nth_error ls1 n) (nth_error ls2 n)).
  auto.
  apply IHls1 in H1.
  simpl.
  auto.
Defined.

(************************************************************************)

Inductive Forall3A {A B :Type} (R: A -> B -> Prop)
          (P: forall (a:A) (b:B), R a b -> Type) :
           list A -> list B -> Prop :=
| Forall3A_nil : Forall3A R P nil nil
| Forall3A_cons : forall (aas: list A) (bbs: list B)
                        (a:A) (b:B) (p: R a b),
                   P a b p ->
                   Forall3A R P aas bbs ->
                   Forall3A R P (a::aas) (b::bbs).

Inductive Forall3 {K A B :Type} (R: A -> B -> Prop)
          (P: forall (a:A) (b:B), R a b -> Prop) :
           Envr K A -> Envr K B -> Prop :=
| Forall3_nil : Forall3 R P nil nil
| Forall3_cons : forall (aas: Envr K A) (bbs: Envr K B)
                        (x:K) (a:A) (b:B) (p: R a b),
                   P a b p ->
                   Forall3 R P aas bbs ->
                   Forall3 R P ((x,a)::aas) ((x,b)::bbs).

Inductive Forall2B {K A B :Type} {h: DEq K} (R: A -> B -> Prop)
          (P: forall (a:A) (b:B), R a b -> Prop)
          (Q: forall (ls1: Envr K A) (ls2: Envr K B),
                     MatchEnvs R ls1 ls2 -> Prop) :
          K -> A -> B -> Envr K A -> Envr K B -> Prop :=
 Forall2B_split : forall (aas as1 as2: Envr K A)
                         (bbs bs1 bs2: Envr K B)
                         (k:K) (a:A) (b:B)
                         (p1: MatchEnvs R as1 bs1)
                         (p2: MatchEnvs R as2 bs2)
                         (p0: R a b),
                 aas = as1 ++ ((k,a)::as2) ->
                 bbs = bs1 ++ ((k,b)::bs2) ->
                 Q as1 bs1 p1 ->
                 Q as2 bs2 p2 ->
                 P a b p0 ->
                 Forall2B R P Q k a b aas bbs.

Inductive Forall2BC {K A B :Type} {h: DEq K} (R: A -> B -> Prop)
          (P: forall (ls1: Envr K A) (ls2: Envr K B),
                     MatchEnvs R ls1 ls2 -> Prop) :
          K -> A -> B -> Envr K A -> Envr K B -> Prop :=
 Forall2BC_split : forall (aas as1 as2: Envr K A)
                         (bbs bs1 bs2: Envr K B)
                         (k:K) (a:A) (b:B)
                         (p1: MatchEnvs R as1 bs1)
                         (p2: MatchEnvs R as2 bs2)
                         (p0: MatchEnvs R (singleE k a) (singleE k b)),
                 aas = as1 ++ ((k,a)::as2) ->
                 bbs = bs1 ++ ((k,b)::bs2) ->
                 P as1 bs1 p1 ->
                 P as2 bs2 p2 ->
                 P (singleE k a) (singleE k b) p0 ->
                 Forall2BC R P k a b aas bbs.

Inductive Forall2BB {K A B :Type} {h: DEq K} (R: A -> B -> Prop)
          (P: forall (a0:A) (b0:B), R a0 b0 -> Prop) :
          K -> A -> B -> Envr K A -> Envr K B -> Prop :=
| Forall2BB_one : forall (k:K) (a:A) (b:B) (p: R a b),
                 P a b p ->
                 Forall2BB R P k a b (singleE k a) (singleE k b)
| Forall2BB_cons : forall (aas as1 as2: Envr K A)
                         (bbs bs1 bs2: Envr K B)
                         (k:K) (a:A) (b:B) (p: R a b),
                    aas = as1 ++ ((k,a)::as2) ->
                    bbs = bs1 ++ ((k,b)::bs2) ->
                    findE as1 k = None ->
                    findE bs1 k = None ->
                    P a b p ->
                    Forall3 R P as1 bs1 ->
                    Forall3 R P as2 bs2 ->
                    Forall2BB R P k a b aas bbs.

(***********************************************************************)

(** lemmas for Forall *)

Lemma matchForallAux1 {K A B} {h: DEq K} (R: A -> B -> Prop)
      (P: forall (a:A) (b:B), R a b -> Prop)
      (env1: Envr K A) (env2: Envr K B) (x:K) (a:A) (b:B):
  Forall3 R P env1 env2 ->
  findEP env1 x a -> findEP env2 x b ->
  (forall p: R a b, P a b p).
Proof.
  intros.
  generalize dependent p.
  dependent induction H.
  inversion H0.
  inversion H.
  intros.
  inversion H1; subst.
  inversion H3; subst.
  destruct (dEq x x0) in H5.
  inversion H5; subst.
  inversion H2; subst.
  inversion H4; subst.
  destruct (dEq x0 x0) in H7.
  inversion H7; subst.
  assert (p = p0).
  apply proof_irrelevance.
  rewrite <- H6.
  assumption.
  intuition n.
  inversion H2; subst.
  inversion H4; subst.
  destruct (dEq x x0) in H7.
  inversion H7; subst.
  intuition n.
  eapply IHForall3.
  constructor.
  assumption.
  constructor.
  assumption.
Defined.

Lemma forall3ConsExt {K A B :Type} {h: DEq K} (R: A -> B -> Prop)
      (P: forall (a:A) (b:B), R a b -> Prop)
      (env1: Envr K A) (env2: Envr K B) (x:K) (a:A) (b:B) (p: R a b):
  Forall3 R P env1 env2 ->
  P a b p ->
  Forall3 R P ((x,a)::env1) ((x,b)::env2).
Proof.
  intros.
  econstructor.
  eassumption.
  assumption.
Defined.

Lemma forall3AppExt {K A B :Type} {h: DEq K} (R: A -> B -> Prop)
      (P: forall (a:A) (b:B), R a b -> Prop)
      (env1 env3: Envr K A) (env2 env4: Envr K B) (x:K):
  Forall3 R P env1 env2 ->
  Forall3 R P env3 env4 ->
  Forall3 R P (env1 ++ env3) (env2 ++ env4).
Proof.
  intros.
  dependent induction H.
  simpl.
  assumption.
  rewrite <- app_comm_cons.
  rewrite <- app_comm_cons.
  econstructor.
  eassumption.
  auto.
Defined.

Lemma forall2Bto3 {K A B :Type} {h: DEq K} (R: A -> B -> Prop)
      (P: forall (a:A) (b:B), R a b -> Prop)
      (env1: Envr K A) (env2: Envr K B) (x:K) (a:A) (b:B):
  @Forall2B K A B h R P (fun x y z => Forall3 R P x y) x a b env1 env2 ->
    Forall3 R P env1 env2.
Proof.
  intros.
  inversion H; subst.
  eapply (forall3ConsExt R P) in H3.
  instantiate (1:=b) in H3.
  instantiate (1:=x) in H3.
  instantiate (1:=a) in H3.
  eapply (forall3AppExt R P).
  auto.
  auto.
  auto.
  eauto.
Defined.

(* see OPEN PROBLEMS in EnvListAux8.v *)

(************************************************************************)

Inductive MatchLists {V1 V2: Type} (rel: V1 -> V2 -> Prop) :
          list V1 -> list V2 -> Prop :=
| MatchLists_Nil : MatchLists rel nil nil
| MatchLists_Cons : forall ls1 ls2 v1 v2,
                     rel v1 v2 ->
                     MatchLists rel ls1 ls2 ->
            MatchLists rel (v1::ls1) (v2::ls2).

(************************************************************************)

(** lemmas on MatchLists *)

Lemma prmsTypingAux1 {A T V: Type} (R: V -> T -> Prop)
        (fps : list (A * T)) (vls : list V)
        (h2: length fps = length vls):
  MatchLists R vls (map snd fps) ->
  MatchLists R (map snd (zip (map fst fps) vls (map_fst_length fps vls h2)))
               (map snd fps).
Proof.
  generalize h2; clear.
  dependent induction fps.
  dependent induction vls.
  intros.
  simpl.
  constructor.
  intros.
  inversion h2.
  dependent induction vls.
  intros.
  inversion h2.
  intros.
  simpl in h2.
  simpl in H.
  simpl.
  inversion H; subst.
  constructor.
  assumption.
  specialize (IHfps vls (cons_length fps vls a a0 h2) H5).
  assert (cons_length (map fst fps) vls (fst a) a0
                      (map_fst_length (a :: fps) (a0 :: vls) h2) = (map_fst_length fps vls (cons_length fps vls a a0 h2))).
  apply proof_irrelevance.
  rewrite H0.
  assumption.
Defined.

Lemma prmsTypingAux2 {A T V: Type} {h: DEq A} (R: V -> T -> Prop)
      (fps : list (A * T)) (vls : list V)
      (h2: length fps = length vls):

  (MatchLists R (map snd (zip (map fst fps) vls (map_fst_length fps vls h2)))
                (map snd fps)) ->
  (MatchEnvs R (zip (map fst fps) vls (map_fst_length fps vls h2)) fps).
Proof.
  generalize h2; clear.
  generalize dependent fps.
  induction vls.
  induction fps.
  intros.
  simpl.
  constructor.
  intro.
  inversion h2.
  generalize dependent vls.
  induction fps.
  intros.
  inversion h2.
  intros.
  specialize (IHvls fps (cons_length fps vls a0 a h2)).
  assert (MatchLists R (map snd (zip (map fst fps) vls
                      (map_fst_length fps vls (cons_length fps vls a0 a h2)))) (map snd fps)).
  simpl in H.
  inversion H; subst.
  assert (cons_length (map fst fps) vls (fst a0) a
                      (map_fst_length (a0 :: fps) (a :: vls) h2) = (map_fst_length fps vls (cons_length fps vls a0 a h2))).
  apply proof_irrelevance.
  rewrite <- H0.
  assumption.
  simpl.
  clear IHfps.
  destruct a0.
  simpl.
  inversion H; subst.
  constructor.
  assumption.
  specialize (IHvls H0).
  assert (cons_length (map fst fps) vls a0 a
                      (map_fst_length ((a0,t) :: fps) (a :: vls) h2) = (map_fst_length fps vls (cons_length fps vls (a0,t) a h2))).
  apply proof_irrelevance.
  rewrite H1.
  assumption.
Defined.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal86.

Set Printing Depth 1000.
Definition lfind_eval  y:=
Succ y.

Compute lfind_eval  (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Zero).


Require Import String. (* Standard library *)
Require Import Prelim. (* QWire *)

(* To be imported later as necessary *)
Require Matrix.
Require Complex.
Require Quantum.
Require Maps.

(******************************************************************************)
(* First we define Open QASM Grammar:
     https://arxiv.org/pdf/1707.03429.pdf pp. 21-22 *)
(******************************************************************************)

Definition id := string.
Definition real := R.
Definition nninteger := nat.

(* not explicit in grammar *)
Inductive binop : Set :=
| b_plus
| b_minus
| b_mult
| b_div
| b_pow.

Inductive unaryop : Set :=
| u_sin
| u_cos
| u_tan
| u_exp
| u_ln
| u_sqrt
| u_neg.

Inductive exp : Set :=
| e_real (r : real)
| e_nat (n : nninteger)
| e_pi
| e_id (name : id)
| e_binop (e1 : exp) (op : binop) (e2 : exp)
| e_unop (op : unaryop) (e : exp).

Definition explist := list exp.
Definition idlist := list id.

Inductive argument : Set :=
| a_id (name : id)
| a_ida (name : id) (size : nninteger).

(*
Definition mixedlist := list argument. (* probably imprecise *)
Definition anylist := list argument. (* probably imprecise *)
 *)

(* To prevent confusion over which of the two above lists to use,
   I am just going to use an arglist *)
Definition arglist := list argument.

Inductive uop : Set :=
| u_U (el : explist) (a : argument)
| u_CX (a1 a2 : argument)
| u_H (a : argument) (* custom addition *)
| u_X (a : argument) (* custom addition *)
| u_Y (a : argument) (* custom addition *)
| u_Z (a : argument) (* custom addition *)
| u_gate (name : id) (el : explist) (al : arglist).

Inductive qop : Set :=
| q_uop (u : uop)
| q_meas (aq ac : argument)
| q_reset (aq : argument).

(* not explicit in the grammar *)
Inductive gop : Set :=
| g_uop (u : uop)
| g_barrier (ids : idlist).

Definition goplist := list gop.

Inductive gatedecl : Set :=
| gate (name : id) (params : option idlist) (qargs : idlist) (body : goplist).

Inductive decl : Set :=
| d_qreg (name : id) (size : nninteger)
| d_creg (name : id) (size : nninteger).

Inductive statement : Type :=
| s_decl (d : decl)
| s_newgate (g : gatedecl) (* combines two production rules *)
| s_opaque (name : id) (params : option idlist) (qargs : idlist)
| s_qop (q : qop)
| s_if (name : id) (val : nninteger) (q : qop)
| s_barrier (args : arglist)
| s_seq (s1 s2 : statement). (* introducing this, not in the grammar *)

Definition program := list statement.

(* ignoring <mainprogram> as it serves no purpose for our needs *)

(******************************************************************************)
(* Next we need to define some variables and write some programs *)

Definition q : string := "q".
Definition c : string := "c".

(* Introduce some notation *)
Bind Scope statement_scope with statement.
Notation "'qreg' q # n" :=
  (s_decl (d_qreg q n)) (at level 60, right associativity) : statement_scope.
Notation "'creg' c # n" :=
  (s_decl (d_creg c n)) (at level 60, right associativity) : statement_scope.
Notation "'H' q # n" :=
  (s_qop (q_uop (u_H (a_ida q n)))) (at level 60, right associativity) : statement_scope.
Notation "'X' q # n" :=
  (s_qop (q_uop (u_X (a_ida q n)))) (at level 60, right associativity) : statement_scope.
Notation "'CX' q0 # n , q1 # m" :=
  (s_qop (q_uop (u_CX (a_ida q0 n) (a_ida q1 m)))) (at level 60, right associativity) : statement_scope.
Notation "'meas' q # n , c # m" :=
  (s_qop (q_meas (a_ida q n) (a_ida c m))) (at level 60, right associativity) : statement_scope.
(* Perhaps define this to be a `cons` and remove the `s_seq` additional statement
     above, so I can use `program` as the return type instead of statement *)
Notation "s1 ;; s2" :=
  (s_seq s1 s2) (at level 80, right associativity) : statement_scope.

Open Scope statement_scope.

(* Here's Deutsch algorithm in QASM that we write below. Src:
     https://github.com/Qiskit/openqasm/blob/master/examples/ibmqx2/Deutsch_Algorithm.qasm

     ```
     qreg q[2];
     creg c[1];

     X q[1];
     H q[0];
     H q[1];
     CX q[0],q[1];
     H q[0];

     measure q[0] -> c[0];
     ```
*)

Definition deutsch : statement :=
  qreg q#2;;
  creg c#1;;

  X q#1;;
  H q#0;;
  H q#1;;
  CX q#0, q#1;;
  H q#0;;
  meas q#0, c#0.

Print deutsch.

(* Now that we know that we can write programs using the Open QASM grammar,
     let's try writing and proving properties about the simplest of all,
     Phil's algorithm (Lipton, Regan Ch-7) basically a coin toss. *)

Definition phil1 : statement :=
  qreg q#1;;
  creg c#1;;

  H q#0;;
  meas q#0, c#0.

Print phil1.

(* Even this simplest of the algorithm's need us to be able to call a user
     defined gate -- H, so we need a way to do that. *)

(* An alternative is to define more elementary gates such as Pauli X, Y, Z
     and H as uop's which is what I chose to do, but I need a way to represent
     complex numbers, vectors and matrices first. *)

(* All three of the following modules courtesy of QWire project *)
Import Complex.
Import Matrix.
Import Quantum.

Open Scope C_scope.

(******************************************************************************)
(* Now we introduce state, the Maps module comes from Software Foundations *)

Import Maps.
(* We define state as a total map from id to density matrices *)
Definition state (n : nat) := total_map (Density n).

Definition zero (n : nat) : Density n :=
  fun x y => C0.

(* choosing to use fixed dimension of 2 as I haven't found a way to deal with
   correct dimensions of matrices yet when it comes to proofs *)
Definition empty_st := (_ !-> zero 2).

Check empty_st.

(* Sanity check *)
Example empty_state_zero_on_any : (empty_st c) = (zero _).
Proof. reflexivity. Qed.

Notation "a '!->' x"  := (t_update empty_st a x) (at level 100).

Fixpoint seval (ns : nat) (st : state ns) (s : statement) : state ns :=
  match s with
  | qreg q # n => (q !-> ∣0⟩ ; st) (* assuming single qubit *)
  | creg c # n => (c !-> zero 2 ; st) (* ditto *)
  | meas q # n, c # m => (c !-> meas_op (st q) ; st)
  | X q # n => (q !-> (super σx (st q)) ; st)
  | H q # n => (q !-> (super hadamard (st q)) ; st)
  | CX q1 # n, q2 # m => (q !-> (super cnot (kron (st q1) (st q2))) ; st) (* super hacky,
                                                                          see notes below *)
  | s_seq s1 s2 => let st' := seval ns st s1 in seval ns st' s2
  | _ => st (* leave unused operations undefined for now *)
  end.

Check seval 2 empty_st phil1.
Check seval 2 empty_st deutsch.

(* Sanity check *)
Example decl_adds_to_state : (seval 2 empty_st (qreg q#2%nat)) q
                             = ∣0⟩.
Proof. simpl. reflexivity. Qed.

(* Because of the way the state is defined, proof steps require finding the
   correct mapping before applying any matrix related tactics from QWire.
   In future, I would like to use a better data structure for state or come
   up with tactic automation to reduce this avoidable proof burden. *)
Example decl_meas : (seval 2 empty_st (qreg q#2%nat ;; meas q#0%nat, c#0%nat)) c
                    = ∣0⟩⟨0∣.
Proof.
  simpl.
  rewrite t_update_eq.
  rewrite t_update_eq.
  unfold meas_op.
  unfold Splus.
  unfold super.
  Msimpl.
  solve_matrix.
Qed.

(* Final output of running phil1 (coin toss) with fixed input ∣0⟩, ie equal
   probabilities of getting 0 or 1 *)
Definition phil1_zero : Density 2 :=
  (fun x y => match x, y with
          | 0, 0 => (1 / 2)
          | 1, 1 => (1 / 2)
          | _, _ => C0
          end).

(* First proper proof which basically verifies whether we get the right output *)
Theorem phil1_works : (seval 2 empty_st phil1) c
                     = phil1_zero.
Proof.
  simpl.
  rewrite t_update_eq.
  rewrite t_update_permute.
  rewrite t_update_permute.
  rewrite t_update_eq.
  unfold meas_op.
  unfold Splus.
  unfold super.
  Msimpl.
  solve_matrix.
  apply eqb_string_false_iff; reflexivity.
  apply eqb_string_false_iff; reflexivity.
Qed.
(* Here we also see the side effect of manually manipulating state map: extra
   goals are generated to ensure that identifiers are unique. The last two
   lines above take care of them. *)

(* Verifying working of Pauli X on ∣0⟩ state *)
Example X_works : (seval 2 empty_st (qreg q#2%nat;; X q#0%nat)) q
                  = ∣1⟩⟨1∣.
Proof.
  simpl.
  rewrite t_update_eq.
  rewrite t_update_eq.
  unfold super.
  Msimpl.
  solve_matrix.
Qed.

(* Unfortunately, I had to come up with a very hacky way to make CNOT (CX)
   work in the short term. Duely noted that both the representation of state
   and ability to manipulate individual qubits of a register need a lot more work.*)
Definition q1 : string := "q1".
Definition q2 : string := "q2".

(* Output of applying CX to ∣10⟩ *)
Definition CX_10 : Density 2 :=
  (fun x y => match x, y with
          | 3, 3 => C1
          | _, _ => C0
          end).

Example CX_works : (seval 2 empty_st (qreg q1#1%nat;;
                                      qreg q2#1%nat;;
                                      X q1#0%nat;;
                                      CX q1#0%nat, q2#0%nat))
                     q = CX_10.
Proof.
  simpl.
  rewrite t_update_eq.
  rewrite t_update_eq.
  rewrite t_update_permute.
  rewrite t_update_eq.
  rewrite t_update_neq.
  rewrite t_update_neq.
  rewrite t_update_eq.
  unfold super.
  Msimpl.
  solve_matrix.
  apply eqb_string_false_iff; reflexivity.
  apply eqb_string_false_iff; reflexivity.
  apply eqb_string_false_iff; reflexivity.
Qed.

(* Phil2 or bell pair generation *)
Definition bell_pair : statement :=
  qreg q1#1%nat;;
  qreg q2#1%nat;;

  H q1#0%nat;;
  CX q1#0%nat, q2#0%nat.

Print bell_pair.

(* Bell pair circuit output for ∣00⟩ *)
Definition bp_00 : Density 4 :=
  (fun x y => match x, y with
          | 0, 0 => 1/2
          | 0, 3 => 1/2
          | 3, 0 => 1/2
          | 3, 3 => 1/2
          | _, _ => C0
          end).

Example bp_works : (seval 2 empty_st bell_pair) q = bp_00.
Proof.
  simpl.
  rewrite t_update_eq.
  rewrite t_update_eq.
  rewrite t_update_permute.
  rewrite t_update_eq.
  rewrite t_update_neq.
  rewrite t_update_neq.
  rewrite t_update_eq.
  unfold super.
  Msimpl.
  solve_matrix.
  apply eqb_string_false_iff; reflexivity.
  apply eqb_string_false_iff; reflexivity.
  apply eqb_string_false_iff; reflexivity.
Qed.

(* After defining CX in a hacky way above, it is not worth trying to prove
   correctness of deutsch as it will involve several identifier changes.
   I hope to fix the fundamental issues with state. *)