(* 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.ftc.Rolle.
From Coq Require Import Lia.

Opaque Min.

Section Taylor_Defs.

(**
* Taylor's Theorem

We now prove Taylor's theorem for the remainder of the Taylor
series.  This proof is done in two steps: first, we prove the lemma
for a proper compact interval; next we generalize the result to two
arbitrary (eventually equal) points in a proper interval.

** First case

We assume two different points [a] and [b] in the domain of [F] and
define the nth order derivative of [F] in the interval
[[Min(a,b),Max(a,b)]].
*)

Variables a b : IR.
Hypothesis Hap : a [#] b.

(* begin hide *)
Let Hab' := ap_imp_Min_less_Max _ _ Hap.
Let Hab := less_leEq _ _ _ Hab'.
Let I := Compact Hab.
(* end hide *)

Variable F : PartIR.
Hypothesis Ha : Dom F a.
Hypothesis Hb : Dom F b.

(* begin show *)
Let fi n (Hf : Diffble_I_n Hab' n F) i Hi := ProjT1 (Diffble_I_n_imp_deriv_n _ _ _
 i F (le_imp_Diffble_I _ _ _ _ _ (lt_n_Sm_le i n Hi) _ Hf)).
(* end show *)

(**
This last local definition is simply:
$f_i=f^{(i)}$#fi=f(i)#.
*)

(* begin hide *)
Lemma Taylor_lemma1 : forall n Hf i Hi,
 Derivative_I_n Hab' i F (PartInt (fi n Hf i Hi)).
Proof.
 intros.
 unfold fi in |- *.
 apply projT2.
Qed.
(* end hide *)

(**
Now we can define the Taylor sequence around [a].  The auxiliary
definition gives, for any [i], the function expressed by the rule
%\[g(x)=\frac{f^{(i)}
(a)}{i!}*(x-a)^i.\]%#g(x)=f(i)(a)/i!*(x-a)i.#
We denote by [A] and [B] the elements of [[Min(a,b),Max(a,b)]]
corresponding to [a] and [b].
*)

(* begin hide *)
Let TL_compact_a := compact_Min_lft _ _ Hab.
Let TL_compact_b := compact_Min_rht _ _ Hab.

Notation A := (Build_subcsetoid_crr IR _ _ TL_compact_a).
Notation B := (Build_subcsetoid_crr IR _ _ TL_compact_b).
(* end hide *)

(* begin show *)
Let funct_i n Hf i Hi := [-C-] (fi n Hf i Hi A [/] _[//] nring_fac_ap_zero _ i) {*} (FId{-} [-C-]a) {^}i.
(* end show *)

(* begin hide *)
Let funct_i' n Hf i Hi := PartInt (fi n Hf i Hi) {*}
 [-C-] ([1][/] _[//]nring_fac_ap_zero IR i) {*} ( [-C-]b{-}FId) {^}i.

Lemma TL_a_i : forall n Hf i Hi, Dom (funct_i n Hf i Hi) a.
Proof.
 split; split; simpl in |- *; auto.
Qed.

Lemma TL_b_i : forall n Hf i Hi, Dom (funct_i n Hf i Hi) b.
Proof.
 split; split; simpl in |- *; auto.
Qed.

Lemma TL_x_i : forall x, I x -> forall n Hf i Hi, Dom (funct_i n Hf i Hi) x.
Proof.
 split; split; simpl in |- *; auto.
Qed.

Lemma TL_a_i' : forall n Hf i Hi, Dom (funct_i' n Hf i Hi) a.
Proof.
 split; split; simpl in |- *; auto.
Qed.

Lemma TL_b_i' : forall n Hf i Hi, Dom (funct_i' n Hf i Hi) b.
Proof.
 split; split; simpl in |- *; auto.
Qed.

Lemma TL_x_i' : forall x, I x -> forall n Hf i Hi, Dom (funct_i' n Hf i Hi) x.
Proof.
 split; split; simpl in |- *; auto.
Qed.

Lemma Taylor_lemma2 : forall n Hf, ext_fun_seq (funct_i n Hf).
Proof.
 red in |- *; intros n Hf i j H H0 H' x y H1 Hx Hy.
 simpl in |- *.
 apply mult_wd.
  apply div_wd.
   2: rewrite H; algebra.
  generalize H' Hx Hy; clear Hy Hx H'.
  rewrite <- H; intros.
  cut (forall Ha1 Ha2, PartInt (fi n Hf i H0) a Ha1 [=] PartInt (fi n Hf i H') a Ha2); intros.
   simpl in H2.
   apply H2.
  apply Feq_imp_eq with (Compact Hab).
   unfold Hab in |- *; apply Derivative_I_n_unique with i F; apply Taylor_lemma1.
  apply TL_compact_a.
 rewrite H.
 astepl ((x[+][--]a) [^]j); Step_final ((y[+][--]a) [^]j).
Qed.

Lemma Taylor_lemma2' : forall n Hf, ext_fun_seq' (funct_i n Hf).
Proof.
 repeat intro.
 repeat split.
Qed.

Lemma Taylor_lemma3 : forall n Hf, ext_fun_seq (funct_i' n Hf).
Proof.
 red in |- *; intros n Hf i j H H0 H' x y H1 Hx Hy.
 simpl in |- *.
 apply mult_wd.
  apply mult_wd.
   2: rewrite H; algebra.
  generalize H' Hx Hy; clear Hy Hx H'.
  rewrite <- H; intros.
  cut (forall Hx' Hy', PartInt (fi n Hf i H0) x Hx' [=] PartInt (fi n Hf i H') y Hy'); intros.
   simpl in H2.
   apply H2.
  cut (Dom (PartInt (fi n Hf i H')) x); [ intro H2 | apply dom_wd with y; algebra ].
  apply eq_transitive_unfolded with (Part _ _ H2).
   apply Feq_imp_eq with (Compact Hab).
    unfold Hab in |- *; apply Derivative_I_n_unique with i F; apply Taylor_lemma1.
   simpl in Hx.
   elim Hx; intros.
   inversion_clear a0; auto.
  algebra.
 rewrite H.
 astepl ((b[+][--]x) [^]j); Step_final ((b[+][--]y) [^]j).
Qed.

Lemma Taylor_lemma3' : forall n Hf, ext_fun_seq' (funct_i' n Hf).
Proof.
 intros n Hf i j H H0 H' x y H1 H2.
 elim H2; intros.
 simpl in a0, b0.
 clear b0; inversion_clear a0 as (X,X0).
 inversion_clear X; repeat split.
  astepr x; auto.
 astepl x; auto.
Qed.
(* end hide *)

(**
Adding the previous expressions up to a given bound [n] gives us the
Taylor sum of order [n].
*)

Definition Taylor_seq' n Hf := FSumx _ (funct_i n Hf).

(* begin hide *)
Let Taylor_seq'_aux n Hf := FSumx _ (funct_i' n Hf).

Lemma TL_lemma_a : forall n Hf, Dom (Taylor_seq' n Hf) a.
Proof.
 intros.
 repeat split.
 apply FSumx_pred'.
  repeat split.
 repeat split.
Qed.
(* end hide *)

(**
It is easy to show that [b] is in the domain of this series, which allows us to write down the Taylor remainder around [b].
*)

Lemma TL_lemma_b : forall n Hf, Dom (Taylor_seq' n Hf) b.
Proof.
 intros.
 repeat split.
 apply FSumx_pred'.
  repeat split.
 repeat split.
Qed.

(* begin hide *)
Lemma TL_lemma_a' : forall n Hf, Dom (Taylor_seq'_aux n Hf) a.
Proof.
 intros.
 split.
  apply FSumx_pred'.
   red in |- *; intros.
   simpl in X.
   inversion_clear X.
   inversion_clear X0.
   simpl in |- *.
   split; split; auto.
   apply compact_wd with x; auto.
  intros.
  apply TL_a_i'.
 apply TL_a_i'.
Qed.

Lemma TL_lemma_b' : forall n Hf, Dom (Taylor_seq'_aux n Hf) b.
Proof.
 intros.
 split.
  apply FSumx_pred'.
   red in |- *; intros.
   simpl in X.
   inversion_clear X.
   inversion_clear X0.
   simpl in |- *.
   split; split; auto.
   apply compact_wd with x; auto.
  intros.
  apply TL_b_i'.
 apply TL_b_i'.
Qed.
(* end hide *)

Definition Taylor_rem n Hf := F b Hb[-]Taylor_seq' n Hf b (TL_lemma_b n Hf).

(* begin hide *)
Let g n Hf Hab := [-C-] (F b Hb) {-}Taylor_seq'_aux n Hf{-}
 [-C-] (Taylor_rem n Hf) {*} (( [-C-]b{-}FId) {*} [-C-] ([1][/] (b[-]a) [//]Hab)).

Lemma Taylor_lemma4 : forall n Hf Hab Ha', g n Hf Hab a Ha' [=] [0].
Proof.
 unfold g in |- *; clear g; intros.
 cut (Dom ( [-C-] (F b Hb) {-}Taylor_seq'_aux n Hf{-} [-C-] (Taylor_rem n Hf)) a). intro H.
  apply eq_transitive_unfolded with (Part _ _ H).
   Opaque Taylor_seq'_aux Taylor_rem.
   simpl in |- *; rational.
  Transparent Taylor_rem.
  unfold Taylor_rem in |- *.
  apply eq_transitive_unfolded with (Part _ _ (TL_lemma_b n Hf) [-]Part _ _ (TL_lemma_a' n Hf)).
   Opaque Taylor_seq'.
   simpl in |- *; rational.
  Transparent Taylor_seq' Taylor_seq'_aux.
  unfold Taylor_seq', Taylor_seq'_aux in |- *.
  cut (Dom (FSum 0 n (FSumx_to_FSum _ (funct_i n Hf))) b). intro H0.
   cut (Dom (FSum 0 n (FSumx_to_FSum _ (funct_i' n Hf))) a). intro H1.
    apply eq_transitive_unfolded with (Part _ _ H0[-]Part _ _ H1).
     apply eq_symmetric_unfolded; apply cg_minus_wd; apply FSum_FSumx_to_FSum.
        apply Taylor_lemma2.
       apply Taylor_lemma2'.
      apply Taylor_lemma3.
     apply Taylor_lemma3'.
    eapply eq_transitive_unfolded.
     simpl in |- *.
     apply eq_symmetric_unfolded; apply Sum_minus_Sum.
    apply Sum_zero.
     auto with arith.
    intros.
    cut (forall Hb' Ha', FSumx_to_FSum (S n) (funct_i n Hf) i b Hb'[-]
      FSumx_to_FSum (S n) (funct_i' n Hf) i a Ha' [=] [0]); auto.
    unfold FSumx_to_FSum in |- *.
    elim le_lt_dec; intro; simpl in |- *.
     algebra.
    intros.
    set (w := fi n Hf i b0 (Build_subcsetoid_crr _ _ _ TL_compact_a) [*]
      ([1][/] _[//]nring_fac_ap_zero IR i) [*] (b[+][--]a) [^]i) in *.
    astepr (w[-]w); unfold w in |- *; simpl in |- *.
    repeat first [ apply cg_minus_wd | simple apply mult_wd ]; try apply csf_wd_unfolded; algebra.
     rational.
    simpl in |- *; algebra.
   simpl in |- *; intro i.
   Opaque funct_i'.
   unfold FSumx_to_FSum in |- *.
   elim le_lt_dec; intro; simpl in |- *.
    auto.
   apply TL_a_i'.
  Opaque funct_i.
  simpl in |- *; intro i.
  unfold FSumx_to_FSum in |- *.
  elim le_lt_dec; intro; simpl in |- *.
   auto.
  apply TL_b_i.
 split; split; split.
  apply FSumx_pred'.
   red in |- *; intros.
   inversion_clear X.
   inversion_clear X0.
   simpl in X.
   split; split; auto.
   simpl in |- *; apply compact_wd with x; auto.
  intros; apply TL_a_i'.
 apply TL_a_i'.
Qed.

Transparent funct_i funct_i'.

Lemma Taylor_lemma5 : forall n Hf Hab Hb', g n Hf Hab b Hb' [=] [0].
Proof.
 unfold g in |- *; intros.
 cut (Dom ( [-C-] (F b Hb) {-}Taylor_seq'_aux n Hf) b). intro H.
  apply eq_transitive_unfolded with (Part _ _ H).
   Opaque Taylor_seq'_aux.
   simpl in |- *; rational.
  Transparent Taylor_seq'_aux.
  unfold Taylor_seq'_aux in |- *.
  cut (Dom (FSum 0 n (FSumx_to_FSum _ (funct_i' n Hf))) b). intro H0.
   apply eq_transitive_unfolded with (F b Hb[-]Part _ _ H0).
    Opaque FSumx.
    apply eq_transitive_unfolded with (F b Hb[-]FSumx (S n) (funct_i' n Hf) b (ProjIR2 H)).
     simpl in |- *; rational.
    apply cg_minus_wd.
     algebra.
    apply eq_symmetric_unfolded; apply FSum_FSumx_to_FSum.
     apply Taylor_lemma3.
    apply Taylor_lemma3'.
   simpl in |- *.
   astepr (Part _ _ Hb[-]Part _ _ Hb); apply cg_minus_wd.
    algebra.
   eapply eq_transitive_unfolded.
    apply Sum_first.
   astepr (Part _ _ Hb[+][0]); apply bin_op_wd_unfolded.
    cut (forall H', FSumx_to_FSum (S n) (funct_i' n Hf) 0 b H' [=] Part _ _ Hb); auto.
    unfold FSumx_to_FSum in |- *.
    elim le_lt_dec; intro; simpl in |- *.
     exfalso; inversion a0.
    intros; simpl in |- *.
    rstepr (Part _ _ Hb[*][1][*][1]).
    apply mult_wdl.
    apply mult_wd.
     2: rational.
    apply eq_symmetric_unfolded.
    apply eq_transitive_unfolded with (PartInt (fi n Hf 0 b0) b TL_compact_b).
     2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
    apply Feq_imp_eq with (Compact Hab).
     apply (ProjT2 (Diffble_I_n_imp_deriv_n _ _ _ _ _
       (le_imp_Diffble_I _ _ _ _ _ (lt_n_Sm_le 0 n b0) _ Hf))).
    apply TL_compact_b.
   apply Sum_zero.
    auto with arith.
   intros.
   cut (forall H', FSumx_to_FSum (S n) (funct_i' n Hf) i b H' [=] [0]); auto.
   unfold FSumx_to_FSum in |- *.
   elim le_lt_dec; intro; simpl in |- *.
    algebra.
   intro.
   astepr (fi n Hf i b0 (Build_subcsetoid_crr IR _ b (ProjIR1 (ProjIR1 H'))) [*]
     ([1][/] _[//]nring_fac_ap_zero _ i) [*][0]).
   apply mult_wdr.
   astepl ((b[-]b) [^]i).
   Step_final (ZeroR[^]i).
  intro i.
  Opaque funct_i'.
  unfold FSumx_to_FSum in |- *.
  elim le_lt_dec; intro; simpl in |- *.
   auto.
  apply TL_b_i'.
 split.
  simpl in |- *; auto.
 simpl in |- *.
 apply TL_lemma_b'.
Qed.

Transparent funct_i' FSumx.

Let funct_aux n Hf i Hi := PartInt (fi (S n) Hf (S i) (lt_n_S _ _ Hi)) {*}
  [-C-] ([1][/] _[//]nring_fac_ap_zero IR i) {*} ( [-C-]b{-}FId) {^}i.

Lemma Taylor_lemma6 :  forall n Hf Hf' i Hi, Derivative_I Hab'
 (PartInt (fi n Hf i Hi)) (PartInt (fi (S n) Hf' (S i) (lt_n_S _ _ Hi))).
Proof.
 intros.
 cut (Derivative_I_n Hab' 1 (PartInt (fi n Hf i Hi))
   (PartInt (fi (S n) Hf' (S i) (lt_n_S i (S n) Hi)))).
  intro H.
  simpl in H.
  elim H; intros f' H1 H2.
  apply Derivative_I_wdr with (PartInt f'); assumption.
 cut (S i = 1 + i); [ intro | lia ].
 cut (1 + i < S (S n)); [ intro | lia ].
 apply Derivative_I_n_wdr with (PartInt (fi (S n) Hf' _ H0)).
  apply Derivative_I_n_unique with (S i) F.
   generalize H0; clear H0.
   rewrite <- H; intro.
   apply Taylor_lemma1.
  apply Taylor_lemma1.
 apply Derivative_I_n_wdl with (n_deriv_I _ _ _ _ _
   (le_imp_Diffble_I _ _ _ _ _ (lt_n_Sm_le i n Hi) _ Hf)).
  2: apply Derivative_I_n_wdr with (n_deriv_I _ _ _ _ _
    (le_imp_Diffble_I _ _ _ _ _ (lt_n_Sm_le _ _ H0) _ Hf')).
   3: apply n_deriv_plus.
  apply Derivative_I_n_unique with i F.
   apply n_deriv_lemma.
  apply Taylor_lemma1.
 apply Derivative_I_n_unique with (1 + i) F.
  apply n_deriv_lemma.
 apply Taylor_lemma1.
Qed.

Ltac Lazy_Included :=
  repeat first
   [ simple apply included_IR
   | simple apply included_FPlus
   | simple apply included_FInv
   | simple apply included_FMinus
   | simple apply included_FMult
   | simple apply included_FNth
   | simple apply included_refl ].

Ltac Lazy_Eq :=
  repeat first
   [ simple apply bin_op_wd_unfolded
   | simple apply un_op_wd_unfolded
   | simple apply cg_minus_wd
   | simple apply div_wd
   | simple apply csf_wd_unfolded ]; algebra.

Lemma Taylor_lemma7 : forall n Hf Hf' i (Hi : 0 < i) Hi', Derivative_I Hab'
 (funct_i' n Hf i Hi') (funct_aux n Hf' i Hi'{-}funct_aux n Hf' (pred i) (lt_5 i (S n) Hi')).
Proof.
 do 5 intro.
 rewrite (S_pred _ _ Hi).
 set (p := pred i) in *; clearbody p; clear Hi i.
 intros.
 cut (Derivative_I Hab' (PartInt (fi n Hf _ Hi'))
   (PartInt (fi (S n) Hf' (S (S p)) (lt_n_S _ _ Hi')))); [ intro | apply Taylor_lemma6 ].
 unfold funct_aux, funct_i' in |- *.
 New_Deriv.
  apply Feq_reflexive.
  Lazy_Included.
 apply eq_imp_Feq.
   Lazy_Included.
  Lazy_Included.
 intros x X0 Hx Hx'.
 simpl in Hx, Hx'; simpl in |- *.
 set (fiSp1 := fi n Hf (S p) Hi') in *.
 set (fiSp2 := fi (S n) Hf' (S p) (lt_n_S p (S n) (lt_5 (S p) (S n) Hi'))) in *.
 cut (forall x y : subset I, scs_elem _ _ x [=] scs_elem _ _ y -> fiSp1 x [=] fiSp2 y); intros.
  set (x1 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR1 (ProjIR1 Hx)))) in *.
  simpl in (value of x1); fold x1 in |- *.
  set (x2 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR1 (ProjIR2 Hx')))) in *.
  simpl in (value of x2); fold x2 in |- *.
  set (x3 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR1 (ProjIR1 (ProjIR2 Hx))))) in *.
  simpl in (value of x3); fold x3 in |- *.
  set (x4 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR1 (ProjIR1 Hx')))) in *.
  simpl in (value of x4); fold x4 in |- *.
  set (x5 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR2 (ProjIR1 (ProjIR2 Hx))))) in *.
  simpl in (value of x5); fold x5 in |- *.
  set (fiSSp := fi (S n) Hf' (S (S p)) (lt_n_S (S p) (S n) Hi')) in *.
  set (pp := [1][/] nring (fact p + p * fact p) [//]nring_fac_ap_zero IR (S p)) in *.
  set (bxp := nexp _ p (b[-]x)) in *.
  set (a1 := fiSp1 x1) in *; set (a5 := fiSSp x5) in *;
    simpl in (value of a1), (value of a5); fold a1 a5 in |- *.
  rstepl (a5[*]pp[*] (bxp[*] (b[-]x)) [-]a1[*] ((nring p[+][1]) [*]pp) [*]bxp).
  unfold a1, a5 in |- *; clear a1 a5.
  Lazy_Eq.
   unfold x4, x5 in |- *; algebra.
   simpl in |- *; algebra.
  unfold pp in |- *.
  rstepr (nring (S p) [*] ([1][/] _[//] mult_resp_ap_zero _ _ _ (nring_fac_ap_zero _ p)
    (pos_ap_zero _ _ (pos_nring_S IR p)))); simpl in |- *.
  apply mult_wdr; apply div_wd.
   algebra.
  clear X H bxp pp x5 x4 x3 x2 x1 fiSSp fiSp1 fiSp2 Hx.
  cut (fact p + p * fact p = fact p * S p).
   intro; rewrite H.
   eapply eq_transitive_unfolded.
    apply nring_comm_mult.
   algebra.
  transitivity (S p * fact p); auto with arith.
 unfold fiSp1, fiSp2 in |- *.
 apply eq_transitive_unfolded with (PartInt (fi n Hf (S p) Hi') (scs_elem _ _ x0) (scs_prf _ _ x0)).
  2: apply eq_transitive_unfolded with (PartInt (fi (S n) Hf' (S p) (lt_n_S _ _ (lt_5 _ _ Hi')))
    (scs_elem _ _ x0) (scs_prf _ _ x0)).
   simpl in |- *; apply csf_wd_unfolded.
   case x0; simpl in |- *; algebra.
  apply Feq_imp_eq with (Compact Hab).
   unfold Hab in |- *; apply Derivative_I_n_unique with (S p) F; apply Taylor_lemma1.
  apply scs_prf.
 simpl in |- *; apply csf_wd_unfolded.
 generalize H; case x0; case y; auto.
Qed.

Lemma Taylor_lemma8 : forall n Hf Hf' Hi,
  Derivative_I Hab' (funct_i' n Hf 0 Hi) (funct_aux n Hf' 0 Hi).
Proof.
 intros.
 cut (Derivative_I Hab' (PartInt (fi n Hf _ Hi)) (PartInt (fi (S n) Hf' 1 (lt_n_S _ _ Hi))));
   [ intro | apply Taylor_lemma6 ].
 unfold funct_aux, funct_i' in |- *; New_Deriv.
  apply Feq_reflexive; Lazy_Included.
 apply eq_imp_Feq.
   Lazy_Included.
  Lazy_Included.
 intros; simpl in |- *.
 apply eq_transitive_unfolded with (fi (S n) Hf' 1 (lt_n_S _ _ Hi)
   (Build_subcsetoid_crr _ _ _ (ProjIR1 (ProjIR2 (ProjIR1 (ProjIR2 Hx))))) [*]
     ([1][/] _[//]nring_fac_ap_zero IR 0) [*][1]).
  simpl in |- *; rational.
 Lazy_Eq; simpl in |- *; algebra.
Qed.

Lemma Taylor_lemma9 : forall n Hf Hf',
  Derivative_I Hab' (Taylor_seq'_aux n Hf) (funct_aux n Hf' n (lt_n_Sn n)).
Proof.
 intro; induction  n as [| n Hrecn].
  intros.
  unfold Taylor_seq'_aux in |- *; simpl in |- *.
  apply Derivative_I_wdl with (funct_i' 0 Hf 0 (lt_n_Sn 0)).
   apply eq_imp_Feq.
     split; split; simpl in |- *; auto.
    split; split; split; simpl in |- *; auto.
   intros; simpl in |- *.
   apply eq_transitive_unfolded with ([0][+] fi 0 Hf 0 (lt_n_Sn 0)
     (Build_subcsetoid_crr _ _ _ (ProjIR1 (ProjIR1 Hx))) [*]
       ([1][/] [0][+][1][//]nring_fac_ap_zero IR 0) [*][1]).
    simpl in |- *; rational.
   Lazy_Eq; simpl in |- *; algebra.
  apply Taylor_lemma8; assumption.
 cut {p : nat | S n = p}; [ intro H | exists (S n); auto ].
 elim H; intros p H0.
 rewrite H0.
 intros.
 unfold Taylor_seq'_aux in |- *; simpl in |- *.
 generalize Hf Hf'; clear Hf Hf'.
 rewrite <- H0; intros.
 cut (Diffble_I_n Hab' n F); [ intro H1 | apply le_imp_Diffble_I with (S n); [ lia | assumption ] ].
 apply Derivative_I_wdl with (Taylor_seq'_aux n H1{+}funct_i' _ Hf _ (lt_n_Sn (S n))).
  unfold Taylor_seq'_aux in |- *.
  apply eq_imp_Feq.
    repeat (split; auto). try rename X into H2.
    apply FSumx_pred'.
     red in |- *; intros. try rename X into H6.
     exact (Taylor_lemma3' _ _ _ _ H3 _ _ _ _ H4 H6).
    intros; simpl in |- *; repeat (split; auto).
   repeat (split; auto). try rename X into H2.
   apply FSumx_pred'.
    red in |- *; intros. try rename X into H6.
    exact (Taylor_lemma3' _ _ _ _ H3 _ _ _ _ H4 H6).
   intros; simpl in |- *; repeat (split; auto).
  intros x H2 Hx Hx'; simpl in |- *.
  repeat first [ simple apply mult_wd | simple apply bin_op_wd_unfolded | simple apply csf_wd_unfolded
    | simple apply eq_reflexive_unfolded ]; simpl in |- *.
    3: algebra.
   apply Feq_imp_eq with (Compact Hab).
    2: assumption.
   apply FSumx_wd'.
   intros; apply eq_imp_Feq.
     repeat (split; auto).
    repeat (split; auto).
   intros x0 H4; intros; simpl in |- *.
   repeat apply mult_wdl.
   apply eq_transitive_unfolded with (PartInt (fi n H1 i (lt_S _ _ H3)) x0 H4).
    simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
   apply eq_transitive_unfolded with (PartInt (fi (S n) Hf i (lt_S _ _ (lt_S _ _ H'))) x0 H4).
    2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
   apply Feq_imp_eq with (Compact Hab).
    unfold Hab in |- *; apply Derivative_I_n_unique with i F; apply Taylor_lemma1.
   auto.
  apply eq_transitive_unfolded with (PartInt (fi n H1 n (lt_n_Sn _)) x H2).
   2: apply eq_transitive_unfolded with (PartInt (fi (S n) Hf n (lt_S _ _ (lt_n_Sn _))) x H2).
    simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
   2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
  apply Feq_imp_eq with (Compact Hab).
   unfold Hab in |- *; apply Derivative_I_n_unique with n F; apply Taylor_lemma1.
  auto.
 apply Derivative_I_wdr with (funct_aux (S n) Hf' (pred (S n)) (lt_5 _ _ (lt_n_Sn (S n))) {+}
   (funct_aux _ Hf' _ (lt_n_Sn (S n)) {-}
     funct_aux (S n) Hf' (pred (S n)) (lt_5 _ _ (lt_n_Sn (S n))))).
  Opaque funct_aux.
  FEQ.
   Transparent funct_aux.
   repeat (split; auto).
  repeat (split; auto).
 apply Derivative_I_plus.
  apply Derivative_I_wdr with (funct_aux n Hf n (lt_n_Sn n)).
   apply eq_imp_Feq.
     repeat (split; auto).
    repeat (split; auto).
   intros x H2 Hx Hx'; simpl in |- *.
   repeat apply mult_wdl.
   apply eq_transitive_unfolded with (PartInt (fi (S n) Hf (S n) (lt_n_S _ _ (lt_n_Sn _))) x H2).
    2: apply eq_transitive_unfolded with (PartInt
      (fi (S (S n)) Hf' (S n) (lt_n_S _ _ (lt_5 _ _ (lt_n_Sn (S n))))) x H2).
     simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
    2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
   apply Feq_imp_eq with (Compact Hab).
    unfold Hab in |- *; apply Derivative_I_n_unique with (S n) F; apply Taylor_lemma1.
   auto.
  apply Hrecn.
 apply Taylor_lemma7.
 lia.
Qed.

Let g' n Hf Hf' Hab :=
 [-C-] (Taylor_rem n Hf[/] (b[-]a) [//]Hab) {-}funct_aux n Hf' n (lt_n_Sn n).

Lemma Taylor_lemma10 : forall n Hf Hf' Hab (H : a [#] b),
 Derivative_I Hab' (g n Hf Hab) (g' n Hf Hf' Hab).
Proof.
 unfold g, g' in |- *.
 intros.
 cut (Derivative_I Hab' (Taylor_seq'_aux n Hf) (funct_aux n Hf' n (lt_n_Sn n)));
   [ intro | apply Taylor_lemma9; assumption ].
 Opaque Taylor_rem funct_aux.
 New_Deriv.
  apply Feq_reflexive; Lazy_Included.
  Included.
 apply eq_imp_Feq.
   Lazy_Included.
   Included.
  Lazy_Included.
  Included.
 intros; simpl in |- *; rational.
Qed.

Transparent Taylor_rem funct_aux.
(* end hide *)

(**
Now Taylor's theorem.

%\begin{convention}% Let [e] be a positive real number.
%\end{convention}%
*)

Variable e : IR.
Hypothesis He : [0] [<] e.

(* begin hide *)
Lemma Taylor_lemma11 : forall n Hf Hf' H, {c : IR | I c |
  forall Hc, AbsIR (g' n Hf Hf' H c Hc) [<=] e[*]AbsIR ([1][/] (b[-]a) [//]H)}.
Proof.
 intros.
 cut (Dom (g n Hf H) (Min a b)). intro H0.
  cut (Dom (g n Hf H) (Max a b)). intro H1.
   cut (Dom (g n Hf H) a). intro H2.
    cut (Dom (g n Hf H) b). intro H3.
     unfold I, Hab in |- *; apply Rolle with (g n Hf H) H0 H1.
       apply Taylor_lemma10; auto.
      elim (ap_imp_less _ _ _ Hap); intro.
       apply eq_transitive_unfolded with ZeroR.
        eapply eq_transitive_unfolded.
         2: apply Taylor_lemma4 with (Ha' := H2).
        apply pfwdef; apply leEq_imp_Min_is_lft; apply less_leEq; auto.
       apply eq_symmetric_unfolded.
       eapply eq_transitive_unfolded.
        2: apply Taylor_lemma5 with (Hb' := H3).
       apply pfwdef; apply leEq_imp_Max_is_rht; apply less_leEq; auto.
      apply eq_transitive_unfolded with ZeroR.
       eapply eq_transitive_unfolded.
        2: apply Taylor_lemma5 with (Hb' := H3).
       apply pfwdef; eapply eq_transitive_unfolded.
        apply Min_comm.
       apply leEq_imp_Min_is_lft; apply less_leEq; auto.
      apply eq_symmetric_unfolded.
      eapply eq_transitive_unfolded.
       2: apply Taylor_lemma4 with (Ha' := H2).
      apply pfwdef; eapply eq_transitive_unfolded.
       apply Max_comm.
      apply leEq_imp_Max_is_rht; apply less_leEq; auto.
     astepl ([0][*]AbsIR ([1][/] _[//]H)).
     apply mult_resp_less.
      assumption.
     apply AbsIR_pos.
     apply div_resp_ap_zero_rev.
     apply one_ap_zero.
    split; split; split; simpl in |- *; auto.
      3: split; split.
     2: split; split; auto; apply TL_compact_b.
    apply FSumx_pred'; intros.
     2: apply TL_b_i'.
    red in |- *; intros. try rename X into H6.
    exact (Taylor_lemma3' _ _ _ _ H3 _ _ _ _ H4 H6).
   split; split; split; simpl in |- *; auto.
     3: split; split.
    2: split; split; auto; apply TL_compact_a.
   apply FSumx_pred'; intros.
    2: apply TL_a_i'.
   red in |- *; intros. try rename X into H5.
   exact (Taylor_lemma3' _ _ _ _ H2 _ _ _ _ H3 H5).
  split; split; split; simpl in |- *; auto.
    3: split; split.
   2: split; split; auto; apply compact_inc_rht.
  apply FSumx_pred'; intros.
   2: apply TL_x_i'.
   red in |- *; intros. try rename X into H4.
   exact (Taylor_lemma3' _ _ _ _ H1 _ _ _ _ H2 H4).
  unfold I in |- *; apply compact_inc_rht.
 split; split; split; simpl in |- *; auto.
   3: split; split.
  2: split; split; auto; apply compact_inc_lft.
 apply FSumx_pred'; intros.
  2: apply TL_x_i'.
  red in |- *; intros. try rename X into H3.
  exact (Taylor_lemma3' _ _ _ _ H0 _ _ _ _ H1 H3).
 unfold I in |- *; apply compact_inc_lft.
Qed.
(* end hide *)

(* begin show *)
Let deriv_Sn' n Hf' :=
 n_deriv_I _ _ Hab' (S n) F Hf'{*} [-C-] ([1][/] _[//]nring_fac_ap_zero _ n) {*} ( [-C-]b{-}FId) {^}n.
(* end show *)

(* begin hide *)
Lemma TLH : b[-]a [#] [0].
Proof.
 rstepl ( [--] (a[-]b)).
 apply inv_resp_ap_zero.
 apply minus_ap_zero; auto.
Qed.
(* end hide *)

Lemma Taylor_lemma : forall n Hf Hf', {c : IR | I c |
 forall Hc, AbsIR (Taylor_rem n Hf[-]deriv_Sn' n Hf' c Hc[*] (b[-]a)) [<=] e}.
Proof.
 intros.
 assert (H := TLH).
 cut {c : IR | I c | forall Hc, AbsIR (g' n Hf Hf' H c Hc) [<=] e[*]AbsIR ([1][/] _[//]H)};
   [ intro H0 | apply Taylor_lemma11; assumption ].
 elim H0; intros c Hc' Hc; clear H0; exists c.
  auto.
 intro.
 cut (Dom (funct_aux n Hf' n (lt_n_Sn n)) c). intro H0.
  apply leEq_wdl with (AbsIR (((Taylor_rem n Hf[/] _[//]H) [-]Part _ _ H0) [*] (b[-]a))).
   eapply leEq_wdl.
    2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
   apply shift_mult_leEq with (AbsIR_resp_ap_zero _ H).
    apply AbsIR_pos; apply H.
   rstepr (e[*] ([1][/] _[//]AbsIR_resp_ap_zero _ H)).
   apply leEq_wdr with (e[*]AbsIR ([1][/] _[//]H)).
    Opaque funct_aux.
    cut (Dom (g' n Hf Hf' H) c). intro H1.
     eapply leEq_wdl.
      apply (Hc H1).
     apply AbsIR_wd; unfold g' in |- *.
     Opaque Taylor_rem.
     simpl in |- *; rational.
    repeat (split; auto).
   apply mult_wdr.
   apply AbsIR_recip.
  apply eq_symmetric_unfolded.
  apply eq_transitive_unfolded
    with (AbsIR ((Taylor_rem n Hf[/] _[//]H) [-]Part _ _ H0) [*]AbsIR (b[-]a)).
   eapply eq_transitive_unfolded.
    2: apply AbsIR_resp_mult.
   apply AbsIR_wd.
   rstepr (Taylor_rem n Hf[-]Part _ _ H0[*] (b[-]a)).
   apply cg_minus_wd.
    algebra.
   apply mult_wdl.
   Transparent Taylor_rem funct_aux.
   unfold deriv_Sn', funct_aux in |- *.
   cut (Dom (n_deriv_I _ _ Hab' (S n) F Hf') c). intro H1.
    simpl in |- *; apply eq_transitive_unfolded with (n_deriv_I _ _ Hab' (S n) F Hf' c H1[*]
      ([1][/] _[//]nring_fac_ap_zero _ n) [*] (b[-]c) [^]n).
     repeat apply mult_wdl; apply pfwdef; algebra.
    repeat apply mult_wdl.
    apply eq_transitive_unfolded with (PartInt (fi (S n) Hf' (S n) (lt_n_S _ _ (lt_n_Sn _))) c Hc').
     2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra.
    apply Feq_imp_eq with (Compact Hab).
     unfold Hab in |- *; apply Derivative_I_n_unique with (S n) F.
      apply n_deriv_lemma.
     apply Taylor_lemma1.
    auto.
   apply n_deriv_inc; auto.
  apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
 repeat (split; auto).
Qed.

End Taylor_Defs.


(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md descbrides the contents of each file and
   provides instructions to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

Require Import List.

Require Import misc_list.
Require Import cfg.
Require Import cfl.

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

Import ListNotations.

(* --------------------------------------------------------------------- *)
(* UNION - DEFINITIONS                                                   *)
(* --------------------------------------------------------------------- *)

Section Union.

Variables non_terminal_1 non_terminal_2 terminal: Type.

Inductive g_uni_nt: Type:=
| Start_uni
| Transf1_uni_nt: non_terminal_1 -> g_uni_nt
| Transf2_uni_nt: non_terminal_2 -> g_uni_nt.

Notation sf1:= (list (non_terminal_1 + terminal)).
Notation sf2:= (list (non_terminal_2 + terminal)).
Notation sfu:= (list (g_uni_nt + terminal)).
Notation nlist:= (list g_uni_nt).
Notation tlist:= (list terminal).

Definition g_uni_sf_lift1 (c: non_terminal_1 + terminal): g_uni_nt + terminal:=
  match c with
  | inl nt => inl (Transf1_uni_nt nt)
  | inr t  => inr t
  end.

Definition g_uni_sf_lift2 (c: non_terminal_2 + terminal): g_uni_nt + terminal:=
  match c with
  | inl nt => inl (Transf2_uni_nt nt)
  | inr t  => inr t
  end.

Inductive g_uni_rules (g1: cfg non_terminal_1 terminal) (g2: cfg non_terminal_2 terminal): g_uni_nt -> sfu -> Prop :=
| Start1_uni: g_uni_rules g1 g2 Start_uni [inl (Transf1_uni_nt (start_symbol g1))]
| Start2_uni: g_uni_rules g1 g2 Start_uni [inl (Transf2_uni_nt (start_symbol g2))]
| Lift1_uni: forall nt: non_terminal_1,
             forall s: list (non_terminal_1 + terminal),
             rules g1 nt s ->
             g_uni_rules g1 g2 (Transf1_uni_nt nt) (map g_uni_sf_lift1 s)
| Lift2_uni: forall nt: non_terminal_2,
             forall s: list (non_terminal_2 + terminal),
             rules g2 nt s ->
             g_uni_rules g1 g2 (Transf2_uni_nt nt) (map g_uni_sf_lift2 s).

Lemma g_uni_finite:
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
exists n: nat,
exists ntl: list g_uni_nt,
exists tl: tlist,
In Start_uni ntl /\
forall left: g_uni_nt,
forall right: sfu,
g_uni_rules g1 g2 left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: g_uni_nt, In (inl s) right -> In s ntl) /\
(forall s: terminal, In (inr s) right -> In s tl).
Proof.
intros g1 g2.
destruct (rules_finite g1) as [n1 [ntl1 [tl1 H1]]].
destruct (rules_finite g2) as [n2 [ntl2 [tl2 H2]]].
exists (S (max n1 n2)), (Start_uni :: (map Transf1_uni_nt ntl1) ++ (map Transf2_uni_nt ntl2)), (tl1 ++ tl2).
split.
- simpl.
  left.
  reflexivity.
- split.
  + inversion H.
    * simpl.
      omega.
    * simpl.
      omega.
    * destruct H1 as [_ H1].
      subst.
      specialize (H1 nt s H0).
      destruct H1 as [H1 _].
      rewrite map_length.
      assert (H3: n1 >= n2 \/ n1 <= n2) by omega.
      {
      destruct H3 as [H3 | H3].
      - apply max_l in H3.
        rewrite H3.
        omega.
      - assert (H3':= H3).
        apply max_r in H3.
        rewrite H3.
        omega.
      }
    * destruct H2 as [_ H2].
      subst.
      specialize (H2 nt s H0).
      destruct H2 as [H2 _].
      rewrite map_length.
      assert (H3: n1 >= n2 \/ n1 <= n2) by omega.
      {
      destruct H3 as [H3 | H3].
      - assert (H3':= H3).
        apply max_l in H3.
        rewrite H3.
        omega.
      - apply max_r in H3.
        rewrite H3.
        omega.
      }
  + split.
    * {
      inversion H.
      - simpl.
        left.
        reflexivity.
      - simpl.
        left.
        reflexivity.
      - simpl.
        right.
        apply in_or_app.
        left.
        destruct H1 as [_ H1].
        specialize (H1 nt s H0).
        destruct H1 as [_ [H5 [_ _]]].
        apply in_split in H5.
        destruct H5 as [l1 [l2 H5]].
        rewrite H5.
        rewrite map_app.
        apply in_or_app.
        right.
        simpl.
        left.
        reflexivity.
      - simpl.
        right.
        apply in_or_app.
        right.
        destruct H2 as [_ H2].
        specialize (H2 nt s H0).
        destruct H2 as [_ [H5 [_ _]]].
        apply in_split in H5.
        destruct H5 as [l1 [l2 H5]].
        rewrite H5.
        rewrite map_app.
        apply in_or_app.
        right.
        simpl.
        left.
        reflexivity.
      }
    * {
      split.
      - inversion H.
        + subst.
          intros s H4.
          simpl in H4.
          destruct H4 as [H4 | H4].
          * inversion H4.
            simpl.
            right.
            apply in_or_app.
            left.
            destruct H1 as [H1 _].
            apply in_split in H1.
            destruct H1 as [l1 [l2 H1]].
            rewrite H1.
            rewrite map_app.
            apply in_or_app.
            right.
            simpl.
            left.
            reflexivity.
          * contradiction.
        + subst.
          intros s H4.
          simpl in H4.
          destruct H4 as [H4 | H4].
          * inversion H4.
            simpl.
            right.
            apply in_or_app.
            right.
            destruct H2 as [H2 _].
            apply in_split in H2.
            destruct H2 as [l1 [l2 H2]].
            rewrite H2.
            rewrite map_app.
            apply in_or_app.
            right.
            simpl.
            left.
            reflexivity.
          * contradiction.
        + subst.
          intros s0 H4.
          destruct H1 as [_ H1].
          specialize (H1 nt s H0).
          destruct H1 as [_ [_ [H5 _]]].
          simpl.
          right.
          apply in_or_app.
          left.
          destruct s0.
          * apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inl Start_uni :: l2) with ([inl Start_uni] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            {
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s0.
              + simpl in H3.
                inversion H3.
              + simpl in H3.
                inversion H3.
            }
          * assert (H6: In (inl n) s).
              {
              apply in_split in H4.
              destruct H4 as [l1 [l2 H4]].
              symmetry in H4.
              apply map_expand in H4.
              destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
              change (inl (Transf1_uni_nt n) :: l2) with ([inl (Transf1_uni_nt n)] ++ l2) in H4'''.
              symmetry in H4'''.
              apply map_expand in H4'''.
              destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
              destruct s1'0.
              - inversion H5''.
              - inversion H5''.
                destruct s0.
                + simpl in H3.
                  inversion H3.
                  subst.
                  apply in_or_app.
                  right.
                  simpl.
                  left.
                  reflexivity.
                + simpl in H3.
                  inversion H3.
              }
            specialize (H5 n H6).
            apply in_map.
            exact H5.
          * apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inl (Transf2_uni_nt n) :: l2) with ([inl (Transf2_uni_nt n)] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            {
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s0.
              + simpl in H3.
                inversion H3.
              + simpl in H3.
                inversion H3.
            }
        + subst.
          intros s0 H4.
          destruct H2 as [_ H2].
          specialize (H2 nt s H0).
          destruct H2 as [_ [_ [H5 _]]].
          simpl.
          right.
          apply in_or_app.
          right.
          destruct s0.
          * apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inl Start_uni :: l2) with ([inl Start_uni] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            {
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s0.
              + simpl in H3.
                inversion H3.
              + simpl in H3.
                inversion H3.
            }
          * apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inl (Transf1_uni_nt n) :: l2) with ([inl (Transf1_uni_nt n)] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            {
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s0.
              + simpl in H3.
                inversion H3.
              + simpl in H3.
                inversion H3.
            }
          * assert (H6: In (inl n) s).
              {
              apply in_split in H4.
              destruct H4 as [l1 [l2 H4]].
              symmetry in H4.
              apply map_expand in H4.
              destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
              change (inl (Transf2_uni_nt n) :: l2) with ([inl (Transf2_uni_nt n)] ++ l2) in H4'''.
              symmetry in H4'''.
              apply map_expand in H4'''.
              destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
              destruct s1'0.
              - inversion H5''.
              - inversion H5''.
                destruct s0.
                + simpl in H3.
                  inversion H3.
                  subst.
                  apply in_or_app.
                  right.
                  simpl.
                  left.
                  reflexivity.
                + simpl in H3.
                  inversion H3.
              }
            specialize (H5 n H6).
            apply in_map.
            exact H5.
      - inversion H.
        + subst.
          intros s H4.
          simpl in H4.
          destruct H4 as [H4 | H4].
          * inversion H4.
          * contradiction.
        + subst.
          intros s H4.
          simpl in H4.
          destruct H4 as [H4 | H4].
          * inversion H4.
          * contradiction.
        + subst.
          intros s0 H4.
          destruct H1 as [_ H1].
          specialize (H1 nt s H0).
          destruct H1 as [_ [_ [_ H5]]].
          assert (H6: In (inr s0) s).
            {
            apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inr s0 :: l2) with ([inr s0] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s1.
              + simpl in H3.
                inversion H3.
              + simpl in H3.
                inversion H3.
                subst.
                apply in_or_app.
                right.
                simpl.
                left.
                reflexivity.
            }
          specialize (H5 s0 H6).
          apply in_or_app.
          left.
          exact H5.
        + subst.
          intros s0 H4.
          destruct H2 as [_ H2].
          specialize (H2 nt s H0).
          destruct H2 as [_ [_ [_ H5]]].
          assert (H6: In (inr s0) s).
            {
            apply in_split in H4.
            destruct H4 as [l1 [l2 H4]].
            symmetry in H4.
            apply map_expand in H4.
            destruct H4 as [s1' [s2' [H4' [H4'' H4''']]]].
            change (inr s0 :: l2) with ([inr s0] ++ l2) in H4'''.
            symmetry in H4'''.
            apply map_expand in H4'''.
            destruct H4''' as [s1'0 [s2'0 [H5' [H5'' H5''']]]].
            destruct s1'0.
            - inversion H5''.
            - simpl in H5''.
              inversion H5''.
              destruct s1.
              + simpl in H3.
                inversion H3.
              + simpl in H3.
                inversion H3.
                subst.
                apply in_or_app.
                right.
                simpl.
                left.
                reflexivity.
            }
          specialize (H5 s0 H6).
          apply in_or_app.
          right.
          exact H5.
      }
Qed.

Definition g_uni (g1: cfg non_terminal_1 terminal) (g2: cfg non_terminal_2 terminal): (cfg g_uni_nt terminal):= {|
start_symbol:= Start_uni;
rules:= g_uni_rules g1 g2;
rules_finite:= g_uni_finite g1 g2
|}.

(* --------------------------------------------------------------------- *)
(* UNION - LEMMAS                                                        *)
(* --------------------------------------------------------------------- *)

Lemma derives_add_uni_left:
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
forall s s': sf1,
derives g1 s s' ->
derives (g_uni g1 g2)
        (map g_uni_sf_lift1 s)
        (map g_uni_sf_lift1 s').
Proof.
intros g1 g2 s s' H.
induction H as [|x y z left right H1 H2 H3].
- apply derives_refl.
- rewrite map_app.
  rewrite map_app.
  rewrite map_app in H2.
  simpl in H2.
  apply derives_step with (left:=(Transf1_uni_nt left)).
  exact H2.
  simpl.
  apply Lift1_uni.
  exact H3.
Qed.

Lemma derives_add_uni_right :
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
forall s s': sf2,
derives g2 s s' ->
derives (g_uni g1 g2)
        (map g_uni_sf_lift2 s)
        (map g_uni_sf_lift2 s').
Proof.
intros g1 g2 s s' H.
induction H as [|x y z left right H1 H2 H3].
- apply derives_refl.
- rewrite map_app.
  rewrite map_app.
  rewrite map_app in H2.
  simpl in H2.
  apply derives_step with (left:=(Transf2_uni_nt left)).
  exact H2.
  simpl.
  apply Lift2_uni.
  exact H3.
Qed.

Theorem g_uni_correct_left:
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
forall s: sf1,
generates g1 s ->
generates (g_uni g1 g2) (map g_uni_sf_lift1 s).
Proof.
unfold generates.
intros g1 g2 s H.
apply derives_trans with (s2:= map g_uni_sf_lift1 [(inl (start_symbol g1))]).
- simpl.
  match goal with
  | |- derives _ ?s1 ?s2 =>
       change s1 with ([] ++ s1)%list;
       change s2 with ([] ++ s2 ++ [])%list
  end.
  apply derives_step with (left:= Start_uni).
  + apply derives_refl.
  + simpl.
    apply Start1_uni.
- apply derives_add_uni_left.
  exact H.
Qed.

Theorem g_uni_correct_right:
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
forall s: sf2,
generates g2 s -> generates (g_uni g1 g2) (map g_uni_sf_lift2 s).
Proof.
unfold generates.
intros g1 g2 s H.
apply derives_trans with (s2:= map g_uni_sf_lift2 [(inl (start_symbol g2))]).
- simpl.
  match goal with
  | |- derives _ ?s1 ?s2 =>
       change s1 with ([] ++ s1)%list;
       change s2 with ([] ++ s2 ++ [])%list
  end.
  apply derives_step with (left:= Start_uni).
  + apply derives_refl.
  + simpl.
    apply Start2_uni.
- apply derives_add_uni_right.
  exact H.
Qed.

Theorem g_uni_correct:
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
forall s1: sf1,
forall s2: sf2,
(generates g1 s1 -> generates (g_uni g1 g2) (map g_uni_sf_lift1 s1)) /\
(generates g2 s2 -> generates (g_uni g1 g2) (map g_uni_sf_lift2 s2)).
Proof.
split.
- apply g_uni_correct_left.
- apply g_uni_correct_right.
Qed.

Theorem g_uni_correct_inv:
forall g1: cfg non_terminal_1 terminal,
forall g2: cfg non_terminal_2 terminal,
forall s: sfu,
generates (g_uni g1 g2) s ->
(s=[inl (start_symbol (g_uni g1 g2))]) \/
(exists s1: sf1,
(s=(map g_uni_sf_lift1 s1) /\ generates g1 s1)) \/
(exists s2: sf2,
(s=(map g_uni_sf_lift2 s2) /\ generates g2 s2)).
Proof.
unfold generates.
intros g1 g2 s.
remember [inl (start_symbol (g_uni g1 g2))] as init.
intro H.
induction H.
  (* Base case *)
- left. reflexivity.
- (* Induction hypothesis *)
  subst.
  specialize (IHderives eq_refl).
  destruct IHderives.
  + (* IHderives, first case *)
    destruct s2.
    * (* First case, left = Start_uni *)
      simpl in H1. inversion H1. subst. {
      inversion H0. subst. clear H1.
      - (* First case, right = start_symbol g1 *)
        simpl in *.
        right.
        left.
        exists [inl (start_symbol g1)].
        split.
        + simpl. reflexivity.
        + apply derives_refl.
      - (* Second case, right = start_symbol g2 *)
        simpl in *.
        right.
        right.
        exists [inl (start_symbol g2)].
        split.
        + simpl. reflexivity.
        + apply derives_refl. }
    * (* Second case, left = non_terminal (g_uni g1 g2 *)
      simpl in H1.
      inversion H1. {
      destruct s2.
      - simpl in H4. inversion H4.
      - inversion H4. }
  + (* IHderives, second case *)
    destruct H1.
    * (* H1, first case: comes from g1 *)
      destruct H1 as [x [H1 H2]].
      {
      inversion H0.
      - (* First rule: Start1_uni *)
        (* Contradiction, x cannot contain Start_uni *)
        simpl in *. subst.
        destruct s2.
        + simpl in H1.
          destruct x.
          * inversion H1.
          * simpl in H1.
            inversion H1. {
            destruct s.
            - inversion H4.
            - inversion H4. }
        + simpl in *.
          assert (IN: In (inl Start_uni) (map g_uni_sf_lift1 x)).
            {
            rewrite <- H1.
            simpl.
            right.
            apply in_app_iff.
            right.
            simpl.
            left.
            reflexivity.
            }
          rewrite in_map_iff in IN.
          destruct IN.
          destruct H3.
          destruct x0.
          * simpl in H3. inversion H3.
          * simpl in H3. inversion H3.
      - (* Second rule: Start2_uni *)
        (* Contradiction, x cannot contain Start_uni *)
        simpl in *. subst.
        destruct s2.
        + simpl in H1.
          destruct x.
          * inversion H1.
          * simpl in H1. inversion H1. {
            destruct s.
            - inversion H4.
            - inversion H4. }
        + simpl in *.
          assert (IN: In (inl Start_uni) (map g_uni_sf_lift1 x)).
            {
            rewrite <- H1.
            simpl.
            right.
            apply in_app_iff.
            right.
            simpl.
            left.
            reflexivity.
            }
          rewrite in_map_iff in IN.
          destruct IN.
          destruct H3.
          destruct x0.
          * simpl in H3. inversion H3.
          * simpl in H3. inversion H3.
      - (* Third rule: Lift1_uni *)
        (* Should be true *)
        right.
        left.
        apply map_expand in H1.
        destruct H1 as [s1' [s2'[H6 [H7 H8]]]].
        replace (inl left::s3) with ([inl left]++s3) in H8.
        + symmetry in H8.
          apply map_expand in H8.
          destruct H8 as [m [n [H9 [H10 H11]]]].
          exists (s1'++s++n).
          split.
          * subst.
            repeat rewrite map_app.
            reflexivity.
          * subst.
            {
            destruct m.
            - inversion H10.
            - simpl in H10.
              inversion H10.
              destruct s0.
              + inversion H4.
                subst.
                apply map_eq_nil in H5.
                subst.
                apply derives_step with (right:=s) in H2.
                exact H2.
                exact H3.
              + inversion H4.
            }
        + simpl.
          reflexivity.
      - (* Forth rule: Lift2_uni *)
        (* Should be false *)
        simpl in *.
        subst.
        assert (IN: In (inl (Transf2_uni_nt nt)) (map g_uni_sf_lift1 x)).
          {
          rewrite <- H1.
          rewrite in_app_iff.
          right.
          simpl.
          left.
          reflexivity.
          }
        rewrite in_map_iff in IN.
        destruct IN as [x0 [H4 H5]].
        destruct x0.
        + inversion H4.
        + inversion H4.
      }
    * (* H1, second case: comes from g2 *)
      destruct H1 as [x [H1 H2]].
      {
      inversion H0.
      - (* First rule: Start1_uni *)
        (* Contradiction, x cannot contain Start_uni *)
        simpl in *. subst.
        destruct s2.
        + simpl in H1.
          destruct x.
          * inversion H1.
          * simpl in H1.
            inversion H1.
            {
            destruct s.
            - inversion H4.
            - inversion H4.
            }
        + simpl in *.
          assert (IN: In (inl Start_uni) (map g_uni_sf_lift2 x)).
            {
            rewrite <- H1.
            simpl.
            right.
            apply in_app_iff.
            right. simpl.
            left.
            reflexivity.
            }
          rewrite in_map_iff in IN.
          destruct IN.
          destruct H3.
          destruct x0.
          * simpl in H3. inversion H3.
          * simpl in H3. inversion H3.
      - (* Second rule: Start2_uni *)
        (* Contradiction, x cannot contain Start_uni *)
        simpl in *.
        subst.
        destruct s2.
        + simpl in H1.
          destruct x.
          * inversion H1.
          * simpl in H1.
            inversion H1.
            {
            destruct s.
            - inversion H4.
            - inversion H4.
            }
        + simpl in *.
          assert (IN: In (inl Start_uni) (map g_uni_sf_lift2 x)).
            {
            rewrite <- H1.
            simpl.
            right.
            apply in_app_iff.
            right.
            simpl.
            left.
            reflexivity.
            }
          rewrite in_map_iff in IN.
          destruct IN.
          destruct H3.
          destruct x0.
          * simpl in H3.
            inversion H3.
          * simpl in H3.
            inversion H3.
      - (* Third rule: Lift1_uni *)
        (* Should be false *)
        simpl in *.
        subst.
        assert (IN: In (inl (Transf1_uni_nt nt)) (map g_uni_sf_lift2 x)).
          {
          rewrite <- H1.
          rewrite in_app_iff.
          right.
          simpl.
          left.
          reflexivity.
          }
        rewrite in_map_iff in IN.
        destruct IN as [x0 [H4 H5]].
        destruct x0.
        + inversion H4.
        + inversion H4.
      - (* Forth rule: Lift2_uni *)
        (* Should be true *)
        right.
        right.
        apply map_expand in H1.
        destruct H1 as [s1' [s2'[H6 [H7 H8]]]].
        replace (inl left::s3) with ([inl left]++s3) in H8.
        + symmetry in H8.
          apply map_expand in H8.
          destruct H8 as [m [n [H9 [H10 H11]]]].
          exists (s1'++s++n).
          split.
          * subst.
            repeat rewrite map_app.
            reflexivity.
          * subst.
            {
            destruct m.
            - inversion H10.
            - simpl in H10.
              inversion H10.
              destruct s0.
              + inversion H4.
                subst.
                apply map_eq_nil in H5.
                subst.
                apply derives_step with (right:=s) in H2.
                exact H2.
                exact H3.
              + inversion H4.
            }
        + simpl.
          reflexivity.
      }
Qed.

End Union.

(* --------------------------------------------------------------------- *)
(* AS LANGUAGES                                                          *)
(* --------------------------------------------------------------------- *)

Section Union_2.

Variable non_terminal_1 non_terminal_2 terminal: Type.

Notation sentence:= (list terminal).

Lemma map_uni_1:
forall s: sentence,
map (@g_uni_sf_lift1 non_terminal_1 non_terminal_2 terminal) (map (@terminal_lift non_terminal_1 terminal) s) =
map (@terminal_lift (@g_uni_nt non_terminal_1 non_terminal_2) terminal) s.
Proof.
induction s.
- simpl.
  reflexivity.
- simpl.
  change (inr a) with (terminal_lift (g_uni_nt non_terminal_1 non_terminal_2) a).
  rewrite IHs.
  reflexivity.
Qed.

Lemma map_uni_2:
forall s: sentence,
map (@g_uni_sf_lift2 non_terminal_1 non_terminal_2 terminal) (map (@terminal_lift non_terminal_2 terminal) s) =
map (@terminal_lift (@g_uni_nt non_terminal_1 non_terminal_2) terminal) s.
Proof.
induction s.
- simpl.
  reflexivity.
- simpl.
  change (inr a) with (terminal_lift (g_uni_nt non_terminal_1 non_terminal_2) a).
  rewrite IHs.
  reflexivity.
Qed.

Lemma map_uni_3:
forall s: sentence,
forall l: list (non_terminal_1 + terminal),
map (@terminal_lift (g_uni_nt non_terminal_1 non_terminal_2) terminal) s =
map (@g_uni_sf_lift1 non_terminal_1 non_terminal_2 terminal) l ->
l = map (@terminal_lift non_terminal_1 terminal) s.
Proof.
induction s.
- intros l H.
  simpl in H.
  symmetry in H.
  apply map_eq_nil in H.
  subst.
  simpl.
  reflexivity.
- intros l H.
  remember (terminal_lift (g_uni_nt non_terminal_1 non_terminal_2) (terminal:=terminal)) as m1.
  remember (g_uni_sf_lift1 non_terminal_2 (terminal:=terminal)) as m2.
  remember (terminal_lift non_terminal_1 (terminal:=terminal)) as m3.
  simpl in H.
  destruct l.
  + simpl in H.
    inversion H.
  + simpl in H.
    inversion H.
    specialize (IHs l H2).
    rewrite IHs.
    simpl.
    destruct s0.
    * {
      replace (m2 (inl n)) with (inl terminal (Transf1_uni_nt non_terminal_2 n)) in H1.
      - replace (m1 a) with (inr (g_uni_nt non_terminal_1 non_terminal_2) a) in H1.
        + inversion H1.
        + rewrite Heqm1.
          change (inr a) with (terminal_lift (g_uni_nt non_terminal_1 non_terminal_2) a).
          reflexivity.
      - rewrite Heqm2.
        simpl.
        reflexivity.
      }
    * {
      replace (m2 (inr t)) with (inr (g_uni_nt non_terminal_1 non_terminal_2) t) in H1.
      - replace (m1 a) with (inr (g_uni_nt non_terminal_1 non_terminal_2) a) in H1.
        + inversion H1.
          replace (m3 t) with (inr non_terminal_1 t).
          * reflexivity.
          * rewrite Heqm3.
            change (inr t) with (terminal_lift non_terminal_1 t).
            reflexivity.
        + rewrite Heqm1.
          change (inr a) with (terminal_lift (g_uni_nt non_terminal_1 non_terminal_2) a).
          reflexivity.
      - rewrite Heqm2.
        simpl.
        reflexivity.
      }
Qed.

Lemma map_uni_4:
forall s: sentence,
forall l: list (non_terminal_2 + terminal),
map (@terminal_lift (@g_uni_nt non_terminal_1 non_terminal_2) terminal) s =
map (@g_uni_sf_lift2 non_terminal_1 non_terminal_2 terminal) l ->
l = map (@terminal_lift non_terminal_2 terminal) s.
Proof.
induction s.
- intros l H.
  simpl in H.
  symmetry in H.
  apply map_eq_nil in H.
  subst.
  simpl.
  reflexivity.
- intros l H.
  remember (terminal_lift (g_uni_nt non_terminal_1 non_terminal_2) (terminal:=terminal)) as m1.
  remember (g_uni_sf_lift2 non_terminal_1 (terminal:=terminal)) as m2.
  remember (terminal_lift non_terminal_2 (terminal:=terminal)) as m3.
  simpl in H.
  destruct l.
  + simpl in H.
    inversion H.
  + simpl in H.
    inversion H.
    specialize (IHs l H2).
    rewrite IHs.
    simpl.
    destruct s0.
    * {
      replace (m2 (inl n)) with (inl terminal (Transf2_uni_nt non_terminal_1 n)) in H1.
      - replace (m1 a) with (inr (g_uni_nt non_terminal_1 non_terminal_2) a) in H1.
        + inversion H1.
        + rewrite Heqm1.
          change (inr a) with (terminal_lift (g_uni_nt non_terminal_1 non_terminal_2) a).
          reflexivity.
      - rewrite Heqm2.
        simpl.
        reflexivity.
      }
    * {
      replace (m2 (inr t)) with (inr (g_uni_nt non_terminal_1 non_terminal_2) t) in H1.
      - replace (m1 a) with (inr (g_uni_nt non_terminal_1 non_terminal_2) a) in H1.
        + inversion H1.
          replace (m3 t) with (inr non_terminal_2 t).
          * reflexivity.
          * rewrite Heqm3.
            change (inr t) with (terminal_lift non_terminal_2 t).
            reflexivity.
        + rewrite Heqm1.
          change (inr a) with (terminal_lift (g_uni_nt non_terminal_1 non_terminal_2) a).
          reflexivity.
      - rewrite Heqm2.
        simpl.
        reflexivity.
      }
Qed.

Inductive l_uni (l1 l2: lang terminal): lang terminal:=
| l_uni_l1: forall s: sentence, l1 s -> l_uni l1 l2 s
| l_uni_l2: forall s: sentence, l2 s -> l_uni l1 l2 s.

End Union_2.

Variable terminal: Type.

Notation sentence:= (list terminal).

Theorem l_uni_is_cfl:
forall l1 l2: lang terminal,
cfl l1 ->
cfl l2 ->
cfl (l_uni l1 l2).
Proof.
intros l1 l2 H1 H2.
unfold cfl.
unfold cfl in H1.
unfold cfl in H2.
unfold lang_eq.
unfold lang_eq in H1.
unfold lang_eq in H2.
unfold lang_of_g.
unfold lang_of_g in H1.
unfold lang_of_g in H2.
destruct H1 as [non_terminal_1 [g1 H1]].
destruct H2 as [non_terminal_2 [g2 H2]].
exists (g_uni_nt non_terminal_1 non_terminal_2), (g_uni g1 g2).
intros w.
split.
- intros H3.
  inversion H3.
  + subst.
    specialize (H1 w).
    destruct H1 as [H1 _].
    specialize (H1 H).
    unfold produces in H1.
    unfold produces.
    rewrite <- (map_uni_1 _ _ w).
    apply g_uni_correct.
    * exact [].
    * exact H1.
  + subst.
    specialize (H2 w).
    destruct H2 as [H2 _].
    specialize (H2 H).
    unfold produces in H2.
    unfold produces.
    rewrite <- (map_uni_2 _ _ w).
    apply g_uni_correct.
    * exact [].
    * exact H2.
- intros H4.
  apply g_uni_correct_inv in H4.
  destruct H4 as [H4 | H4].
  + destruct w.
    * simpl in H4.
      inversion H4.
    * simpl in H4.
      inversion H4.
  + destruct H4 as [H4 | H4].
    * destruct H4 as [s1 [H4 H5]].
      left.
      specialize (H1 w).
      destruct H1 as [_ H1].
      apply H1.
      unfold produces.
      apply map_uni_3 in H4.
      rewrite H4 in H5.
      exact H5.
    * destruct H4 as [s1 [H4 H5]].
      right.
      specialize (H2 w).
      destruct H2 as [_ H2].
      apply H2.
      unfold produces.
      apply map_uni_4 in H4.
      rewrite H4 in H5.
      exact H5.
Qed.

Theorem l_uni_correct:
forall l1 l2: lang terminal,
forall s: sentence,
(l1 s \/ l2 s) -> (l_uni l1 l2) s.
Proof.
intros l1 l2 s H.
destruct H as [H | H].
- apply l_uni_l1.
  exact H.
- apply l_uni_l2.
  exact H.
Qed.

Theorem l_uni_correct_inv:
forall l1 l2: lang terminal,
forall s: sentence,
(l_uni l1 l2) s ->
l1 s \/ l2 s.
Proof.
intros l1 l2 s H.
inversion H.
- left.
  exact H0.
- right.
  exact H0.
Qed.


Require Export soundness.
Require Export Decidable.
Require Export Lia.
Set Implicit Arguments.

Module Type complete_mod (X : base_mod) (Y : sound_mod X).
Import X.
Import Y.

(* Negation Normal Form (NNF) *)
Inductive NNF : Set :=
  | NPos : PropVars -> NNF
  | NNeg : PropVars -> NNF
  | NBot : NNF
  | NTop : NNF
  | NConj : NNF -> NNF -> NNF
  | NDisj : NNF -> NNF -> NNF
  .

Fixpoint MakeNNF A : NNF :=
    match A with
    | # P => NPos P
    | ⊥ => NBot
    | B ∨ C => NDisj (MakeNNF B) (MakeNNF C)
    | B ∧ C => NConj (MakeNNF B) (MakeNNF C)
    | B → C => NDisj (MakeNNFN B) (MakeNNF C)
    end
(* MakeNNFN does sama as ¬ A *)
with MakeNNFN A : NNF :=
  match A with
  | # P => NNeg P
  | ⊥ => NTop
  | B ∨ C => NConj (MakeNNFN B) (MakeNNFN C)
  | B ∧ C => NDisj (MakeNNFN B) (MakeNNFN C)
  | B → C => NConj (MakeNNF B) (MakeNNFN C)
  end.

Fixpoint NNFtoPropF A : PropF :=
  match A with
  | NPos P => # P
  | NNeg P => ¬ # P
  | NBot => ⊥
  | NTop => ⊤
  | NConj B C => NNFtoPropF B ∧ NNFtoPropF C
  | NDisj B C => NNFtoPropF B ∨ NNFtoPropF C
  end.

(* l := p | ¬ p | ⊤ | ⊥ *)
Inductive Literal :=
  | LPos : PropVars -> Literal
  | LNeg : PropVars -> Literal
  | LBot : Literal
  | LTop : Literal
  .

Definition Bar P :=
  match P with
  | LPos Q => LNeg Q
  | LNeg Q => LPos Q
  | LBot => LTop
  | LTop => LBot
  end.

Definition LiteraltoPropF P : PropF :=
  match P with
  | LPos Q => # Q
  | LNeg Q => ¬ # Q
  | LBot => ⊥
  | LTop => ⊤
  end.

(* c := {lᵢ} *)
Definition Clause := list Literal.

(* {lᵢ} => l₁ ∨ l₂ ∨ ... ∨ lᵢ *)
Definition ClausetoPropF := map_fold_right LiteraltoPropF Disj ⊥.

(* CNF := {cᵢ} *)
Definition CNF := list Clause.

(*
  {cᵢ} => (l₁₁ ∨ l₁₂ ∨ ... l₁ₙ₁) ∧
          (l₂₁ ∨ l₂₂ ∨ ... l₂ₙₙ₂) ∧
          ...
          (lₘ₁ ∨ lₘ₂ ∨ ... lₘₙₘ )
*)
Definition CNFtoPropF := map_fold_right ClausetoPropF Conj ⊤.

(* AddClause l {lᵢ} := {l++l₁, l++l₂, ..., l++lᵢ} *)
Definition AddClause (l : Clause) (ll : CNF) : CNF := map (fun l2 => l ++ l2) ll.

(*
  ll1 := [[a;b;c];[d;e;f];[g;h;i]].
  ll2 := [[A;B;C];[D;E;F];[G;H;I]].
  Disjunct ll1 ll2 =
    [[a; b; c; A; B; C]; [a; b; c; D; E; F]; [a; b; c; G; H; I];
     [d; e; f; A; B; C]; [d; e; f; D; E; F]; [d; e; f; G; H; I];
     [g; h; i; A; B; C]; [g; h; i; D; E; F]; [g; h; i; G; H; I]
    ]
*)
Definition Disjunct (ll ll2 : CNF) : CNF := flat_map (fun l => AddClause l ll2) ll.

Fixpoint MakeCNF A : CNF :=
  match A with
  | NPos P => [[LPos P]]
  | NNeg P => [[LNeg P]]
  | NBot => [[LBot]]
  | NTop => [[LTop]]
  | NConj B C => MakeCNF B ++ MakeCNF C
  | NDisj B C => Disjunct (MakeCNF B) (MakeCNF C)
  end.

Definition Valid_Clause (l : Clause) := In LTop l \/ (exists A, In (LPos A) l /\ In (LNeg A) l).
Definition Valid_CNF ll := forall l, In l ll -> Valid_Clause l.

Lemma Literal_eqdec :
  forall (x y : Literal), {x = y} + {x <> y}.
Proof.
  intros x y; destruct x,y;
    try solve [left; auto| right; discriminate];
    destruct (X.Varseq_dec p p0);
    try solve [left; f_equal; auto];
    right; intro F; inversion F; auto.
Qed.

Lemma NNF_equiv_valid v A :
  TrueQ v (NNFtoPropF (MakeNNF A)) = TrueQ v A /\
  TrueQ v (NNFtoPropF (MakeNNFN A)) = TrueQ v ¬ A.
Proof.
  induction A; simpl;
    try destruct (v p); simpl; split;
    try destruct IHA1 as [L1 L2];
    try destruct IHA2 as [R1 R2];
    try rewrite L1;
    try rewrite L2;
    try rewrite R1;
    try rewrite R2; simpl;
    repeat rewrite orb_false_r;
    try rewrite negb_orb;
    try rewrite negb_andb;
    try rewrite negb_involutive;
    auto.
Qed.

Lemma CNF_and_valid v ll1 ll2 :
  TrueQ v (CNFtoPropF (ll1 ++ ll2)) =
  TrueQ v (CNFtoPropF ll1) && TrueQ v (CNFtoPropF ll2).
Proof.
  generalize dependent ll2.
  induction ll1; simpl; auto; intro ll2.
  rewrite <- andb_assoc.
  f_equal.
  rewrite IHll1; auto.
Qed.

Lemma CNF_or_clause_valid v l1 l2 :
  TrueQ v (ClausetoPropF (l1 ++ l2)) =
  TrueQ v (ClausetoPropF l1) || TrueQ v (ClausetoPropF l2).
Proof.
    generalize dependent l2.
    induction l1; auto; simpl; intro l2.
    rewrite <- orb_assoc; f_equal; rewrite IHl1; auto.
Qed.

Lemma cons_app {A} (a : A) (l : list A) :
  a :: l = [a] ++ l.
Proof.
  induction l; simpl; auto.
Qed.

Lemma CNF_add_clause_valid v l ll :
  TrueQ v (CNFtoPropF (AddClause l ll)) =
  TrueQ v (ClausetoPropF l) || TrueQ v (CNFtoPropF ll).
Proof.
  induction ll; simpl in *.
  - destruct l; simpl; auto.
    rewrite orb_true_r; auto.
  - unfold CNFtoPropF in IHll.
    rewrite IHll; clear IHll.
    rewrite CNF_or_clause_valid.
    remember (TrueQ v (ClausetoPropF l)) as P.
    remember (TrueQ v (ClausetoPropF a)) as Q.
    remember (TrueQ v (map_fold_right ClausetoPropF Conj ⊤ ll)) as R.
    rewrite orb_andb_distrib_r; auto.
Qed.

Lemma CNF_or_valid v ll1 ll2 :
  TrueQ v (CNFtoPropF (Disjunct ll1 ll2)) =
  TrueQ v (CNFtoPropF ll1) || TrueQ v (CNFtoPropF ll2).
Proof.
  induction ll1; auto; simpl.
  rewrite CNF_and_valid, CNF_add_clause_valid, IHll1.
  unfold CNFtoPropF.
  remember (TrueQ v (map_fold_right ClausetoPropF Conj ⊤ ll1)) as P.
  remember (TrueQ v (map_fold_right ClausetoPropF Conj ⊤ ll2)) as Q.
  remember (TrueQ v (ClausetoPropF a)) as R.
  rewrite orb_andb_distrib_l; auto.
Qed.

Theorem CNF_equiv_valid v A :
  TrueQ v (CNFtoPropF (MakeCNF A)) = TrueQ v (NNFtoPropF A).
Proof.
  induction A;simpl;
    try repeat rewrite orb_false_r;
    try repeat rewrite andb_true_r;
    try rewrite CNF_and_valid;
    try rewrite CNF_or_valid;
    try rewrite IHA1, IHA2; auto.
Qed.

Definition Countervaluation l P :=
  if (in_dec Literal_eqdec (LNeg P) l) then true else false.
Definition Validates v Δ :=
  exists A, In A Δ /\ Is_true (TrueQ v A).

Lemma TrueQ_impl_Validates v m :
  Is_true (TrueQ v (ClausetoPropF m)) -> Validates v (map LiteraltoPropF m).
Proof.
  induction m; simpl; intro H.
  - inversion H.
  - unfold Validates.
    apply Is_true_eq_true in H.
    apply orb_prop in H.
    destruct H.
    * exists (LiteraltoPropF a); split; auto.
      + left; auto.
      + rewrite H; simpl; auto.
    * apply Is_true_eq_left in H.
      apply IHm in H.
      destruct H as [x [Hxm Hx]].
      exists x; split; auto.
      right; auto.
Qed.

Lemma Validated_valid l :
  Validates (Countervaluation l) (map LiteraltoPropF l) -> Valid_Clause l.
Proof.
  destruct 1 as [A [HA Hx]].
  apply in_map_iff in HA as [p [Hp pl]]; subst.
  destruct p;
  unfold Countervaluation in Hx; simpl in Hx;
  try solve [left; auto];
  try destruct (in_dec Literal_eqdec (LNeg p) l);
  simpl in *;
  try contradiction.
  try right; exists p; split; auto.
Qed.

Theorem Clause_valid l :
  Valid (ClausetoPropF l) -> Valid_Clause l.
Proof.
  intro H; apply Validated_valid.
  apply TrueQ_impl_Validates.
  apply H.
  intros A HA.
  contradiction.
Qed.

Theorem CNF_valid ll :
  Valid (CNFtoPropF ll) -> Valid_CNF ll.
Proof.
  induction ll; simpl; intro H.
  - unfold Valid, Valid_CNF; intros; contradiction.
  - intros l Hl.
    apply Clause_valid.
    intros f Hf.
    specialize (H f Hf).
    rewrite cons_app in H.
    rewrite CNF_and_valid in H.
    apply andb_prop_elim in H as [Ha Hll].
    destruct Hl; subst; auto.
    * simpl in Ha; rewrite andb_true_r in Ha; auto.
    *  apply in_split in H as [h [t]]; subst.
        rewrite CNF_and_valid in Hll.
        apply andb_prop_elim in Hll as [_].
        simpl in H.
        apply andb_prop_elim in H as []; auto.
Qed.

Lemma Clause_provable_3 a l1 l2 Γ :
  In (LiteraltoPropF a) Γ -> Γ ⊢ ClausetoPropF (l1 ++ a :: l2).
Proof.
  intro H; induction l1; simpl.
  - unfold ClausetoPropF; simpl.
    apply OrI1; constructor; auto.
  - unfold ClausetoPropF; simpl; apply OrI2; simpl; auto.
Qed.

Lemma provable_or_comm l A B :
  l ⊢ A ∨ B -> l ⊢ B ∨ A.
Proof.
  intro H.
  apply OrE with A B; auto; [apply OrI2| apply OrI1]; is_ass.
Qed.

Lemma Clause_provable_2 a l1 l2 l3 :
  Provable (ClausetoPropF (l1 ++ (Bar a) :: l2 ++ a :: l3)).
Proof.
  induction l1; simpl.
  - apply OrE with (LiteraltoPropF (Bar a)) (LiteraltoPropF a).
    * destruct a; simpl;
      try apply Excluded_Middle;
      apply provable_or_comm; apply Excluded_Middle.
    * unfold ClausetoPropF; simpl.
      apply OrI1; is_ass.
    * unfold ClausetoPropF; simpl.
      apply OrI2.
      induction l2; simpl.
      { apply OrI1. is_ass. }
      { apply OrI2; auto. }
  - unfold ClausetoPropF; simpl; apply OrI2; auto.
Qed.

Lemma Clause_provable l :
  Valid_Clause l -> Provable (ClausetoPropF l).
Proof.
  unfold Valid_Clause.
  intros H; destruct H.
  - apply in_split in H as [h [t]]; subst.
    induction h; simpl.
    * unfold ClausetoPropF; simpl.
      apply OrI1; apply ImpI; is_ass.
    * unfold ClausetoPropF; simpl.
      apply OrI2; auto.
  - destruct H as [A [HP HN]].
    assert (LPos A = Bar (LNeg A)) as HLP by auto.
    assert (LNeg A = Bar (LPos A)) as HLN by auto.
    apply in_split in HP as [l1 [l2]]; subst.
    apply in_app_or in HN.
    destruct HN.
    * apply in_split in H as [l3 [l4]]; subst.
      rewrite <- app_assoc, <- app_comm_cons, HLN.
      apply Clause_provable_2.
    * destruct H; try contradiction.
      inversion H.
      apply in_split in H as [l3 [l4]]; subst.
      rewrite HLP.
      apply Clause_provable_2.
Qed.

Theorem CNF_provable ll :
  Valid_CNF ll -> Provable (CNFtoPropF ll).
Proof.
  unfold Valid_CNF.
  induction ll; unfold CNFtoPropF; simpl.
  - intro H; apply ImpI; is_ass.
  - intro H.
    apply AndI.
    * apply Clause_provable; apply H; left; auto.
    * apply IHll; intros l Hll.
      apply H; right; auto.
Qed.

Lemma prov_or A1 A2 B1 B2 Γ :
  Provable (A1 → A2) -> Provable (B1 → B2) -> In (A1 ∨ B1) Γ -> Γ ⊢ A2 ∨ B2.
Proof.
  intros HA HB H1.
  eapply OrE with A1 B1;
    [is_ass|apply OrI1|apply OrI2];
    apply deduction;
    rewrite <- (app_nil_l Γ);
    apply weakening; auto.
Qed.

From mathcomp Require Export ssreflect.

Lemma prov_and_assoc A B C Γ :
  Γ ⊢ A ∧ B ∧ C -> Γ ⊢ (A ∧ B) ∧ C.
Proof.
  move => H.
  apply AndI; [apply AndI|].
  - apply AndE1 with (B ∧ C); auto.
  - apply AndE1 with C.
    apply AndE2 with A; auto.
  - apply AndE2 with B.
    apply AndE2 with A; auto.
Qed.

Lemma CNF_and_prov ll1 ll2 :
  Provable (CNFtoPropF (ll1 ++ ll2) → CNFtoPropF ll1 ∧ CNFtoPropF ll2).
Proof.
  induction ll1; simpl.
  - unfold CNFtoPropF; simpl.
    apply ImpI. apply AndI.
    * rewrite <- (app_nil_l [_]).
      apply weakening.
      apply ImpI; is_ass.
    * is_ass.
  - move : (prov_impl IHll1) => H.
    apply ImpI.
    unfold CNFtoPropF; simpl.
    apply prov_and_assoc.
    apply AndI.
    * eapply AndE1; is_ass.
    * apply H.
      eapply AndE2; is_ass.
Qed.

Lemma prov_or_assoc A B C Γ :
  Γ ⊢ A ∨ B ∨ C -> Γ ⊢ (A ∨ B) ∨ C.
Proof.
  move => H.
  eapply OrE with A (B ∨ C); auto.
  - repeat apply OrI1; is_ass.
  - eapply prov_or with B C.
    * apply ImpI; apply OrI2; is_ass.
    * apply ImpI; is_ass.
    * left; auto.
Qed.

Lemma CNF_or_clause_prov l1 l2 :
  Provable (ClausetoPropF (l1 ++ l2) → ClausetoPropF l1 ∨ ClausetoPropF l2).
Proof.
  induction l1; rewrite /ClausetoPropF => /=; apply ImpI.
  - apply OrI2; is_ass.
  - apply prov_or_assoc.
    eapply prov_or with (LiteraltoPropF a) (ClausetoPropF (l1 ++ l2)); auto.
    * apply ImpI; is_ass.
    * left; auto.
Qed.

Ltac prov_impl_in IH := let H := fresh "K" in
try (remember (prov_impl IH) as H eqn:HeqH;clear IH HeqH).

Lemma CNF_add_clause_prov l ll :
  Provable (CNFtoPropF (AddClause l ll) → ClausetoPropF l ∨ CNFtoPropF ll).
Proof.
  induction ll.
    (* rewrite /CNFtoPropF; simpl. *)
  - apply ImpI; apply OrI2; apply ImpI; is_ass.
  - apply ImpI.
    move : (prov_impl IHll) => IH.
    unfold CNFtoPropF; simpl.
    apply OrE with (ClausetoPropF l) (ClausetoPropF a).
    * eapply prov_impl.
      + apply CNF_or_clause_prov.
      + eapply AndE1; is_ass.
    * apply OrI1; is_ass.
    * apply OrE with (ClausetoPropF l) (CNFtoPropF ll).
      - apply IH. eapply AndE2; is_ass.
      - apply OrI1; is_ass.
      - apply OrI2; apply AndI; is_ass.
Qed.

Lemma CNF_or_prov ll1 ll2 :
  Provable (CNFtoPropF (Disjunct ll1 ll2) → CNFtoPropF ll1 ∨ CNFtoPropF ll2).
Proof.
  induction ll1.
  { apply ImpI; apply OrI1; is_ass. }
  {
    move : (prov_impl IHll1) => IH; clear IHll1.
    apply ImpI; simpl.
    rewrite /CNFtoPropF; simpl.
    apply OrE with (ClausetoPropF a) (CNFtoPropF ll2).
    {
      eapply prov_impl.
      - apply CNF_add_clause_prov.
      - eapply AndE1.
        eapply prov_impl.
        * apply CNF_and_prov.
        * is_ass.
    }
    {
      apply OrE with (CNFtoPropF ll1) (CNFtoPropF ll2).
        apply IH. eapply AndE2.
        eapply prov_impl.
        - apply CNF_and_prov.
        - is_ass.
        apply OrI1; apply AndI; is_ass.
        apply OrI2; is_ass.
    }
    {
      apply OrI2; is_ass.
    }
  }
Qed.

Theorem CNF_impl_prov A :
  Provable (CNFtoPropF (MakeCNF A) → NNFtoPropF A).
Proof.
  induction A; apply ImpI; simpl.
  - rewrite /CNFtoPropF /ClausetoPropF; simpl;
    eapply OrE;[ eapply AndE1 | | apply BotC]; is_ass.
  - rewrite /CNFtoPropF /ClausetoPropF; simpl;
    eapply OrE; [ eapply AndE1 | | apply BotC]; is_ass.
  - rewrite /CNFtoPropF /ClausetoPropF; simpl;
    eapply OrE; [ eapply AndE1 | | apply BotC]; is_ass.
  - rewrite /CNFtoPropF /ClausetoPropF; simpl;
    eapply OrE; [ eapply AndE1 | | apply BotC]; is_ass.
  - eapply prov_impl.
    * apply ImpI.
      eapply AndI; eapply prov_impl; eauto;
      [eapply AndE1|eapply AndE2]; is_ass.
    * eapply prov_impl; [apply CNF_and_prov|is_ass].
  - eapply OrE with (CNFtoPropF (MakeCNF A1)) ((CNFtoPropF (MakeCNF A2))).
    * eapply prov_impl; [apply CNF_or_prov| is_ass].
    * apply OrI1. eapply prov_impl. apply IHA1; is_ass. is_ass.
    * apply OrI2. eapply prov_impl. apply IHA2; is_ass. is_ass.
Qed.

Lemma prov_and A1 A2 B1 B2 Γ :
  Provable (A1 → A2) -> Provable (B1 → B2) -> In (A1 ∧ B1) Γ -> Γ ⊢ A2 ∧ B2.
Proof.
  move => HA HB H1.
  apply AndI; eapply prov_impl; eauto; [eapply AndE1 | eapply AndE2]; is_ass.
Qed.

Theorem prov_not_or_and A B Γ :
  Γ ⊢ ¬ (A ∨ B) -> Γ ⊢ (¬ A) ∧ (¬ B).
Proof.
  intro H; apply AndI; apply ImpI; apply ImpE with (A ∨ B);
    try (eapply weakening2; [apply H| intros; right; auto]);
    [apply OrI1|apply OrI2]; is_ass.
Qed.

Theorem prov_and_not_or A B Γ :
  Γ ⊢ (¬ A) ∧ (¬ B) -> Γ ⊢ ¬ (A ∨ B).
Proof.
  move => H. apply ImpI.
  eapply OrE with A B.
  is_ass.
  apply ImpE with A. eapply weakening2 with Γ;
  [eapply AndE1; apply H| intros; right; right; auto].
  is_ass.
  apply ImpE with B. eapply weakening2 with Γ;
  [eapply AndE2; apply H| intros; right; right; auto].
  is_ass.
Qed.

Theorem prov_or_not_and A B Γ :
  Γ ⊢ (¬ A) ∨ (¬ B) -> Γ ⊢ ¬ (A ∧ B).
Proof.
  move => H.
  apply ImpI.
  apply OrE with (¬ A) (¬ B).
  - apply weakening2 with Γ; auto.
    intros; right; auto.
  - apply ImpE with A.
    is_ass.
    eapply AndE1; is_ass.
  - apply ImpE with B.
    is_ass.
    eapply AndE2; is_ass.
Qed.

Theorem prov_or_imply A B Γ :
  Γ ⊢ (¬ A) ∨ B -> Γ ⊢ A → B.
Proof.
  move => H.
  apply ImpI.
  apply OrE with (¬ A) B.
  - apply weakening2 with Γ; auto.
    intros; right; auto.
  - apply BotC.
    apply ImpE with A; is_ass.
  - is_ass.
Qed.

Theorem NN A Γ :
 Γ ⊢ A -> Γ ⊢ ¬ ¬ A.
Proof.
  intro H.
  apply ImpI.
  apply ImpE with A.
  is_ass.
  apply weakening2 with Γ; auto.
  intros; right; auto.
Qed.

Theorem prov_and_imply A B Γ :
   Γ ⊢ A ∧ ¬ B -> Γ ⊢ ¬ (A → B).
Proof.
  move => H.
  apply ImpI.
  apply ImpE with (A ∧ ¬ B).
  - apply prov_or_not_and.
    apply OrE with A (¬ A).
    eapply Excluded_Middle.
    apply OrI2. apply NN. eapply ImpE with A; is_ass.
    apply OrI1. is_ass.
  - apply weakening2 with Γ; auto.
    intros; right; auto.
Qed.

Lemma NNF_impl_prov A :
  Provable (NNFtoPropF (MakeNNF A)  →   A) /\
  Provable (NNFtoPropF (MakeNNFN A) → ¬ A).
Proof.
  induction A; split; simpl; apply ImpI;
  try destruct IHA1 as [IHA1 IHA1']; try destruct IHA2 as [IHA2 IHA2'].
  - is_ass.
  - is_ass.
  - is_ass.
  - is_ass.
  - eapply prov_and.
    apply IHA1.
    apply IHA2.
    left; auto.
  - apply OrE with (NNFtoPropF (MakeNNFN A1)) (NNFtoPropF (MakeNNFN A2)).
    * is_ass.
    * apply ImpI.
      apply ImpE with A1.
      apply  (prov_impl IHA1'). is_ass.
      apply AndE1 with A2. is_ass.
    * apply ImpI.
      apply ImpE with A2.
      apply (prov_impl IHA2'). is_ass.
      eapply AndE2; is_ass.
  - eapply prov_or.
    eapply IHA1.
    eapply IHA2.
    left; auto.
    - eapply prov_and_not_or.
    move : (prov_impl IHA1') => IH1; clear IHA1.
    move : (prov_impl IHA2') => IH2; clear IHA2.
    apply AndI; [apply IH1|apply IH2]; [eapply AndE1|eapply AndE2]; is_ass.
  - apply ImpI.
    apply OrE with (¬ A1) A2.
    * eapply prov_or; try assumption; in_solve.
    * apply BotC.
      apply ImpE with A1; is_ass.
    * is_ass.
  - apply ImpI.
    apply ImpE with A2.
    * eapply prov_impl.
      apply IHA2'.
      eapply AndE2; is_ass.
    * apply ImpE with A1.
      is_ass.
      eapply prov_impl.
      apply IHA1.
      eapply AndE1.
      is_ass.
Qed.

Theorem Completeness : Prop_Completeness.
Proof.
  move => A HA.
  mp. apply NNF_impl_prov.
  mp. apply CNF_impl_prov.
  apply CNF_provable.
  apply CNF_valid.
  move => f Hf.
  Search (TrueQ _ (NNFtoPropF _)).
  rewrite CNF_equiv_valid.
  move : (NNF_equiv_valid f A) => [H _].
  rewrite H.
  apply HA; auto.
Qed.

End complete_mod.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo39:
  prime  12155647799415374728567975423->
  prime  230528960214814584603528114483172789621.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      230528960214814584603528114483172789621
      18964761403
      ((12155647799415374728567975423,1)::nil)
      0
      23625
      30
      225)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo42:
  prime  401928217->
  prime  1199081629973173.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      1199081629973173
      2983323
      ((401928217,1)::nil)
      0
      6912
      24
      144)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


Require Import core.Semantics.
Require Import core.Syntax.
Require Import core.Model.
Require Import core.TransformationConfiguration.
Require Import String.
Require Import EqNat.
Require Import List.
Require Import Expressions.
Require Import core.utils.Utils.
Require Import PeanoNat.
Require Import Lia.
Require Import FunctionalExtensionality.
Require Import Coq.Program.Basics.

(* Trivial theorem if we are free to choose anything *)

Theorem adaptation :
forall (tc: TransformationConfiguration)
  (T_t: Type) (sem_t: TargetModel -> T_t)
  (adapter: Transformation),
  exists (T_s: Type) (sem_s: SourceModel -> T_s) (f: T_s -> T_t),
     compose sem_t (execute adapter) = compose f (sem_s).
Proof.
  intros.
  exists T_t, (compose sem_t (execute adapter)), id.
  crush.
Qed.

(* Trivial theorem, version for views *)

Theorem adaptation'' :
forall (tc: TransformationConfiguration)
  (T_t: Type) (adapter: Transformation),
  exists (view_t: TargetModel -> TargetModel) (view_s: SourceModel -> SourceModel),
     compose view_t (execute adapter) = compose (execute adapter) view_s.
Proof.
  intros.
  exists id, id.
  crush.
Qed.

(* Non provable theorem for view adaptation *)

Theorem adaptation' :
forall (tc: TransformationConfiguration)
  (view_t: TargetModel -> TargetModel)
  (adapter: Transformation),
  (forall ms, view_t (Model_concat ms) = Model_concat (map view_t ms)) ->
  exists (view_s: SourceModel -> SourceModel),
    forall (sm: SourceModel),
      view_t (execute adapter sm) = execute adapter (view_s sm).
Proof.
  intros.
  destruct adapter.
  induction l.
  2: {
    destruct IHl as [view_s].
    exists view_s.
    intros.
    specialize (H0 sm).
Abort.

(* Theorem adaptation_pushout :
forall (tc: TransformationConfiguration)
  (tool_s: Transformation)
  (adapter: Transformation),
  exists (tool_t: Transformation) (view: Transformation),
    forall (sm: SourceModel),
       execute view (execute tool_s sm) = execute tool_t (execute adapter sm).*)


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2007-08-08

maximal reduction length of a term
for a finitely branching well-founded relation
*)

Set Implicit Arguments.

From CoLoR Require Import SN ListMax RelUtil ListUtil LogicUtil.
From Coq Require Import Arith.

Section S.

Variables (A : Type) (R : relation A) (FB : finitely_branching R) (WF : WF R).

Definition len_aux x (len : forall y, R x y -> nat) :=
  let f i (hi : i < length (sons FB x)) :=
    len (ith hi) (in_sons_R FB (ith_In hi))
  in S (lmax (pvalues f)).

Lemma len_aux_ext : forall x (f g : forall y, R x y -> nat),
  (forall y (p : R x y), f y p = g y p) -> len_aux f = len_aux g.

Proof.
intros. unfold len_aux. apply (f_equal (fun l => S (lmax l))).
apply pvalues_eq. intros. apply H.
Qed.

Definition len : A -> nat := Fix (WF_wf_transp WF) _ len_aux.

Lemma len_eq : forall x, len x = S (lmax (map len (sons FB x))).

Proof.
intro. unfold len. rewrite Fix_eq. 2: exact len_aux_ext. fold len.
unfold len_aux. apply (f_equal (fun l => S (lmax l))).
rewrite <- (@pvalues_ith_eq_map A nat). apply pvalues_eq. intros. refl.
Qed.

Lemma R_len : forall x y, R x y -> len x > len y.

Proof.
intros. rewrite len_eq. unfold gt, lt. apply le_n_S. apply in_lmax.
apply in_map. apply R_in_sons. exact H.
Qed.

End S.


Require Export Coq.FSets.FMapInterface.
Require Import Fiat.Common.Wf.
Require Export Fiat.Common.FMapExtensions.
Require Import Fiat.Common.

Module FMapExtensionsWf_fun (E: DecidableType) (Import M: WSfun E).
  Module BasicExtensions := FMapExtensions_fun E M.
  Include BasicExtensions.

  Section rel.
    Context {A} (eqb leb : A -> A -> bool).

    Let ltb x y := (leb x y && negb (eqb x y)).
    Let gtb := flip ltb.

    Context (well_founded_gt : well_founded gtb).
    Context (top : A) (top_top : forall x, leb x top)
            (top_eqb : forall x, leb top x -> eqb top x)
            (eqb_Equivalence : Equivalence eqb).
            (*eqb_bl : forall x y, eqb x y -> x = y)
            (eqb_lb : forall x y, x = y -> eqb x y*)

    Definition lift_leb := lift_brelation leb top.
    Definition lift_eqb := lift_brelation eqb top.
    Definition lift_ltb x y
      := lift_leb x y && negb (lift_eqb x y).

    Global Instance lift_ltb_Proper_Equal
      : Proper (@Equal _ ==> @Equal _ ==> eq) lift_ltb | 5.
    Proof.
      unfold lift_ltb.
      intros ?? H ?? H'.
      rewrite H, H'.
      reflexivity.
    Qed.

    Global Instance lift_ltb_Proper_lift_eqb
           {HR : Reflexive eqb}
           {Hsub : subrelation eqb leb}
           {leb_Proper : Proper (eqb ==> eqb ==> eq) leb}
           {eqb_Proper : Proper (eqb ==> eqb ==> eq) eqb}
      : Proper (lift_eqb ==> lift_eqb ==> eq) lift_ltb.
    Proof.
      unfold lift_ltb.
      intros ?? H ?? H'.
      rewrite H, H'.
      reflexivity.
    Qed.

    Lemma empty_ltb_nothing v : lift_ltb (empty _) v = false.
    Proof.
      unfold lift_ltb.
      apply not_true_iff_false, BoolFacts.not_andb_negb_iff.
      unfold lift_leb, lift_eqb.
      setoid_rewrite lift_brelation_iff.
      intros H k; specialize (H k).
      rewrite empty_o in *.
      edestruct find; [ | reflexivity ].
      apply top_eqb; assumption.
    Qed.

    Section wf.
      Let to_function (m : t A) : key -> A :=
        fun k => find_default top k m.
      Let keys_of (m : t A) : list key := List.map (@fst _ _) (elements m).

      Lemma is_finite_for_keys (m : t A) : is_finite_forA eqb top E.eq to_function (keys_of m) m.
      Proof.
        unfold is_finite_forA, is_finite_forA', keys_of, to_function, find_default.
        intro k.
        rewrite InA_alt.
        setoid_rewrite in_map_iff.
        intro H.
        destruct (find k m) eqn:Hfind; simpl; [ | reflexivity ].
        apply elements_iff_find in Hfind.
        rewrite InA_alt in Hfind.
        destruct Hfind as [kv [[? ?] ?]]; simpl in *; subst.
        exfalso; apply H.
        intuition eauto.
      Qed.

      Lemma well_founded_lift_gtb
            {leb_Reflexive : Reflexive leb}
            {leb_Proper : Proper (eqb ==> eqb ==> eq) leb}
            {eqb_Proper : Proper (eqb ==> eqb ==> eq) eqb}
        : well_founded (Basics.flip lift_ltb).
      Proof.
        intro a.
        eapply Acc_subrelation.
        { eapply function_relationA_of_Acc;
          [ .. | eexact well_founded_gt | | eapply is_finite_for_keys ];
          [ try exact _.. ];
          [ repeat match goal with
                               | [ |- is_true (?R ?x ?x) ] => reflexivity
                   | _ => progress unfold gtb, ltb, flip, impl in *
                   | _ => intro
                   | _ => progress subst
                   | _ => assumption
                   | [ H : is_true (eqb ?x ?y) |- _ ]
                     => rewrite H in *; clear x H
                   end..
          | | ].
          { simpl; unfold gtb, flip, ltb in *.
            intro x; rewrite top_top; simpl.
            destruct (eqb x top) eqn:Heqb; [ left | right; reflexivity ].
            fold_is_true.
            rewrite Heqb; reflexivity. }
          { unfold to_function, find_default.
            intros ???? H.
            rewrite !(find_o _ H).
            trivial. } }
        { unfold gtb, flip; intros x y _ H.
          unfold lift_ltb in H.
          apply andb_true_iff in H.
          destruct H as [H0 H1].
          unfold function_relation.
          split; [ clear H1 | clear H0 ].
          { unfold to_function, lift_leb, find_default, ltb in *.
            setoid_rewrite lift_brelation_iff in H0.
            intro k; specialize (H0 k).
            do 2 edestruct find;
              repeat match goal with
                     | _ => progress simpl in *
                     | _ => left; congruence
                     | _ => right; reflexivity
                     | [ |- context[eqb ?x ?y] ] => destruct (eqb x y) eqn:?
                     | [ H : context[?x = true] |- _ ] => change (is_true x) in H
                     | [ H : is_true ?x, H' : context[?x] |- _ ] => rewrite H in H'
                     | [ H : is_true ?x |- context[?x] ] => rewrite H
                     | [ H : is_true (eqb ?x ?y) |- _ ]
                       => rewrite H in *; clear x H
                     | [ H : is_true (eqb ?x ?y) |- _ ]
                       => rewrite <- H in *; clear y H
                     | [ H : context[eqb ?x ?x] |- _ ]
                     => replace (eqb x x) with true
                       in H
                       by (symmetry; change (is_true (eqb x x)); reflexivity)                     end. }
          { unfold lift_eqb, to_function, find_default in *.
            apply negb_true_iff in H1.
            rewrite lift_brelation_iff_false in H1.
            destruct H1 as [k H1]; exists k.
            do 2 edestruct find;
              repeat match goal with
                     | _ => progress simpl in *
                     | _ => progress subst
                     | _ => congruence
                     | _ => intro
                     | [ H : is_true (eqb ?x ?y) |- _ ]
                       => rewrite H in *; clear x H
                     | [ H : is_true (eqb ?x ?y) |- _ ]
                       => rewrite <- H in *; clear y H
                     | [ H : context[eqb ?x ?x] |- _ ]
                       => replace (eqb x x) with true
                         in H
                         by (symmetry; change (is_true (eqb x x)); reflexivity)
                   end. } }
      Qed.
    End wf.
  End rel.
End FMapExtensionsWf_fun.

Module FMapExtensionsWf (M: WS) := FMapExtensionsWf_fun M.E M.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Machine- and ABI-dependent layout information for activation records. *)

Require Import Coqlib.
Require Import Memory Separation.
Require Import Bounds.

(** The general shape of activation records is as follows,
  from bottom (lowest offsets) to top:
- Space for outgoing arguments to function calls.
- Back link to parent frame
- Saved values of integer callee-save registers used by the function.
- Saved values of float callee-save registers used by the function.
- Local stack slots.
- Space for the stack-allocated data declared in Cminor
- Return address.
*)

Definition fe_ofs_arg := 0.

(** Computation of the frame environment from the bounds of the current
  function. *)

Definition make_env (b: bounds) : frame_env :=
  let olink := 4 * b.(bound_outgoing) in  (* back link *)
  let ocs := olink + 4 in                 (* callee-saves *)
  let ol :=  align (size_callee_save_area b ocs) 8 in (* locals *)
  let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *)
  let oretaddr := align (ostkdata + b.(bound_stack_data)) 4 in (* return address *)
  let sz := oretaddr + 4 in (* total size *)
  {| fe_size := sz;
     fe_ofs_link := olink;
     fe_ofs_retaddr := oretaddr;
     fe_ofs_local := ol;
     fe_ofs_callee_save := ocs;
     fe_stack_data := ostkdata;
     fe_used_callee_save := b.(used_callee_save) |}.

(** Separation property *)

Local Open Scope sep_scope.

Lemma frame_env_separated:
  forall b sp m P,
  let fe := make_env b in
  m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P ->
  m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b)
       ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b)
       ** range sp (fe_ofs_link fe) (fe_ofs_link fe + 4)
       ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + 4)
       ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe))
       ** P.
Proof.
Local Opaque Z.add Z.mul sepconj range.
  intros; simpl.
  set (olink := 4 * b.(bound_outgoing)).
  set (ocs := olink + 4).
  set (ol :=  align (size_callee_save_area b ocs) 8).
  set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
  set (oretaddr := align (ostkdata + b.(bound_stack_data)) 4).
  generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
  assert (0 <= olink) by (unfold olink; omega).
  assert (olink + 4 <= ocs) by (unfold ocs; omega).
  assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr).
  assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega).
  assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega).
  assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega).
(* Reorder as:
     outgoing
     back link
     callee-save
     local
     retaddr *)
  rewrite sep_swap12.
  rewrite sep_swap23.
  rewrite sep_swap45.
  rewrite sep_swap34.
(* Apply range_split and range_split2 repeatedly *)
  unfold fe_ofs_arg.
  apply range_split. omega.
  apply range_split. omega.
  apply range_split_2. fold ol. omega. omega.
  apply range_drop_right with ostkdata. omega.
  rewrite sep_swap.
  apply range_drop_left with (ostkdata + bound_stack_data b). omega.
  rewrite sep_swap.
  exact H.
Qed.

Lemma frame_env_range:
  forall b,
  let fe := make_env b in
  0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe.
Proof.
  intros; simpl.
  set (olink := 4 * b.(bound_outgoing)).
  set (ocs := olink + 4).
  set (ol :=  align (size_callee_save_area b ocs) 8).
  set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
  set (oretaddr := align (ostkdata + b.(bound_stack_data)) 4).
  generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
  assert (0 <= olink) by (unfold olink; omega).
  assert (olink + 4 <= ocs) by (unfold ocs; omega).
  assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr).
  assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega).
  assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega).
  assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega).
  split. omega. omega.
Qed.

Lemma frame_env_aligned:
  forall b,
  let fe := make_env b in
     (8 | fe_ofs_arg)
  /\ (8 | fe_ofs_local fe)
  /\ (8 | fe_stack_data fe)
  /\ (4 | fe_ofs_link fe)
  /\ (4 | fe_ofs_retaddr fe).
Proof.
  intros; simpl.
  set (olink := 4 * b.(bound_outgoing)).
  set (ocs := olink + 4).
  set (ol :=  align (size_callee_save_area b ocs) 8).
  set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
  set (oretaddr := align (ostkdata + b.(bound_stack_data)) 4).
  split. apply Zdivide_0.
  split. apply align_divides; omega.
  split. apply align_divides; omega.
  split. apply Z.divide_factor_l.
  apply align_divides; omega.
Qed.