(*
(C) Copyright 2010, COQTAIL team

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

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

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

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

(** Properties of real functions sequences. *)

Require Import Rsequence_def.
Require Import Rinterval Ranalysis_def.
Require Import Rsequence_cv_facts.
Require Import Rsequence_tactics.
Require Import MyRIneq.
Require Import Cfunctions.
Require Import Csequence.
Require Import Csequence_facts.
Require Import CFsequence.
Require Import Cnorm.
Require Import Cprop_base.
Require Import Ctacfield.
Require Import Lia.
Require Import Lra.
Require Import Max.
Require Import Cmet.
Require Import Canalysis_def.
Require Import Canalysis_deriv.

Open Scope C_scope.

Lemma CFseq_cvu_derivable : forall (fn fn' : nat -> C -> C) (f g : C -> C) (z c : C) (r : posreal)
      (z_in : Boule c r z),
      (forall (x:C) (n:nat), Boule c r x -> derivable_pt_lim (fn n) x (fn' n x)) ->
      (CFseq_cv_boule fn f c r) ->
      (CFseq_cvu fn' g c r) ->
      (forall (x:C), Boule c r x -> continuity_pt g x) ->
      derivable_pt_lim f z (g z).
Proof.
intros fn fn' f g z c r z_in Dfn_eq_fn' fn_cv_f fn'_cvu_g g_cont eps eps_pos.
 assert (eps_8_pos : 0 < eps / 8) by lra.
 destruct (g_cont z z_in (eps/8)%R eps_8_pos) as [delta1 H] ; clear g_cont ; destruct H as [delta1_pos g_cont].
 assert (delta_pos : 0 < Rmin ((r - (Cnorm (z - c))) / 2) delta1).
  apply Rmin_pos_lt ; [| assumption].
  unfold middle, Rdiv ; apply Rlt_mult_inv_pos ; [| lra].
  apply Rlt_Rminus ; rewrite Cnorm_minus_sym ; apply z_in.

 pose (delta := mkposreal (Rmin ((r - (Cnorm (z - c))) / 2) delta1) (delta_pos)).
 exists delta ; intros h h_neq h_ub.
 pose (eps' :=  ((Cnorm h) * eps / 4)%R).
 assert (eps'_pos : 0 < eps').
  unfold eps', Rdiv ; rewrite Rmult_assoc ; apply Rmult_lt_0_compat ;
  [apply Cnorm_pos_lt ; assumption | lra].
 destruct (fn_cv_f z z_in eps' eps'_pos) as [Nz fnz_cv_fz].

assert (zh_in : Boule c r (z + h)).
 unfold Boule ; simpl ; unfold C_dist.
  unfold Cminus ; rewrite Copp_add_distr ; unfold Cminus ; rewrite <- Cadd_assoc ;
  apply Rle_lt_trans with (Cnorm (c - z) + Cnorm (-h))%R.
  apply Cnorm_triang.
  rewrite Cnorm_opp, Cnorm_minus_sym.
  apply Rlt_le_trans with (Cnorm (z - c) + delta)%R.
  apply Rplus_lt_compat_l ; assumption.
  apply Rle_trans with (Cnorm (z - c) + ((r - (Cnorm (z - c))) / 2))%R.
  apply Rplus_le_compat_l ; unfold delta ; apply Rmin_l.
  apply Rle_trans with ((Cnorm (z - c) + r) / 2)%R.
  right ; field.
  apply Rle_trans with ((r + r) / 2)%R.
  unfold Rdiv ; apply Rmult_le_compat_r ; [lra |] ; apply Rplus_le_compat_r ;
  rewrite Cnorm_minus_sym ; left ; apply z_in.
  right ; field.

 destruct (fn_cv_f (z + h) zh_in eps' eps'_pos) as [Nzh fnzh_cv_fzh] ; clear fn_cv_f.

 destruct (fn'_cvu_g (eps/8)%R eps_8_pos) as [Ng fn'c_cvu_gc] ; clear fn'_cvu_g.

 pose (N := max (max Nz Nzh) Ng).
 assert (Main : Cnorm ((f (z+h) - fn N (z+h)) - (f z - fn N z) + (fn N (z+h) - fn N z - h * (g z))) < (Cnorm h)*eps).
 apply Rle_lt_trans with (Rplus (Cnorm (f (z + h) - fn N (z + h) - (f z - fn N z))) (Cnorm ((fn N (z + h) - fn N z - h * g z)))).
 apply Cnorm_triang.
 apply Rle_lt_trans with (Rplus (Rplus (Cnorm (f (z + h) - fn N (z + h))) (Cnorm (- (f z - fn N z))))
                                                            (Cnorm (fn N (z + h) - fn N z - h * g z))).
 apply Rplus_le_compat_r ; apply Cnorm_triang.
 rewrite Cnorm_opp.

apply Rlt_le_trans with (Rplus (Rplus eps' (Cnorm (f z - fn N z)))  (Cnorm (fn N (z + h) - fn N z - h * g z))).
 do 2 apply Rplus_lt_compat_r ; rewrite Cnorm_minus_sym ; apply fnzh_cv_fzh.
 unfold ge ; apply le_trans with (max Nz Nzh)%nat ; [apply le_max_r | apply le_max_l].

apply Rle_trans with (Rplus (Rplus eps' eps') (Cnorm (fn N (z + h) - fn N z - h * g z))).
 apply Rplus_le_compat_r ; apply Rplus_le_compat_l ; left ; rewrite Cnorm_minus_sym ;
 apply fnz_cv_fz ; unfold ge ; apply le_trans with (max Nz Nzh)%nat ; apply le_max_l.

apply Rle_trans with (Cnorm h * eps / 2 + Cnorm h * eps / 2)%R.
 apply Rle_trans with (Cnorm h * eps / 4 + Cnorm h * eps / 4 + Cnorm h * eps / 2)%R.
 apply Rplus_le_compat_l.

 assert (Interval_to_boule : forall (t: R), interval 0 1 t -> Boule c r (z + t * h)).
  intros t t_in ; unfold Boule ; simpl ; unfold C_dist.
  replace (c - (z + t * h)) with ((c - z) + - (t*h)).
  apply Rle_lt_trans with (Rplus (Cnorm (c - z)) (Cnorm (- (t*h)))) ;
  [apply Cnorm_triang | rewrite Cnorm_opp, Cnorm_Cmult].
  apply Rle_lt_trans with (Rplus (Cnorm (c - z)) (Cnorm h)).
  apply Rplus_le_compat_l ; rewrite <- Rmult_1_l ; apply Rmult_le_compat_r ;
  [apply Cnorm_pos | rewrite Cnorm_IRC_Rabs].
  clear -t_in ; destruct t_in as [t_lb [t_eq | t_ub]].
  left ; apply Rabs_def1 ; [| apply Rlt_le_trans with R0] ; lra.
  subst ; rewrite Rabs_R1 ; right ; reflexivity.
  apply Rlt_le_trans with (Rplus (Cnorm (c - z)) delta) ;
  [apply Rplus_lt_compat_l ; assumption |].
  apply Rle_trans with (Rplus (Cnorm (c - z)) ((r - Cnorm (z - c)) / 2)) ;
  [apply Rplus_le_compat_l ; unfold delta ; apply Rmin_l |].
  rewrite Cnorm_minus_sym.
  field_simplify ; unfold Rdiv; try rewrite Rinv_1, Rmult_1_r.
  unfold Boule in z_in ; simpl in z_in ; unfold C_dist in z_in ;
  left ; rewrite Cnorm_minus_sym ;
 apply (proj2 (middle_is_in_the_middle _ _ z_in)).
 unfold Cminus ; rewrite Copp_add_distr ;
 rewrite Cadd_assoc ; reflexivity.

 assert (fn_deriv : forall t : R, interval 0 1 t -> derivable_pt (fn N) (z + t * h)).
  intros ; exists (fn' N (z + t * h)) ; apply Dfn_eq_fn'.
  apply Interval_to_boule ; assumption.

 destruct (MVT_Cre (fn N) z h fn_deriv h_neq) as [u [u_in_I Hu_bd]].
 destruct (MVT_Cim (fn N) z h fn_deriv h_neq) as [v [v_in_I Hv_bd]].

 apply Rle_trans with (Rmult (Cnorm h) (Rmult (Cnorm (fn N (z + h) - fn N z - h * g z)) (/ Cnorm h))).
 right ; field ; apply Cnorm_no_R0 ; assumption.

 unfold Rdiv ; rewrite Rmult_assoc ; apply Rmult_le_compat_l ;
 [apply Cnorm_pos |] ; rewrite <- Cnorm_inv, <- Cnorm_Cmult ; [| assumption].
 rewrite Cmult_minus_distr_r ; replace (h * g z * / h) with (g z) ; [| field ; assumption].
 rewrite <- Cproj_right with ((fn N (z + h) - fn N z) * / h), <- Cproj_right with (g z).
 apply Rle_trans with (Cnorm (Rminus (Cre ((fn N (z + h) - fn N z) * / h))  (Cre (g z)),
                                                    Rminus (Cim ((fn N (z + h) - fn N z) * / h)) (Cim (g z)))).
  right ; apply Cnorm_eq_compat ; CusingR.

apply Rle_trans with (Rplus (Cnorm ((Cre ((fn N (z + h)%C - fn N z) * / h) - Cre (g z))%R, R0))
        (Cnorm ((R0 , (Cim ((fn N (z + h)%C - fn N z) * / h) - Cim (g z))%R)))).
 apply Rle_trans with (Cnorm (((Cre ((fn N (z + h)%C - fn N z) * / h) - Cre (g z))%R, R0)
   + (R0, (Cim ((fn N (z + h)%C - fn N z) * / h) - Cim (g z))%R))).
  right ; apply Cnorm_eq_compat ; CusingR.
  apply Cnorm_triang.
 rewrite Cnorm_Cre_simpl, Cnorm_Cim_simpl.
 unfold Cdiv in Hu_bd, Hv_bd ; rewrite Hu_bd, Hv_bd.

apply Rle_trans with (eps/4 + Rabs (Cim (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I)) - Cim (g z)))%R.
apply Rplus_le_compat_r.
apply Rle_trans with (Rabs ((Cre (derive_pt (fn N) (z + u * h) (fn_deriv u u_in_I)) - Cre (g (z + u * h)))
                                                      +  (Cre (g (z + u * h)) - Cre (g z)))).
 right ; apply Rabs_eq_compat ; ring.
 apply Rle_trans with (Rplus (Rabs (Cre (derive_pt (fn N) (z + u * h) (fn_deriv u u_in_I)) - Cre (g (z + u * h))))
                                (Rabs (Cre (g (z + u * h)) - Cre (g z)))) ; [apply Rabs_triang |].
 do 2 rewrite Cre_minus_compat.
 apply Rle_trans with (Rplus (Cnorm (derive_pt (fn N) (z + u * h) (fn_deriv u u_in_I) - g (z + u * h)))
                                (Rabs (Cre (g (z + u * h) - g z)))).
 apply Rplus_le_compat_r ; apply Cre_le_Cnorm.
 apply Rle_trans with (Rplus (Cnorm (derive_pt (fn N) (z + u * h) (fn_deriv u u_in_I) - g (z + u * h)))
                                (Cnorm (g (z + u * h) - g z))).
 apply Rplus_le_compat_l ; apply Cre_le_Cnorm.

apply Rle_trans with (Rplus (eps / 8) (Cnorm (g (z + u * h) - g z))).
apply Rplus_le_compat_r.

assert (zuh_in : Boule c r (z + u *h)).
 apply Interval_to_boule ; assumption.
 rewrite (derive_pt_eq_0 _ _ _ (fn_deriv u u_in_I) (Dfn_eq_fn' _ N zuh_in)).
 unfold C_dist in fn'c_cvu_gc ; left ; apply fn'c_cvu_gc ;
 [unfold N ; apply le_max_r |] ; assumption.

apply Rle_trans with (eps / 8 + eps / 8)%R ; [apply Rplus_le_compat_l | right ; field].

destruct (proj1 u_in_I) as [u_neq | u_eq].

left ; simpl in g_cont ; unfold C_dist in g_cont ; apply g_cont ; split.
unfold Cderiv.D_x, no_cond ; split ; [trivial |].
 clear - u_neq h_neq.
 intro Hf ; symmetry in Hf ; generalize Hf ; clear Hf ; apply Cadd_neq_compat_l.
 apply  Cmult_integral_contrapositive_currified ;
 [apply IRC_neq_compat ; apply Rgt_not_eq |] ; assumption.

 replace (z + u * h - z) with (u * h).
 rewrite Cnorm_Cmult ; apply Rlt_le_trans with (1 * delta)%R.
 apply Rlt_le_trans with (Cnorm u * delta)%R.
 apply Rmult_lt_compat_l ; [apply Cnorm_pos_lt ; apply IRC_neq_compat ;
 apply Rgt_not_eq |] ; assumption.
 apply Rmult_le_compat_r ; [left ; assumption |].
 rewrite Cnorm_IRC_Rabs.
  clear -u_in_I ; destruct u_in_I as [u_lb [u_eq | u_ub]].
  left ; apply Rabs_def1 ; [| apply Rlt_le_trans with R0] ; lra.
  subst ; rewrite Rabs_R1 ; right ; reflexivity.
  rewrite Rmult_1_l ; unfold delta ; apply Rmin_r.

 ring.

subst ; rewrite Cmult_0_l, Cadd_0_r ; unfold Cminus ; rewrite Cadd_opp_r, Cnorm_C0 ;
 left ; assumption.

apply Rle_trans with (eps / 4 +  eps/4)%R ; [apply Rplus_le_compat_l | right ; field].

apply Rle_trans with (Rabs ((Cim (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I)) - Cim (g (z + v * h)))
                                                      +  (Cim (g (z + v * h)) - Cim (g z)))).
 right ; apply Rabs_eq_compat ; ring.
 apply Rle_trans with (Rplus (Rabs (Cim (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I)) - Cim (g (z + v * h))))
                                (Rabs (Cim (g (z + v * h)) - Cim (g z)))) ; [apply Rabs_triang |].
 do 2 rewrite Cim_minus_compat.
 apply Rle_trans with (Rplus (Cnorm (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I) - g (z + v * h)))
                                (Rabs (Cim (g (z + v * h) - g z)))).
 apply Rplus_le_compat_r ; apply Cim_le_Cnorm.
 apply Rle_trans with (Rplus (Cnorm (derive_pt (fn N) (z + v * h) (fn_deriv v v_in_I) - g (z + v * h)))
                                (Cnorm (g (z + v * h) - g z))).
 apply Rplus_le_compat_l ; apply Cim_le_Cnorm.

apply Rle_trans with (Rplus (eps / 8) (Cnorm (g (z + v * h) - g z))).
apply Rplus_le_compat_r.

assert (zvh_in : Boule c r (z + v *h)).
 apply Interval_to_boule ; assumption.
 rewrite (derive_pt_eq_0 _ _ _ (fn_deriv v v_in_I) (Dfn_eq_fn' _ N zvh_in)).
 unfold C_dist in fn'c_cvu_gc ; left ; apply fn'c_cvu_gc ;
 [unfold N ; apply le_max_r |] ; assumption.

apply Rle_trans with (eps / 8 + eps / 8)%R ; [apply Rplus_le_compat_l | right ; field].

destruct (proj1 v_in_I) as [v_neq | v_eq].

left ; simpl in g_cont ; unfold C_dist in g_cont ; apply g_cont ; split.
unfold Cderiv.D_x, no_cond ; split ; [trivial |].
 clear - v_neq h_neq.
 intro Hf ; symmetry in Hf ; generalize Hf ; clear Hf ; apply Cadd_neq_compat_l.
 apply  Cmult_integral_contrapositive_currified ;
 [apply IRC_neq_compat ; apply Rgt_not_eq |] ; assumption.

 replace (z + v * h - z) with (v * h).
 rewrite Cnorm_Cmult ; apply Rlt_le_trans with (1 * delta)%R.
 apply Rlt_le_trans with (Cnorm v * delta)%R.
 apply Rmult_lt_compat_l ; [apply Cnorm_pos_lt ; apply IRC_neq_compat ;
 apply Rgt_not_eq |] ; assumption.
 apply Rmult_le_compat_r ; [left ; assumption |].
 rewrite Cnorm_IRC_Rabs.
  clear -v_in_I ; destruct v_in_I as [v_lb [v_eq | v_ub]].
  left ; apply Rabs_def1 ; [| apply Rlt_le_trans with R0] ; lra.
  subst ; rewrite Rabs_R1 ; right ; reflexivity.
  rewrite Rmult_1_l ; unfold delta ; apply Rmin_r.

 ring.

subst ; rewrite Cmult_0_l, Cadd_0_r ; unfold Cminus ; rewrite Cadd_opp_r, Cnorm_C0 ;
 left ; assumption.

right ; field.
right ; field.

apply Rle_lt_trans with (Rmult (Cnorm ((f (z + h)  - f z) - h * g z)) (/ Cnorm h)).
rewrite <- Cnorm_inv, <- Cnorm_Cmult ; [| assumption] ; right ; apply Cnorm_eq_compat ;
 field ; assumption.

apply Rle_lt_trans with (Rmult (Cnorm (f (z + h) - fn N (z + h) - (f z - fn N z) +
          (fn N (z + h) - fn N z - h * g z))) (/ Cnorm h)).
right ; apply Rmult_eq_compat_r ; apply Cnorm_eq_compat ; ring.

apply Rlt_le_trans with ((Cnorm h * eps) * / Cnorm h)%R.
apply Rmult_lt_compat_r ; [rewrite <- Cnorm_inv ; [apply Cnorm_pos_lt ;
 apply Cinv_neq_0_compat |] |] ; assumption.

 right ; field ; apply Cnorm_no_R0 ; assumption.
Qed.

Definition SFL_interv : forall (fn:nat -> C -> C) (r:posreal)
  (cv : forall z : C, Boule 0 r z -> {l:C | Cseq_cv (fun N:nat => CFpartial_sum (fun n => fn n z) N) l }) (y:C), C.
Proof.
intros fn r cv z.
 destruct (Rlt_le_dec (Cnorm (0 - z)) r) as [z_bd | z_lb].
 unfold Boule in cv ; simpl in cv ; unfold C_dist in cv ;
 destruct (cv _ z_bd) as (l, _) ; apply l.
 exact 0.
Defined.

Lemma SFL_interv_right : forall fn r cv y, Boule 0 r y ->
     Cseq_cv (fun N:nat => CFpartial_sum (fun n => fn n y) N) (SFL_interv fn r cv y).
Proof.
intros fn r cv z z_bd ; unfold SFL_interv ;
 destruct (Rlt_le_dec (Cnorm (0 - z)) r) as [z_bd2 | z_lb].
 destruct (cv z z_bd2) as [l Hl] ; assumption.
 assert (Hf : Cnorm (0 - z) < Cnorm (0 - z)).
  apply Rlt_le_trans with r ; unfold Boule in * ; assumption.
 elim (Rlt_irrefl _ Hf).
Qed.

Lemma Rlt_minus_exchange : forall a b c, a - b < c -> a - c < b.
Proof.
intros a b c H ; lra.
Qed.

Lemma Rlt_plus_exchange : forall a b c,  a - b < c  -> a < b + c.
Proof.
intros a b c H ; lra.
Qed.

Lemma sum_cv_maj : forall (An : nat -> R) (fn : nat -> C -> C) (z l1 : C) (l2 : R),
       Cseq_cv (fun n : nat => CFpartial_sum (fun n => fn n z) n) l1 ->
       Rseq_cv (fun n : nat => sum_f_R0 An n) l2 ->
       (forall n : nat, Cnorm (fn n z) <= An n) -> Cnorm l1 <= l2.
Proof.
intros An fn z l1 l2 fn_cv An_cv fn_bd.
 destruct (Rle_lt_dec (Cnorm l1) l2) as [H | Hf].
  assumption.
  pose (eps := ((Cnorm l1 - l2) / 4)%R) ;
  assert (eps_pos : 0 < eps).
   unfold eps, Rdiv ; apply Rlt_mult_inv_pos ; lra.
  destruct (fn_cv _ eps_pos) as [Nfn Hfn] ;
  destruct (An_cv _ eps_pos) as [NAn HAn].
  pose (N := max Nfn NAn).
  assert (Main : Cnorm l1 - eps < l2 + eps).
   apply Rlt_trans with (Cnorm (CFpartial_sum (fun n : nat => fn n z) N)).
   apply Rlt_minus_exchange ; apply Rle_lt_trans with (Cnorm (CFpartial_sum (fun n : nat => fn n z) N - l1)) ;
   [apply Cnorm_triang_rev_r | apply Hfn ;  apply le_max_l].
   apply Rle_lt_trans with (Rabs (sum_f_R0 An N)).
   apply Rle_trans with (sum_f_R0 (fun n => Cnorm (fn n z)) N).
   unfold CFpartial_sum ; apply sum_f_C0_triang.
   clear - fn_bd ; induction N.
   simpl ; rewrite Rabs_right ; [| apply Rle_ge ; apply Rle_trans with (Cnorm (fn O z)) ;
   [apply Cnorm_pos |] ] ; apply fn_bd.
   simpl ; rewrite Rabs_right.
   apply Rle_trans with (Rplus (sum_f_R0 An N) (Cnorm (fn (S N) z))) ;
   [apply Rplus_le_compat_r ; rewrite <- Rabs_right ; [apply IHN |] |
   apply Rplus_le_compat_l ; apply fn_bd].
   apply Rle_ge ; apply cond_pos_sum.
   intro n ; apply Rle_trans with (Cnorm (fn n z)) ; [apply Cnorm_pos | apply fn_bd].
   rewrite <- tech5 ; apply Rle_ge ; apply cond_pos_sum.
   intro n ; apply Rle_trans with (Cnorm (fn n z)) ; [apply Cnorm_pos | apply fn_bd].
   apply Rlt_plus_exchange.
   apply Rle_lt_trans with (R_dist (sum_f_R0 An N) l2).
   apply Rle_trans with (Rminus (Rabs (sum_f_R0 An N)) (Rabs l2)).
   replace (Rabs l2) with l2.
   right ; reflexivity.
   symmetry ; apply Rabs_right.
   apply Rle_ge ; apply Rseq_limit_comparison with (fun _ => R0)  (fun n : nat => sum_f_R0 An n).
   intros n ; apply cond_pos_sum ; intro n' ; apply Rle_trans with (Cnorm (fn n' z)) ;
   [apply Cnorm_pos | apply fn_bd].
   intros ; exists O ; intros ; simpl ; unfold R_dist . rewrite Rminus_0_r.
   change R0 with (IZR 0). rewrite Rabs_R0 ; assumption.
   assumption.
   unfold R_dist ; apply Rabs_triang_inv.
   apply HAn ; apply le_max_r.
   assert (Cnorm l1 < Cnorm l1).
   apply Rlt_trans with (l2 + 2 * eps)%R.
   lra.
   unfold eps.
   apply Rle_lt_trans with ((Cnorm l1 + l2) / 2)%R.
   right ; field.
   rewrite Rplus_comm ; apply (middle_is_in_the_middle _ _ Hf).
   elim (Rlt_irrefl _ H).
Qed.

Definition Csigma f low high := sum_f_C0 (fun n : nat => f (low + n)%nat) (high - low).

Lemma   Csigma_split : forall (f : nat -> C) (low high k : nat),
       (low <= k)%nat ->  (k < high)%nat ->
       Csigma f low high = (Csigma f low k + Csigma f (S k) high).
Proof.
intros f low high k l_le_k k_lt_h.
 unfold Csigma.
 apply (proj1 (Ceq _ _)) ; split.
 rewrite <- Cre_add_compat ; do 3 rewrite <- sum_f_C0_Cre_compat.
 assert (H := sigma_split (fun n => Cre (f n))  l_le_k k_lt_h) ;
 unfold sigma in H ; assumption.
 rewrite <- Cim_add_compat ; do 3 rewrite <- sum_f_C0_Cim_compat.
 assert (H := sigma_split (fun n => Cim (f n))  l_le_k k_lt_h) ;
 unfold sigma in H ; assumption.
Qed.

Lemma sum_maj1 : forall (fn : nat -> C -> C) (An : nat -> R) (x l1: C) (l2 : R) (N : nat),
       Cseq_cv (fun n : nat => CFpartial_sum (fun n => fn n x) n) l1 ->
       Rseq_cv (fun n : nat => sum_f_R0 An n) l2 ->
       (forall n : nat, Cnorm (fn n x) <= An n) ->
       Cnorm (l1 - CFpartial_sum (fun n => fn n x) N) <= l2 - sum_f_R0 An N.
Proof.
  intros fn An x l1 l2 N fn_cv An_cv fn_bd ;
    cut { l:C | Cseq_cv (fun n => sum_f_C0 (fun l => fn (S N + l)%nat x) n) l }.
  intro X;
    cut { l:R | Rseq_cv (fun n => sum_f_R0 (fun l => An (S N + l)%nat) n) l }.
  intro X0; elim X; intros l1N H2.
  elim X0; intros l2N H3.
  cut (l1 - CFpartial_sum (fun n => fn n x) N = l1N).
  intro Temp; cut (Rminus l2 (sum_f_R0 An N) = l2N).
  intro Temp2; rewrite Temp, Temp2.
  apply sum_cv_maj with (fun n => An (S N + n)%nat) (fun I => fn (S N + I)%nat) x.
  assumption.
  assumption.
  intro n ; apply fn_bd.
  symmetry ; eapply Rseq_cv_unique.
  apply H3.
  unfold Rseq_cv in An_cv |-* ; intros eps eps_pos ; destruct (An_cv _ eps_pos)
  as [N' HN'] ; exists N' ; intros n n_lb.
  unfold R_dist ;
    replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))%R
    with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2)%R;
      [| ring ].
  replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n)%R with
  (sum_f_R0 An (S (N + n)))%R.
  apply HN' ; intuition lia.
  assert (N_pos : (0 <= N)%nat) by intuition.
  assert (N_ub : (N < S (N + n))%nat) by intuition.
  intros; assert (H := sigma_split An N_pos N_ub) ; unfold sigma in H.
  do 2 rewrite <- minus_n_O in H.
  replace (sum_f_R0 An (S (N + n))) with
  (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
  replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
  assert (Hrew : (S (N + n) - S N)%nat = n) by intuition lia.
  rewrite Hrew in H.
  apply H.
  apply sum_eq; intros ;  reflexivity.
  apply sum_eq; intros ;  reflexivity.
  symmetry ; eapply Cseq_cv_unique.
  apply H2.
  unfold Rseq_cv in fn_cv |-* ; intros eps eps_pos ; destruct (fn_cv _ eps_pos)
  as [N' HN'] ; exists N' ; intros n n_lb.
  unfold R_dist ;
    replace (sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n - (l1 -  CFpartial_sum (fun n0 : nat => fn n0 x) N))
    with ((CFpartial_sum (fun n0 : nat => fn n0 x) N + sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n) - l1);
      [| ring ].
      replace ((CFpartial_sum (fun n0 : nat => fn n0 x) N + sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n))
      with (CFpartial_sum (fun n0 : nat => fn n0 x) (S N + n)%nat).
  apply HN' ; intuition lia.
  assert (N_pos : (0 <= N)%nat) by intuition.
  assert (N_ub : (N < S (N + n))%nat) by intuition.
  intros; assert (H := Csigma_split (fun n => fn n x) O (S (N + n)) N N_pos N_ub) ; unfold Csigma in H.
  do 2 rewrite <- minus_n_O in H.
  replace (CFpartial_sum (fun n0 : nat => fn n0 x) (S N + n)) with
  (sum_f_C0 (fun n : nat => fn (0 + n)%nat x) (S (N + n))).
  replace (CFpartial_sum (fun n0 : nat => fn n0 x) N) with (sum_f_C0 (fun n : nat => fn (0 + n)%nat x) N).
  assert (Hrew : (S (N + n) - S N)%nat = n) by intuition lia.
  rewrite Hrew in H.
  apply H.
  unfold CFpartial_sum ; apply sum_f_C0_eq_seq ; intros ;  reflexivity.
  unfold CFpartial_sum ; apply sum_f_C0_eq_seq ; intros ;  reflexivity.

  exists (l2 - sum_f_R0 An N)%R.
   unfold Rseq_cv in An_cv |-* ; intros eps eps_pos ; destruct (An_cv _ eps_pos)
  as [N' HN'] ; exists N' ; intros n n_lb.
  unfold R_dist ;
    replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))%R
    with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2)%R;
      [| ring ].
  replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n)%R with
  (sum_f_R0 An (S (N + n)))%R.
  apply HN' ; intuition lia.
  assert (N_pos : (0 <= N)%nat) by intuition.
  assert (N_ub : (N < S (N + n))%nat) by intuition.
  intros; assert (H := sigma_split An N_pos N_ub) ; unfold sigma in H.
  do 2 rewrite <- minus_n_O in H.
  replace (sum_f_R0 An (S (N + n))) with
  (sum_f_R0 (fun k:nat => An (0 + k)%nat) (S (N + n))).
  replace (sum_f_R0 An N) with (sum_f_R0 (fun k:nat => An (0 + k)%nat) N).
  assert (Hrew : (S (N + n) - S N)%nat = n) by intuition lia.
  rewrite Hrew in H.
  apply H.
  apply sum_eq; intros ;  reflexivity.
  apply sum_eq; intros ;  reflexivity.

  exists (l1 - CFpartial_sum (fun n => fn n x) N).

 intros eps eps_pos ; destruct (fn_cv _ eps_pos) as [N' HN'] ; exists N' ; intros n n_lb.

    replace (sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n - (l1 -  CFpartial_sum (fun n0 : nat => fn n0 x) N))
    with ((CFpartial_sum (fun n0 : nat => fn n0 x) N + sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n) - l1);
      [| ring ].
      replace ((CFpartial_sum (fun n0 : nat => fn n0 x) N + sum_f_C0 (fun l:nat => fn (S N + l)%nat x) n))
      with (CFpartial_sum (fun n0 : nat => fn n0 x) (S N + n)%nat).
  apply HN' ; intuition lia.
  assert (N_pos : (0 <= N)%nat) by intuition.
  assert (N_ub : (N < S (N + n))%nat) by intuition.
  intros; assert (H := Csigma_split (fun n => fn n x) O (S (N + n)) N N_pos N_ub) ; unfold Csigma in H.
  do 2 rewrite <- minus_n_O in H.
  replace (CFpartial_sum (fun n0 : nat => fn n0 x) (S N + n)) with
  (sum_f_C0 (fun n : nat => fn (0 + n)%nat x) (S (N + n))).
  replace (CFpartial_sum (fun n0 : nat => fn n0 x) N) with (sum_f_C0 (fun n : nat => fn (0 + n)%nat x) N).
  assert (Hrew : (S (N + n) - S N)%nat = n) by intuition lia.
  rewrite Hrew in H.
  apply H.
  unfold CFpartial_sum ; apply sum_f_C0_eq_seq ; intros ;  reflexivity.
  unfold CFpartial_sum ; apply sum_f_C0_eq_seq ; intros ;  reflexivity.
Qed.

Lemma CVN_CVU_boule :forall (fn : nat -> C -> C) (r : posreal)
       (cv : forall z : C,  Boule 0 r z -> {l : C | Cseq_cv (fun N : nat => CFpartial_sum (fun n => fn n z) N) l}),
       CVN_r fn r ->
       CFseq_cvu (fun N  z => CFpartial_sum (fun n => fn n z) N) (SFL_interv fn r cv) 0 r.
Proof.
intros fn r cv cvn eps eps_pos.

 destruct cvn as [An [l [sum_cv fn_bd]]] ;
 destruct (sum_cv eps eps_pos) as [N HN] ;
 exists N ; intros n y n_lb y_bd.
 unfold SFL_interv.
 destruct (Rlt_le_dec (Cnorm (0 - y)) r) as [y_bd2 | y_lb].

  destruct (cv y y_bd2) as [l2 Hl2] ; unfold C_dist.

 apply Rle_lt_trans with (Rabs (sum_f_R0 (fun k => Cnorm (An k)) n - l)).
  rewrite <- (Rabs_Ropp (sum_f_R0 (fun k:nat => Cnorm (An k)) n - l));
    rewrite Ropp_minus_distr';
      rewrite (Rabs_right (l - sum_f_R0 (fun k:nat => Cnorm (An k)) n)).
  rewrite Cnorm_minus_sym ; eapply sum_maj1.
  apply Hl2.
  apply sum_cv.
  intros ; apply fn_bd ; assumption.
  apply Rge_minus ; apply Rle_ge ; apply sum_incr.
  assumption.
  intros ; apply Cnorm_pos.
  unfold R_dist in HN ; apply HN ; assumption.

unfold Boule in y_bd ; simpl in y_bd ; unfold C_dist in y_bd.
 assert (Hf : Cnorm (0 - y) < Cnorm (0 - y)).
  apply Rlt_le_trans with r ; assumption.
 destruct (Rlt_irrefl _ Hf).
Qed.

Lemma CVU_continuity_boule :forall (fn : nat -> C -> C) (f : C -> C) (c : C) (r : posreal),
       CFseq_cvu fn f c r ->
       (forall n z, Boule c r z -> continuity_pt (fn n) z) ->
       forall z, Boule c r z -> continuity_pt f z.
Proof.
intros fn f c r fn_cvu fn_cont z z_in.
 intros eps eps_pos ; assert (eps_3_pos : 0 < (eps / 3)%R) by lra ;
 destruct (fn_cvu _ eps_3_pos) as [N HN] ;
 destruct (fn_cont N z z_in _ eps_3_pos) as [delta1 [delta1_pos Hdelta]].
 pose (delta := Rmin delta1 ((r - Cnorm (c - z))/2)) ;
 assert (delta_pos : 0 < delta).
  unfold delta ; apply Rmin_pos_lt.
  assumption.
  unfold Rdiv ; apply Rlt_mult_inv_pos ; [apply Rlt_Rminus ; apply z_in | lra].
  exists delta ; split ; [assumption | intros x [_  Hx]].
  simpl ; unfold C_dist.
  apply Rle_lt_trans with (Cnorm (f x - fn N x) + Cnorm (fn N x - fn N z) + Cnorm (fn N z  - f z))%R.
  replace (f x - f z)%C with ((f x - fn N x) + (fn N x - fn N z) + (fn N z - f z))%C by ring.
  apply Rle_trans with (Cnorm ((f x - fn N x) + (fn N x - fn N z)) + Cnorm (fn N z - f z))%R ;
  [| apply Rplus_le_compat_r] ;  apply Cnorm_triang.
  apply Rlt_trans with (Cnorm (f x - fn N x) + Cnorm (fn N x - fn N z) + (eps/3))%R.
  apply Rplus_lt_compat_l ; apply HN ; trivial.
  apply Rlt_trans with (eps/3 + Cnorm (fn N x - fn N z) + eps / 3)%R.
  do 2 apply Rplus_lt_compat_r ; rewrite Cnorm_minus_sym ; apply HN ; trivial.
 unfold Boule in * ; simpl in * ; unfold C_dist in *.
 replace (c - x)%C with ((c - z) + - (x - z))%C by ring.
 apply Rle_lt_trans with (Cnorm (c - z) + Cnorm (- (x - z)))%R ;
 [apply Cnorm_triang | rewrite Cnorm_opp].
 apply Rlt_trans with (Cnorm (c - z) + delta)%R ;
 [apply Rplus_lt_compat_l ; assumption |].
 apply Rle_lt_trans with (Cnorm (c - z) +  (r - Cnorm (c - z))/2)%R ;
 [apply Rplus_le_compat_l ; apply Rmin_r |].
 field_simplify ; unfold Rdiv ; try rewrite Rinv_1, Rmult_1_r.
 apply (middle_is_in_the_middle _ _ z_in).
 destruct (Ceq_dec x z) as [eq | neq].
 subst ; unfold Cminus ; rewrite Cadd_opp_r, Cnorm_C0 ; lra.
 apply Rlt_le_trans with (eps/3 + eps/3 + eps/3)%R ; [| right ; field].
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l ; simpl in Hdelta ; apply Hdelta ; split.
 unfold Cderiv.D_x, no_cond ; split ; auto.
 apply Rlt_le_trans with delta ; [apply Hx | unfold delta ; apply Rmin_l].
Qed.


(* 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.
 *)
(* ZMod.v, by Vince Barany *)

Require Export CoRN.model.Zmod.ZGcd.

(**
* Working modulo a positive number over Z
** Facts on `mod'
*)

Section zmod.

Definition Zmod_same := Z_mod_same.

Lemma Zmod_zero_lft : forall m : Z, (0 mod m)%Z = 0%Z.
Proof.
 intro m.
 case m; auto.
Qed.

Lemma Zmod_zero_rht : forall a : Z, (a mod 0)%Z =
ltac:(match eval hnf in (1 mod 0) with | 0 => exact 0%Z | _ => exact a end).
Proof.
 intro a.
 case a; auto.
Qed.

Lemma Zmod_Zmod :
 forall m a : Z, (m > 0)%Z -> ((a mod m) mod m)%Z = (a mod m)%Z.
Proof.
 intros m a Hm.
 apply (Zdiv_remainder_unique (a mod m) m (a mod m / m) ((a mod m) mod m) 0 (a mod m)).
    rewrite Zmult_comm.
    apply Z_div_mod_eq_full.
   apply Z_mod_lt; auto.
  auto with zarith.
 apply Z_mod_lt; auto.
Qed.

Lemma Zmod_cancel_multiple :
 forall m a b : Z, (m > 0)%Z -> ((b * m + a) mod m)%Z = (a mod m)%Z.
Proof.
 intros m a b Hm.
 rewrite Zplus_comm.
 apply Z_mod_plus.
 exact Hm.
Qed.

Lemma Zmod_multiple : forall m a : Z, (m > 0)%Z -> ((a * m) mod m)%Z = 0%Z.
Proof.
 intros m a Hm.
 rewrite <- (Zplus_0_r (a * m)).
 rewrite Zmod_cancel_multiple; auto.
Qed.

Lemma Zmod_minus_intro :
 forall m a b : Z,
 (m > 0)%Z -> ((a - b) mod m)%Z = 0%Z -> (a mod m)%Z = (b mod m)%Z.
Proof.
 intros m a b Hm H0.
 assert (Hdiv : Zdivides m (a - b)); auto with zarith.
 elim Hdiv; intros q Hq.
 replace a with (q * m + b)%Z; auto with zarith.
 apply Zmod_cancel_multiple.
 assumption.
Qed.

Lemma Zmod_plus_compat :
 forall m a b : Z,
 (m > 0)%Z -> ((a + b) mod m)%Z = ((a mod m + b mod m) mod m)%Z.
Proof.
 intros m a b Hm.
 rewrite <- (Zmod_Zmod m (a + b) Hm).
 apply Zmod_minus_intro.
  exact Hm.
 apply Zmod0_Zdivides.
  auto with zarith.
 replace (a mod m)%Z with (a - m * (a / m))%Z.
  replace (b mod m)%Z with (b - m * (b / m))%Z.
   replace ((a + b) mod m)%Z with (a + b - m * ((a + b) / m))%Z.
    unfold Zminus in |- *; repeat rewrite Zplus_assoc.
    repeat rewrite Zopp_plus_distr; repeat rewrite Z.opp_involutive.
    rewrite (Zplus_comm (a + b) (- (m * ((a + b) / m)))).
    repeat rewrite <- Zplus_assoc.
    apply Zdivides_plus_elim.
     auto with zarith.
    rewrite (Zplus_assoc (m * (a / m)) (- b) (m * (b / m))).
    rewrite (Zplus_comm (m * (a / m)) (- b)).
    rewrite <- (Zplus_assoc (- b) (m * (a / m)) (m * (b / m))).
    rewrite (Zplus_assoc (- a) (- b) (m * (a / m) + m * (b / m))).
    rewrite <- Zopp_plus_distr.
    repeat rewrite Zplus_assoc.
    rewrite Zplus_opp_r.
    auto with zarith.
   generalize (Z_div_mod_eq_full (a + b) m); auto with zarith.
  generalize (Z_div_mod_eq_full b m); auto with zarith.
 generalize (Z_div_mod_eq_full a m); auto with zarith.
Qed.

Lemma Zmod_plus_compat_rht :
 forall m a b : Z, (m > 0)%Z -> ((a + b) mod m)%Z = ((a + b mod m) mod m)%Z.
Proof.
 intros m a b Hm.
 rewrite (Zmod_plus_compat m a b Hm).
 rewrite <- (Zmod_Zmod m (a + b mod m) Hm).
 rewrite (Zmod_plus_compat m a (b mod m) Hm).
 rewrite Zmod_Zmod; auto.
 rewrite Zmod_Zmod; auto.
Qed.

Lemma Zmod_plus_compat_lft :
 forall m a b : Z, (m > 0)%Z -> ((a + b) mod m)%Z = ((a mod m + b) mod m)%Z.
Proof.
 intros m a b Hm.
 rewrite (Zplus_comm a b).
 rewrite (Zplus_comm (a mod m) b).
 apply Zmod_plus_compat_rht.
 auto.
Qed.

Lemma Zmod_opp_elim :
 forall m a : Z, (m > 0)%Z -> (- a mod m)%Z = ((m - a mod m) mod m)%Z.
Proof.
 intros m a Hm.
 apply Zmod_minus_intro.
  exact Hm.
 replace (- a - (m - a mod m))%Z with (- m + (a mod m - a))%Z; auto with zarith.
 replace (- m)%Z with (-1 * m)%Z; auto with zarith.
 rewrite Zmod_cancel_multiple; auto.
 replace (a mod m - a)%Z with (- (a / m) * m)%Z; auto with zarith.
 generalize (Z_div_mod_eq_full a m).
 set (q := (a / m)%Z); set (r := (a mod m)%Z); intro Ha; rewrite Ha.
 rewrite Zplus_comm; unfold Zminus in |- *; rewrite Zopp_plus_distr;
   rewrite Zplus_assoc; rewrite Zplus_opp_r; rewrite Zplus_0_l;
     rewrite Zopp_mult_distr_l_reverse; rewrite Zmult_comm; reflexivity.
Qed.

Lemma Zmod_minus_elim :
 forall m a b : Z,
 (m > 0)%Z -> (a mod m)%Z = (b mod m)%Z -> ((a - b) mod m)%Z = 0%Z.
Proof.
 intros m a b Hm Heq.
 unfold Zminus in |- *.
 rewrite (Zmod_plus_compat m a (- b) Hm).
 rewrite Heq.
 rewrite Zmod_opp_elim; auto.
 rewrite <- (Zmod_plus_compat m b (m - b mod m) Hm).
 unfold Zminus in |- *.
 rewrite Zplus_assoc.
 rewrite (Zplus_comm b m).
 rewrite <- Zplus_assoc.
 fold (b - b mod m)%Z in |- *.
 replace (b - b mod m)%Z with (b / m * m)%Z.
  rewrite Zplus_comm.
  rewrite Zmod_cancel_multiple; auto.
  apply Zmod_same; auto.
 set (q := (b / m)%Z); set (r := (b mod m)%Z).
 rewrite (Z_div_mod_eq_full b m).
 fold q in |- *; fold r in |- *.
 rewrite Zmult_comm.
 unfold Zminus in |- *.
 rewrite <- Zplus_assoc.
 rewrite Zplus_opp_r.
 auto with zarith.
Qed.

Lemma Zmod_mult_compat :
 forall m a b : Z,
 (m > 0)%Z -> ((a * b) mod m)%Z = ((a mod m * (b mod m)) mod m)%Z.
Proof.
 intros m a b Hm.
 rewrite <- (Zmod_Zmod m (a * b) Hm).
 apply Zmod_minus_intro; auto.
 apply Zmod0_Zdivides.
  auto with zarith.
 replace (a mod m)%Z with (a - m * (a / m))%Z.
  replace (b mod m)%Z with (b - m * (b / m))%Z.
   replace ((a * b) mod m)%Z with (a * b - m * (a * b / m))%Z.
    unfold Zminus in |- *; repeat rewrite Zplus_assoc.
    repeat rewrite Zmult_plus_distr_l.
    repeat rewrite Zmult_plus_distr_r.
    repeat rewrite Zopp_plus_distr; repeat rewrite Z.opp_involutive.
    rewrite (Zplus_comm (a * b)).
    repeat rewrite <- Zplus_assoc.
    apply Zdivides_plus_elim.
     auto with zarith.
    repeat rewrite Zplus_assoc.
    rewrite Zplus_opp_r.
    repeat rewrite Zopp_mult_distr_l_reverse; repeat rewrite Zopp_mult_distr_r;
      repeat rewrite Z.opp_involutive.
    simpl in |- *.
    apply Zdivides_plus_elim; auto with zarith.
   generalize (Z_div_mod_eq_full (a * b) m); auto with zarith.
  generalize (Z_div_mod_eq_full b m); auto with zarith.
 generalize (Z_div_mod_eq_full a m); auto with zarith.
Qed.

Lemma Zmod_mult_compat_rht :
 forall m a b : Z, (m > 0)%Z -> ((a * b) mod m)%Z = ((a * (b mod m)) mod m)%Z.
Proof.
 intros m a b Hm.
 rewrite (Zmod_mult_compat m a b Hm).
 rewrite <- (Zmod_Zmod m (a * (b mod m)) Hm).
 rewrite (Zmod_mult_compat m a (b mod m) Hm).
 rewrite Zmod_Zmod; auto.
 rewrite Zmod_Zmod; auto.
Qed.

Lemma Zmod_mult_compat_lft :
 forall m a b : Z, (m > 0)%Z -> ((a * b) mod m)%Z = ((a mod m * b) mod m)%Z.
Proof.
 intros m a b Hm.
 rewrite (Zmult_comm a b).
 rewrite (Zmult_comm (a mod m) b).
 apply Zmod_mult_compat_rht.
 auto.
Qed.

Lemma Zmod_mult_elim_lft :
 forall m a b c : Z,
 (m > 0)%Z ->
 Zrelprime a m ->
 ((a * b) mod m)%Z = ((a * c) mod m)%Z -> (b mod m)%Z = (c mod m)%Z.
Proof.
 intros m a b c Hm Hrelprime Hmulteq.
 assert (Hm0 : m <> 0%Z); auto with zarith.
 generalize (Zdivides_Zmod0 _ _ Hm0 (Zmod_minus_elim m _ _ Hm Hmulteq)); intro Hdiv.
 rewrite (Zmult_comm a b) in Hdiv; rewrite (Zmult_comm a c) in Hdiv;
   rewrite <- BinInt.Zmult_minus_distr_r in Hdiv.
 apply Zmod_minus_intro; auto.
 apply Zmod0_Zdivides. auto with zarith.
  apply (Zrelprime_div_mult_intro m a (b - c)).
  apply Zrelprime_symm; assumption.
 rewrite Zmult_comm; assumption.
Qed.

Lemma Zmod_mult_elim_rht :
 forall m a b c : Z,
 (m > 0)%Z ->
 Zrelprime a m ->
 ((b * a) mod m)%Z = ((c * a) mod m)%Z -> (b mod m)%Z = (c mod m)%Z.
 intros m a b c; rewrite (Zmult_comm b a); rewrite (Zmult_comm c a); apply Zmod_mult_elim_lft.
Qed.

Lemma Zmod_opp_zero :
 forall m a : Z, (m > 0)%Z -> (a mod m)%Z = 0%Z -> (- a mod m)%Z = 0%Z.
Proof.
 intros m a Hm Ha.
 rewrite (Zmod_opp_elim m a Hm).
 rewrite Ha.
 unfold Zminus in |- *; simpl in |- *; rewrite Zplus_0_r.
 apply (Z_mod_same m Hm).
Qed.

Lemma Zmod_small :
 forall m a : Z, (m > 0)%Z -> (0 <= a < m)%Z -> (a mod m)%Z = a.
Proof.
 intros m a Hm Ha.
 apply (Zmodeq_small (a mod m) a m).
   apply (Z_mod_lt a m Hm).
  exact Ha.
 replace (a mod m - a)%Z with (- m * (a / m))%Z.
  auto with zarith.
 generalize (Z_div_mod_eq_full a m).
 set (q := (a / m)%Z); set (r := (a mod m)%Z); intro H; rewrite H.
 rewrite Zplus_comm; unfold Zminus in |- *; rewrite Zopp_plus_distr;
   rewrite Zplus_assoc; rewrite Zplus_opp_r; rewrite Zplus_0_l;
     rewrite Zopp_mult_distr_l_reverse; rewrite Zmult_comm; reflexivity.
Qed.

Lemma Zmod_opp_nonzero :
 forall m a : Z,
 (m > 0)%Z -> (a mod m)%Z <> 0%Z -> (- a mod m)%Z = (m - a mod m)%Z.
Proof.
 intros m a Hm Ha.
 rewrite (Zmod_opp_elim m a Hm).
 apply Zmod_small.
  exact Hm.
 generalize (Z_mod_lt a m Hm); intro Hlt.
 auto with zarith.
Qed.

Lemma Zmod_one_lft : forall m : Z, (m > 1)%Z -> (1 mod m)%Z = 1%Z.
Proof.
 intros m Hm.
 apply Zmod_small; auto with zarith.
Qed.

Lemma Zmod_one_rht : forall a : Z, (a mod 1)%Z = 0%Z.
Proof.
 intro a.
 generalize (Z_mod_lt a 1).
 auto with zarith.
Qed.

Lemma Zmod_lin_comb :
 forall m a : Z,
 (m > 0)%Z -> (Zgcd a m < m)%Z -> ((a * Zgcd_coeff_a a m) mod m)%Z = Zgcd a m.
Proof.
 intros m a Hm Hgcd.
 generalize (Zgcd_lin_comb a m); intro Hlincomb.
 rewrite (Z_div_mod_eq_full (Zgcd_coeff_a a m * a) m) in Hlincomb.
 rewrite Zmult_comm in Hlincomb.
 rewrite Zplus_comm in Hlincomb.
 rewrite Zplus_assoc in Hlincomb.
 rewrite <- Zmult_plus_distr_l in Hlincomb.
 replace (Zgcd a m) with (Zgcd a m mod m)%Z.
  rewrite Hlincomb.
  rewrite Zmod_plus_compat; auto.
  rewrite Zmod_Zmod; auto.
  rewrite <- Zmod_plus_compat; auto.
  apply Zmod_minus_intro; auto.
  set (u := Zgcd_coeff_a a m).
  set (v := Zgcd_coeff_b a m).
  rewrite (Zplus_comm ((v + u * a / m) * m) (u * a)).
  unfold Zminus in |- *.
  rewrite Zopp_plus_distr.
  rewrite Zplus_assoc.
  rewrite (Zmult_comm a u).
  rewrite Zplus_opp_r.
  rewrite Zplus_0_l.
  rewrite <- Zopp_mult_distr_l_reverse.
  apply Zmod_multiple; auto.
 apply Zmod_small; auto.
 auto with zarith.
Qed.

Lemma Zmod_relprime_inv :
 forall m a : Z,
 (m > 1)%Z -> Zrelprime a m -> ((a * Zgcd_coeff_a a m) mod m)%Z = 1%Z.
Proof.
 intros m a Hm H1.
 unfold Zrelprime in H1.
 generalize (Zgcd_lin_comb a m).
 intro Hlc.
 rewrite H1 in Hlc.
 rewrite (Zmult_comm (Zgcd_coeff_a a m) a) in Hlc.
 assert (Hqr : (a * Zgcd_coeff_a a m)%Z = (- Zgcd_coeff_b a m * m + 1)%Z).
  rewrite Zplus_comm.
  rewrite Hlc.
  rewrite <- Zplus_assoc.
  rewrite Zopp_mult_distr_l_reverse.
  auto with zarith.
 set (Hdivmod:=Z_div_mod_eq_full (a * Zgcd_coeff_a a m) m).
 rewrite (Zmult_comm m (a * Zgcd_coeff_a a m / m)) in Hdivmod.
 apply (Zdiv_remainder_unique _ _ _ _ (- Zgcd_coeff_b a m) 1 Hdivmod).
   apply Z_mod_lt.
   auto with zarith.
  exact Hqr.
 auto with zarith.
Qed.

End zmod.

#[global]
Hint Resolve Zmod_zero_lft: zarith.
#[global]
Hint Resolve Zmod_zero_rht: zarith.
#[global]
Hint Resolve Zmod_same: zarith.
#[global]
Hint Resolve Zmod_Zmod: zarith.
#[global]
Hint Resolve Zmod_cancel_multiple: zarith.
#[global]
Hint Resolve Zmod_multiple: zarith.
#[global]
Hint Resolve Zmod_minus_intro: zarith.
#[global]
Hint Resolve Zmod_plus_compat: zarith.
#[global]
Hint Resolve Zmod_plus_compat_lft: zarith.
#[global]
Hint Resolve Zmod_plus_compat_rht: zarith.
#[global]
Hint Resolve Zmod_opp_elim: zarith.
#[global]
Hint Resolve Zmod_minus_elim: zarith.
#[global]
Hint Resolve Zmod_mult_compat: zarith.
#[global]
Hint Resolve Zmod_mult_compat_lft: zarith.
#[global]
Hint Resolve Zmod_mult_compat_rht: zarith.
#[global]
Hint Resolve Zmod_opp_zero: zarith.
#[global]
Hint Resolve Zmod_small: zarith.
#[global]
Hint Resolve Zmod_opp_nonzero: zarith.
#[global]
Hint Resolve Zmod_one_lft: zarith.
#[global]
Hint Resolve Zmod_one_rht: zarith.
#[global]
Hint Resolve Zmod_lin_comb: zarith.
#[global]
Hint Resolve Zmod_relprime_inv: zarith.

(*
** Equality modulo m
Let m be a positive number.
*)

Section zmodeq.

Variable m : positive.

Definition Zmodeq (a b : Z) := Zdivides m (a - b).

Lemma Zmodeq_dec : forall a b : Z, {Zmodeq a b} + {~ Zmodeq a b}.
Proof.
 intros a b.
 unfold Zmodeq in |- *.
 apply Zdivides_dec.
Qed.

Lemma Zmodeq_modeq : forall a b : Z, Zmodeq a b -> (a mod m)%Z = (b mod m)%Z.
Proof.
 intros a b H.
 apply Zmod_minus_intro.
  auto with zarith.
 unfold Zmodeq in H.
 apply Zmod0_Zdivides.
  intro Hfalse; inversion Hfalse.
 assumption.
Qed.

Lemma Zmodeq_eqmod : forall a b : Z, (a mod m)%Z = (b mod m)%Z -> Zmodeq a b.
Proof.
 intros a b H.
 unfold Zmodeq in |- *.
 apply Zdivides_Zmod0.
  intro Hfalse; inversion Hfalse.
 apply Zmod_minus_elim; auto with zarith.
Qed.

Lemma Zmodeq_refl : forall a : Z, Zmodeq a a.
Proof.
 intros.
 unfold Zmodeq in |- *.
 unfold Zminus in |- *.
 rewrite Zplus_opp_r.
 apply Zdivides_zero_rht.
Qed.

Lemma Zmodeq_symm : forall a b : Z, Zmodeq a b -> Zmodeq b a.
Proof.
 unfold Zmodeq in |- *.
 intros.
 replace (b - a)%Z with (- (a - b))%Z; auto with zarith.
Qed.

Lemma Zmodeq_trans : forall a b c : Z, Zmodeq b a -> Zmodeq a c -> Zmodeq b c.
Proof.
 unfold Zmodeq in |- *.
 intros.
 replace (b - c)%Z with (b - a + (a - c))%Z; auto with zarith.
Qed.

Lemma Zmodeq_zero : forall a : Z, Zmodeq a 0 <-> Zdivides m a.
Proof.
 unfold Zmodeq in |- *; unfold Zdivides in |- *.
 intros.
 unfold Zminus in |- *.
 simpl in |- *.
 rewrite Zplus_0_r.
 tauto.
Qed.

Lemma Zmodeq_rem : forall a : Z, Zmodeq a (a mod m).
Proof.
 intros.
 unfold Zmodeq in |- *.
 exists (a / m)%Z.
 rewrite Zmult_comm.
 generalize (Z_div_mod_eq_full a m).
 auto with zarith.
Qed.

Lemma Zmodeq_plus_compat :
 forall a b c d : Z, Zmodeq a b -> Zmodeq c d -> Zmodeq (a + c) (b + d).
Proof.
 intros a b c d.
 unfold Zmodeq in |- *.
 unfold Zdivides in |- *.
 intros Hab Hcd.
 elim Hab.
 intros q1 H1.
 elim Hcd.
 intros q2 H2.
 exists (q1 + q2)%Z.
 rewrite Zmult_plus_distr_l.
 auto with zarith.
Qed.

Definition Zmodeq_plus_elim := Zmodeq_plus_compat.

Lemma Zmodeq_plus_elim_lft :
 forall a b c : Z, Zmodeq a b -> Zmodeq (c + a) (c + b).
Proof.
 intros.
 apply Zmodeq_plus_compat.
  apply Zmodeq_refl.
 assumption.
Qed.

Lemma Zmodeq_plus_elim_rht :
 forall a b c : Z, Zmodeq a b -> Zmodeq (a + c) (b + c).
Proof.
 intros.
 apply Zmodeq_plus_compat.
  assumption.
 apply Zmodeq_refl.
Qed.

Lemma Zmodeq_mult_elim_lft :
 forall a b c : Z, Zmodeq a b -> Zmodeq (c * a) (c * b).
Proof.
 intros.
 unfold Zmodeq in |- *.
 unfold Zminus in |- *.
 rewrite (Zmult_comm c b).
 rewrite <- Zopp_mult_distr_l_reverse.
 rewrite (Zmult_comm c a).
 rewrite <- Zmult_plus_distr_l.
 fold (a - b)%Z in |- *.
 apply Zdivides_mult_elim_rht.
 assumption.
Qed.

Lemma Zmodeq_mult_elim_rht :
 forall a b c : Z, Zmodeq a b -> Zmodeq (a * c) (b * c).
Proof.
 intros.
 rewrite (Zmult_comm a c).
 rewrite (Zmult_comm b c).
 apply Zmodeq_mult_elim_lft.
 assumption.
Qed.

Lemma Zmodeq_mult_compat :
 forall a b c d : Z, Zmodeq a b -> Zmodeq c d -> Zmodeq (a * c) (b * d).
Proof.
 intros a b c d Hab Hcd.
 apply (Zmodeq_trans (b * c)).
  apply Zmodeq_mult_elim_rht; assumption.
 apply Zmodeq_mult_elim_lft; assumption.
Qed.

Definition Zmodeq_mult_elim := Zmodeq_mult_compat.

Lemma Zmodeq_opp_elim : forall a b : Z, Zmodeq a b -> Zmodeq (- a) (- b).
Proof.
 intros a b H.
 replace (- a)%Z with (-1 * a)%Z; auto with zarith.
 replace (- b)%Z with (-1 * b)%Z; auto with zarith.
 apply Zmodeq_mult_elim.
  apply Zmodeq_refl.
 exact H.
Qed.

Lemma Zmodeq_opp_intro : forall a b : Z, Zmodeq (- a) (- b) -> Zmodeq a b.
Proof.
 intros a b H.
 rewrite <- (Z.opp_involutive a).
 rewrite <- (Z.opp_involutive b).
 apply (Zmodeq_opp_elim _ _ H).
Qed.

Lemma Zmodeq_gcd_compat_lft :
 forall a b : Z, Zmodeq a b -> Zgcd m a = Zgcd m b.
Proof.
 unfold Zmodeq in |- *.
 intros a b H0.
 elim H0; intros q Hq.
 replace (Zgcd m b) with (Zgcd m (b + q * m)); auto with zarith.
 rewrite Hq.
 replace (b + (a - b))%Z with a; auto with zarith.
Qed.

Lemma Zmodeq_gcd_compat_rht :
 forall a b : Z, Zmodeq a b -> Zgcd a m = Zgcd b m.
Proof.
 intros.
 rewrite (Zgcd_symm a m).
 rewrite (Zgcd_symm b m).
 apply Zmodeq_gcd_compat_lft.
 assumption.
Qed.

Lemma Zmodeq_relprime :
 forall a b : Z, Zmodeq a b -> Zrelprime a m -> Zrelprime b m.
Proof.
 intros a b H.
 unfold Zrelprime in |- *.
 rewrite (Zmodeq_gcd_compat_rht a b H).
 tauto.
Qed.

Lemma Zmodeq_mod_elim :
 forall a b : Z, Zmodeq a b -> Zmodeq (a mod m) (b mod m).
Proof.
 intros a b H.
 apply Zmodeq_eqmod.
 rewrite Zmod_Zmod; auto with zarith.
 rewrite Zmod_Zmod; auto with zarith.
Qed.

Lemma Zmodeq_mod_elim_lft : forall a b : Z, Zmodeq a b -> Zmodeq (a mod m) b.
Proof.
 intros a b H.
 apply Zmodeq_eqmod.
 rewrite Zmod_Zmod; auto with zarith.
Qed.

Lemma Zmodeq_mod_elim_rht : forall a b : Z, Zmodeq a b -> Zmodeq a (b mod m).
Proof.
 intros a b H.
 apply Zmodeq_eqmod.
 rewrite Zmod_Zmod; auto with zarith.
Qed.

Lemma Zmodeq_mod_intro :
 forall a b : Z, Zmodeq (a mod m) (b mod m) -> Zmodeq a b.
Proof.
 intros a b H.
 apply Zmodeq_eqmod.
 rewrite <- (Zmod_Zmod m a); auto with zarith.
 rewrite <- (Zmod_Zmod m b); auto with zarith.
Qed.

Lemma Zmodeq_mod_intro_lft : forall a b : Z, Zmodeq (a mod m) b -> Zmodeq a b.
Proof.
 intros a b H.
 apply Zmodeq_eqmod.
 rewrite <- (Zmod_Zmod m a); auto with zarith.
Qed.

Lemma Zmodeq_mod_intro_rht : forall a b : Z, Zmodeq a (b mod m) -> Zmodeq a b.
Proof.
 intros a b H.
 apply Zmodeq_eqmod.
 rewrite <- (Zmod_Zmod m b); auto with zarith.
Qed.

End zmodeq.

#[global]
Hint Resolve Zmodeq_dec: zarith.
#[global]
Hint Resolve Zmodeq_modeq: zarith.
#[global]
Hint Resolve Zmodeq_eqmod: zarith.
#[global]
Hint Resolve Zmodeq_refl: zarith.
#[global]
Hint Resolve Zmodeq_symm: zarith.
#[global]
Hint Resolve Zmodeq_trans: zarith.
#[global]
Hint Resolve Zmodeq_zero: zarith.
#[global]
Hint Resolve Zmodeq_rem: zarith.
#[global]
Hint Resolve Zmodeq_plus_compat: zarith.
#[global]
Hint Resolve Zmodeq_plus_elim: zarith.
#[global]
Hint Resolve Zmodeq_plus_elim_lft: zarith.
#[global]
Hint Resolve Zmodeq_plus_elim_rht: zarith.
#[global]
Hint Resolve Zmodeq_mult_elim_lft: zarith.
#[global]
Hint Resolve Zmodeq_mult_elim_rht: zarith.
#[global]
Hint Resolve Zmodeq_mult_compat: zarith.
#[global]
Hint Resolve Zmodeq_mult_elim: zarith.
#[global]
Hint Resolve Zmodeq_opp_intro: zarith.
#[global]
Hint Resolve Zmodeq_opp_elim: zarith.
#[global]
Hint Resolve Zmodeq_gcd_compat_lft: zarith.
#[global]
Hint Resolve Zmodeq_gcd_compat_rht: zarith.
#[global]
Hint Resolve Zmodeq_relprime: zarith.
#[global]
Hint Resolve Zmodeq_mod_elim: zarith.
#[global]
Hint Resolve Zmodeq_mod_elim_lft: zarith.
#[global]
Hint Resolve Zmodeq_mod_elim_rht: zarith.
#[global]
Hint Resolve Zmodeq_mod_intro: zarith.
#[global]
Hint Resolve Zmodeq_mod_intro_lft: zarith.
#[global]
Hint Resolve Zmodeq_mod_intro_rht: zarith.

(*
Notation " a ~ b  ( 'mod' m ) "  := (Zmodeq m a b) (at level 1, a,b,m at level 10).

Syntax constr level 5:
  Zmodeq_print [ (Zmodeq $c1 $c2 $c3) ] -> [ $c2 "~" $c3 "(" "mod" $c1 ")" ].
*)


Require Import CoqStock.comparable.
Require Import CoqStock.List.
Require Import CoqStock.WreckIt.

Require Import Reexamined.regex.
Require Import Reexamined.matches_pred.

Theorem concat_empty_l:
  forall {A : Type} {cmp : comparable A} (xs : list A) (r : regex A),
    xs =~ r ->
    xs =~ concat r empty.
Proof.
  intros.
  rewrite <- app_nil_r.
  apply concat_matches.
  - assumption.
  - apply empty_matches.
Qed.

Theorem concat_empty_r:
  forall {A : Type} {cmp : comparable A} (xs : list A) (r : regex A),
    xs =~ r ->
    xs =~ concat r empty.
Proof.
  intros.
  rewrite <- app_nil_r.
  apply concat_matches.
  - assumption.
  - apply empty_matches.
Qed.

Theorem concat_nil:
  forall {A : Type} {cmp : comparable A} (xs : list A) (r : regex A),
    xs =~ r ->
    (xs ++ nil) =~ r.
Proof.
  intros.
  rewrite <- app_nil_r in H.
  assumption.
Qed.

Theorem concatP:
  forall {A : Type} {cmp : comparable A} (xs : list A) (r s : regex A),
    xs =~ concat r s ->
    (exists (prefix suffix : list A),
        xs = prefix ++ suffix /\ prefix =~ r /\ suffix =~ s).
Proof.
  intros.
  remember (concat r s) as r'.
  induction H; (try inversion Heqr').
  - subst.
    clear Heqr' IHmatches_prop1 IHmatches_prop2.
    exists xs.
    exists ys.
    split.
    + reflexivity.
    + split; assumption.
Qed.

Theorem concat_assoc:
  forall {A : Type} {cmp : comparable A} (l : list A) (r s t: regex A),
    l =~ (concat (concat r s) t) ->
    l =~ (concat r (concat s t)).
Proof.
  intros.
  apply concatP in H.
  elim H; clear H.
  intros xs_ys H0.
  elim H0; clear H0.
  intros zs H1.
  elim H1; clear H1.
  intros.
  elim H0; clear H0.
  intros.
  rewrite H.
  apply concatP in H0.
  elim H0; clear H0.
  intros xs H0.
  elim H0; clear H0.
  intros ys H0.
  elim H0; clear H0.
  intros.
  elim H2; clear H2.
  intros.
  (* TODO: Help Wanted
     clean up above *)

  subst.
  rewrite <- app_assoc.

  apply concat_matches.
  - assumption.
  - apply concat_matches; assumption.
Qed.

Theorem concat_assoc':
  forall {A : Type} {cmp : comparable A} (l : list A) (r s t: regex A),
    l =~ (concat (concat r s) t) ->
    l =~ (concat r (concat s t)).
Proof.
  intros.
  apply concatP in H.
  wreckit.
  apply concatP in H1.
  wreckit.
  rewrite <- app_assoc.
  apply concat_matches.
  - assumption.
  - apply concat_matches; assumption.
Qed.

Theorem orP:
  forall {A : Type} {cmp : comparable A} (xs : list A) (r s : regex A),
    xs =~ or r s ->
    xs =~ r \/ xs =~ s.
Proof.
  intros.
  remember (or r s) as r'.
  induction H; (try inversion Heqr').
  - subst.
    left; assumption.
  - subst.
    right; assumption.
Qed.

Theorem concat_or_distrib_r:
  forall {A : Type} {cmp : comparable A} (xs: list A) (r s t: regex A),
    xs =~ (concat (or r s) t) ->
    xs =~ or (concat r t) (concat s t).
Proof.
  intros.
  remember (concat (or r s) t) as r'.
  induction H; (try inversion Heqr').
  - subst.
    clear IHmatches_prop2.
    clear IHmatches_prop1.

    apply orP in H.
    elim H.
    + intros.
      apply or_matches_l.
      apply concat_matches; assumption.
    + intros.
      apply or_matches_r.
      apply concat_matches; assumption.
Qed.

Theorem concat_fail_l:
  forall {A : Type} {cmp : comparable A} (xs : list A) (r : regex A),
    xs =~ concat fail r ->
    xs =~ fail.
Proof.
  intros.
  inversion H.
  inversion H2.
Qed.

Theorem concat_fail_r:
  forall {A : Type} {cmp : comparable A} (xs : list A) (r : regex A),
    xs =~ concat r fail ->
    xs =~ fail.
Proof.
  intros.
  inversion H.
  inversion H4.
Qed.

Theorem or_comm:
  forall {A : Type} {cmp : comparable A} (xs : list A) (r s : regex A),
    xs =~ (or r s) ->
    xs =~ (or s r).
Proof.
  intros.
  apply orP in H; elim H; intros.
  - apply or_matches_r; assumption.
  - apply or_matches_l; assumption.
Qed.

Theorem starP:
  forall {A : Type} {cmp : comparable A} (xs : list A) (r : regex A),
    xs =~ star r ->
    xs <> nil ->
    exists prefix suffix : list A,
      xs = prefix ++ suffix /\ prefix =~ r /\ suffix =~ star r.
Proof.
  intros.
  remember (star r) as r'.
  induction H; (try inversion Heqr').
  - elim (H0 (eq_refl nil)).
  - subst.
    exists xs.
    exists ys.
    split.
    + reflexivity.
    + split; assumption.
Qed.

Lemma star_app:
  forall {A : Type} {cmp : comparable A} (xs ys : list A) (r : regex A),
    xs =~ (star r) ->
    ys =~ (star r) ->
    xs ++ ys =~ (star r).
Proof.
  intros.
  remember (star r) as r'.
  induction H; (try inversion Heqr').
  - rewrite H1 in *.
    cbn.
    assumption.
  - subst.
    clear IHmatches_prop1.
    rewrite <- app_assoc.
    apply star_matches_concat.
    + assumption.
    + apply IHmatches_prop2.
      * reflexivity.
      * assumption.
Qed.

Theorem star_idem:
  forall {A : Type} {cmp : comparable A} (xs : list A) (r : regex A),
    xs =~ star (star r) ->
    xs =~ (star r).
Proof.
  intros.
  remember (star (star r)) as r'.
  induction H; (try inversion Heqr').
  - apply star_matches_nil.
  - subst.
    apply star_app.
    + assumption.
    + apply IHmatches_prop2.
      assumption.
Qed.


(* Maybe monad *)
Arguments Some [A] _.
Arguments None [A].

Definition ret {A : Type} (x : A) := Some x.

Definition bind {A B : Type} (a : option A) (f : A -> option B) : option B :=
  match a with
    | Some x => f x
    | None => None
  end.

Notation "A >>= F" := (bind A F) (at level 42, left associativity).

Notation "'do' X <- A ; B" := (bind A (fun X => B)) (at level 200, X ident, A at level 100, B at level 200).

Lemma mon_left_id : forall (A B : Type) (a : A) (f : A -> option B),
  ret a >>= f = f a.
Proof.
intros.
reflexivity.
Qed.

Lemma mon_right_id : forall (A : Type) (a : option A),
  a >>= ret = a.
Proof.
intros.
induction a; repeat reflexivity.
Qed.

Lemma mon_assoc :
  forall (A B C : Type) (a : option A) (f : A -> option B) (g : B -> option C),
    (a >>= f) >>= g = a >>= (fun x => f x >>= g).
Proof.
intros.
induction a; repeat reflexivity.
Qed.


(* derrec, derl, etc, other useful stuff *)

Require Export List.
Set Implicit Arguments.
Export ListNotations.

Require Import Coq.Program.Equality. (* for dependent induction/destruction *)

Require Import genT gen existsT.
Require Import PeanoNat.

(* note, this doesn't work Type replaced by Prop,
  although the actual version used allows prems : X -> Prop
Reset derrec.

Inductive derrec X (rules : list X -> X -> Prop) :
  (X -> Type) -> X -> Prop :=
  | dpI : forall prems concl,
    prems concl -> derrec rules prems concl
  | derI : forall ps prems concl,
    rules ps concl -> dersrec rules prems ps -> derrec rules prems concl
with dersrec X (rules : list X -> X -> Prop) :
  (X -> Type) -> list X -> Prop :=
  | dlNil : forall prems, dersrec rules prems []
  | dlCons : forall prems seq seqs,
    derrec rules prems seq -> dersrec rules prems seqs ->
    dersrec rules prems (seq :: seqs)
    .
    *)

(* definition using Forall, seems equivalent *)
Inductive aderrec X (rules : list X -> X -> Prop)
  (prems : X -> Prop) : X -> Prop :=
  | adpI : forall concl,
    prems concl -> aderrec rules prems concl
  | aderI : forall ps concl, rules ps concl ->
    Forall (aderrec rules prems) ps -> aderrec rules prems concl.
(* need type version of Forall, to change this to Type *)

(* derrec: type of derivation of a sequent ; dersrec: same idea but for
multiple sequents *)

Inductive derrec X (rules : list X -> X -> Type) (prems : X -> Type) :
  X -> Type :=
  | dpI : forall concl,
    prems concl -> derrec rules prems concl
  | derI : forall ps concl,
    rules ps concl -> dersrec rules prems ps -> derrec rules prems concl
with dersrec X (rules : list X -> X -> Type) (prems : X -> Type) :
  list X -> Type :=
  | dlNil : dersrec rules prems []
  | dlCons : forall seq seqs,
    derrec rules prems seq -> dersrec rules prems seqs ->
    dersrec rules prems (seq :: seqs)
    .

Scheme derrec_rect_mut := Induction for derrec Sort Type
with dersrec_rect_mut := Induction for dersrec Sort Type.
Scheme derrec_rec_mut := Induction for derrec Sort Set
with dersrec_rec_mut := Induction for dersrec Sort Set.
Scheme derrec_ind_mut := Induction for derrec Sort Prop
with dersrec_ind_mut := Induction for dersrec Sort Prop.
(*
Check derrec_ind_mut.
Check dersrec_ind_mut.
*)
(* combine the two inductive principles *)
Definition derrec_dersrec_rect_mut X rules prems P P0 dp der dln dlc :=
  pair (@derrec_rect_mut X rules prems P P0 dp der dln dlc)
    (@dersrec_rect_mut X rules prems P P0 dp der dln dlc).

Ltac solve_dersrec := repeat (apply dlCons || apply dlNil || assumption).

(* this should be a more useful induction principle for derrec *)
Definition dim_all X rules prems Q :=
  @derrec_ind_mut X rules prems (fun y => fun _ => Q y)
  (fun ys => fun _ => Forall Q ys).

Definition dim_allT X rules (prems Q : X -> Type) :=
  @derrec_rect_mut X rules prems (fun y => fun _ => Q y)
  (fun ys => fun _ => ForallT Q ys).

(* this doesn't work
Check (dim_all _ _ (Forall_nil X Q)).
*)
(* here is how to get the tautologies out of dim_all *)
Definition dim_all3 X rules prems Q h1 h2 :=
  @dim_all X rules prems Q h1 h2 (Forall_nil Q).

Definition fce3 X Q D Ds seq seqs (d : D seq) qs (ds : Ds seqs) qss :=
  @Forall_cons X Q seq seqs qs qss.

Definition dim_all4 X rules prems Q h1 h2 :=
  @dim_all3 X rules prems Q h1 h2
  (@fce3 X Q (derrec rules prems) (dersrec rules prems)).

Definition dim_all8 X rules prems Q h1 h2 :=
  @dim_all3 X rules prems Q h1 h2
  (fun seq seqs _ qs _ qss => @Forall_cons X Q seq seqs qs qss).

(* so dim_all4, or dim_all8 better, is the same as derrec_all_ind below *)

Lemma derrec_all_ind:
  forall X (rules : list X -> X -> Type) (prems Q : X -> Prop),
     (forall concl : X, prems concl -> Q concl) ->
     (forall (ps : list X) (concl : X),
      rules ps concl -> dersrec rules prems ps -> Forall Q ps -> Q concl) ->
     forall y : X, derrec rules prems y -> Q y.
Proof.  intros.
eapply dim_all. exact H. exact H0.
apply Forall_nil.
intros.  apply Forall_cons. assumption.  assumption.
assumption.  Qed.

Lemma derrec_all_indT:
  forall X (rules : list X -> X -> Type) (prems Q : X -> Type),
     (forall concl : X, prems concl -> Q concl) ->
     (forall (ps : list X) (concl : X),
      rules ps concl -> dersrec rules prems ps -> ForallT Q ps -> Q concl) ->
     forall y : X, derrec rules prems y -> Q y.
Proof.  intros until 0. intros H H0.
eapply dim_allT. exact H. exact H0.
apply ForallT_nil.
intros.  apply ForallT_cons. assumption.  assumption.
Qed.

Lemma derrec_all_rect:
  forall X (rules : list X -> X -> Type) (prems Q : X -> Type),
     (forall concl : X, prems concl -> Q concl) ->
     (forall (ps : list X) (concl : X),
      rules ps concl -> dersrec rules prems ps -> ForallT Q ps -> Q concl) ->
     forall y : X, derrec rules prems y -> Q y.
Proof.  intros.
eapply dim_allT. exact X0. exact X1.
apply ForallT_nil.
intros.  apply ForallT_cons. assumption.  assumption.
assumption.  Qed.

Lemma derrec_derrec' X rules prems:
  (forall c : X, derrec rules (derrec rules prems) c -> derrec rules prems c) *
  (forall cs, dersrec rules (derrec rules prems) cs -> dersrec rules prems cs).
Proof. apply derrec_dersrec_rect_mut.
- intros. assumption.
- intros. eapply derI ; eassumption.
- apply dlNil.
- intros. apply dlCons ; assumption. Qed.

Definition derrec_derrec X rules prems := fst (@derrec_derrec' X rules prems).
Definition dersrec_derrec X rules prems := snd (@derrec_derrec' X rules prems).

Inductive derl X (rules : list X -> X -> Type) : list X -> X -> Type :=
  | asmI : forall p, derl rules [p] p
  | dtderI : forall pss ps concl, rules ps concl ->
    dersl rules pss ps -> derl rules pss concl
with dersl X (rules : list X -> X -> Type) : list X -> list X -> Type :=
  | dtNil : dersl rules [] []
  | dtCons : forall ps c pss cs,
    derl rules ps c -> dersl rules pss cs -> dersl rules (ps ++ pss) (c :: cs)
  .

Scheme derl_ind_mut := Induction for derl Sort Prop
with dersl_ind_mut := Induction for dersl Sort Prop.
Scheme derl_rec_mut := Induction for derl Sort Set
with dersl_rec_mut := Induction for dersl Sort Set.
Scheme derl_rect_mut := Induction for derl Sort Type
with dersl_rect_mut := Induction for dersl Sort Type.
(*
Check derl_ind_mut.
Check dersl_ind_mut.
*)
Lemma dtCons_eq X rules ps c pss cs psa: derl rules ps (c : X) ->
  dersl rules pss cs -> psa = ps ++ pss -> dersl rules psa (c :: cs).
Proof. intros. subst. apply dtCons ; assumption. Qed.

Lemma derl_dersl_single X rules ps (c : X) :
  iffT (dersl rules ps [c]) (derl rules ps c).
Proof. split.
intro. inversion X0. inversion X2. subst.  rewrite app_nil_r. assumption.
intro. eapply (dtCons_eq X0 (dtNil _)).  rewrite app_nil_r. reflexivity. Qed.

(* combine the two inductive principles *)
Definition derl_dersl_rect_mut X rules P P0 asm dtd dtn dtc :=
  pair (@derl_rect_mut X rules P P0 asm dtd dtn dtc)
    (@dersl_rect_mut X rules P P0 asm dtd dtn dtc).

Lemma asmsI X rules ps: @dersl X rules ps ps .
Proof. induction ps. apply dtNil. pose (asmI rules a).
pose (dtCons d IHps). simpl in d0. exact d0. Qed.

Lemma in_derl X rules ps c: rules ps c -> @derl X rules ps c.
Proof. intro. eapply dtderI. eassumption. apply asmsI. Qed.

Definition rsub_derl X rules := rsubI _ _ (@in_derl X rules).

Inductive dercl X (rules : list X -> X -> Type) :
  list X -> X -> Type :=
  | casmI : forall p, dercl rules [p] p
  | dtcderI : forall pss ps concl, rules ps concl ->
    dercsl rules pss ps -> dercl rules (concat pss) concl
with dercsl X (rules : list X -> X -> Type) :
  list (list X) -> list X -> Type :=
  | dtcNil : dercsl rules [] []
  | dtcCons : forall ps c pss cs, dercl rules ps c ->
      dercsl rules pss cs -> dercsl rules (ps :: pss) (c :: cs)
  .

Scheme dercl_ind_mut := Induction for dercl Sort Prop
with dercsl_ind_mut := Induction for dercsl Sort Prop.
Scheme dercl_rec_mut := Induction for dercl Sort Set
with dercsl_rec_mut := Induction for dercsl Sort Set.
Scheme dercl_rect_mut := Induction for dercl Sort Type
with dercsl_rect_mut := Induction for dercsl Sort Type.
(*
Check dercl_ind_mut.
Check dercsl_ind_mut.
*)
(* combine the two inductive principles *)
Definition dercl_dercsl_rect_mut X rules P P0 asm dtd dtn dtc :=
  pair (@dercl_rect_mut X rules P P0 asm dtd dtn dtc)
    (@dercsl_rect_mut X rules P P0 asm dtd dtn dtc).

Inductive ccps X f (qs cs : list X) : Type :=
  | ccpsI : forall pss, f pss cs -> qs = concat pss -> ccps f qs cs.

Lemma ccpsD X f qs cs: ccps f qs cs ->
  {pss : list (list X) & qs = concat pss & f pss cs}.
Proof. intro cc. destruct cc. subst. exists pss ; tauto. Qed.

Definition drl_allT X (rules Q : list X -> X -> Type) R :=
  @derl_rect_mut X rules (fun ps => fun c => fun _ => Q ps c)
  (fun pss => fun cs => fun _ => R pss cs).

Definition drsl_allT X (rules Q : list X -> X -> Type) R :=
  @dersl_rect_mut X rules (fun ps => fun c => fun _ => Q ps c)
  (fun pss => fun cs => fun _ => R pss cs).

(* these may be too strong, have a condition that has to hold
  even if dersl and Forall2T Q hold for different partition of pss *)
Definition drl_allT' X (rules Q : list X -> X -> Type) :=
  @derl_rect_mut X rules (fun ps => fun c => fun _ => Q ps c)
  (fun ps => fun cs => fun _ => ccps (Forall2T Q) ps cs).

Definition drsl_allT' X (rules Q : list X -> X -> Type) :=
  @dersl_rect_mut X rules (fun ps => fun c => fun _ => Q ps c)
  (fun ps => fun cs => fun _ => ccps (Forall2T Q) ps cs).

Definition dcl_allT X (rules Q : list X -> X -> Type) :=
  @dercl_rect_mut X rules (fun ps => fun c => fun _ => Q ps c)
  (fun pss => fun cs => fun _ => Forall2T Q pss cs).

Definition dcsl_allT X (rules Q : list X -> X -> Type) :=
  @dercsl_rect_mut X rules (fun ps => fun c => fun _ => Q ps c)
  (fun pss => fun cs => fun _ => Forall2T Q pss cs).

Lemma dercl_all_rect: forall X (rules Q : list X -> X -> Type),
  (forall p : X, Q [p] p) ->
  (forall pss qs ps concl, rules ps concl -> dercsl rules pss ps ->
    Forall2T Q pss ps -> qs = concat pss -> Q qs concl) ->
  forall ps c, dercl rules ps c -> Q ps c.
Proof.  intros. eapply dcl_allT.  exact X0.
{ intros. eapply X1.  eassumption.
  eassumption.  eassumption. reflexivity. }
apply Forall2T_nil.
intros. apply Forall2T_cons ; assumption. assumption. Qed.

Lemma derscl_all_dercl: forall X (rules : list X -> X -> Type),
  forall pss cs, dercsl rules pss cs -> Forall2T (dercl rules) pss cs.
Proof. intros X rules. apply dcsl_allT. apply casmI.
intros. eapply dtcderI ; eassumption.
apply Forall2T_nil.  intros.  apply Forall2T_cons ; assumption. Qed.

Lemma all_dercl_derscl: forall X (rules : list X -> X -> Type),
  forall pss cs, Forall2T (dercl rules) pss cs -> dercsl rules pss cs.
Proof. induction pss.
intros. inversion X0. apply dtcNil.
intros. inversion X0. subst. apply dtcCons. assumption.
apply IHpss. assumption.  Qed.

Lemma all_derl_dersl: forall X (rules : list X -> X -> Type),
  forall pss cs, Forall2T (derl rules) pss cs -> dersl rules (concat pss) cs.
Proof. induction pss.
intros. inversion X0. simpl. apply dtNil.
intros. inversion X0. subst. simpl. apply dtCons. assumption.
apply IHpss. assumption.  Qed.

Lemma all_derl_dersl': forall X (rules : list X -> X -> Type),
  forall qs cs, ccps (Forall2T (derl rules)) qs cs -> dersl rules qs cs.
Proof. intros. destruct X0. subst. apply all_derl_dersl. exact f. Qed.

Lemma dersl_all_derl: forall X (rules : list X -> X -> Type),
  forall qs cs, dersl rules qs cs ->
  {pss : list (list X) & qs = concat pss & Forall2T (derl rules) pss cs}.
Proof. intros X rules. eapply drsl_allT. apply asmI.
intros. destruct X0. subst. eapply dtderI. apply r. apply d.
exists []. simpl. reflexivity.  apply Forall2T_nil.
intros. destruct X1. subst. exists (ps :: x).  simpl. reflexivity.
apply Forall2T_cons ; assumption. Qed.

Lemma dersl_all_derl': forall X (rules : list X -> X -> Type),
  forall qs cs, dersl rules qs cs -> ccps (Forall2T (derl rules)) qs cs.
Proof. intros X rules. eapply drsl_allT'. apply asmI.
intros. destruct X0. eapply dtderI ; eassumption.
eapply ccpsI. apply Forall2T_nil.  simpl. reflexivity.
intros. destruct X1. subst. eapply ccpsI.
apply Forall2T_cons ; eassumption.  simpl. reflexivity.  Qed.

Lemma dercl_derl': forall X (rules : list X -> X -> Type),
  prod (forall ps c, dercl rules ps c -> derl rules ps c)
    (forall pss cs, dercsl rules pss cs -> dersl rules (concat pss) cs).
Proof. intros.
eapply (dercl_dercsl_rect_mut (rules := rules)
  (fun ps : list X => fun c => fun _ => derl rules ps c)
  (fun pss cs => fun _ => dersl rules (concat pss) cs)).
apply asmI.
intros. eapply dtderI. eassumption.
subst. assumption.
simpl. apply dtNil.
intros. simpl. apply dtCons ; assumption.  Qed.

Definition dercl_derl X rules := fst (@dercl_derl' X rules).
Definition dercsl_dersl X rules := snd (@dercl_derl' X rules).

Lemma derl_dercl: forall X (rules : list X -> X -> Type),
  forall ps c, derl rules ps c -> dercl rules ps c.
Proof.  intros X rules.
eapply (drl_allT (dercl rules) (ccps (dercsl rules))).
apply casmI.
{ intros. destruct X0. subst.
eapply dtcderI. eassumption.  eassumption. }
{ eapply ccpsI. apply dtcNil. simpl. reflexivity. }
{ intros. destruct X1. subst.
eapply ccpsI. eapply dtcCons ; eassumption.
simpl. reflexivity. } Qed.

Lemma derl_all_rect: forall X (rules Q : list X -> X -> Type),
  (forall p : X, Q [p] p) ->
  (forall pss qs ps concl, rules ps concl -> dersl rules qs ps ->
    Forall2T Q pss ps -> qs = concat pss -> Q qs concl) ->
  forall ps c, derl rules ps c -> Q ps c.
Proof.  intros X rules Q asm dtd.
eapply (drl_allT Q (ccps (Forall2T Q))).
exact asm.
{ intros. destruct X0. subst.
eapply dtd. eassumption. eassumption. eassumption. reflexivity. }
{ eapply ccpsI. apply Forall2T_nil. simpl. reflexivity. }
{ intros. destruct X1. subst.
eapply ccpsI. eapply Forall2T_cons ; eassumption.
simpl. reflexivity. } Qed.
(*
Check derl_all_rect.
Check derl_dercl.
Check dercl_derl.
*)
(* no convenient way of expressing the corresponding result
  for dercsl except using sth like allrel *)

Lemma derrec_same: forall X rules prems (c c' : X),
  derrec rules prems c -> c = c' -> derrec rules prems c'.
Proof. intros. subst. assumption. Qed.

(* further detailed versions of derrec_same *)
Lemma derrec_same_nsL: forall Y X D rules prems G H Δ d (Γ Γ' : X),
  derrec rules prems (G ++ (Γ : X, Δ : Y, d : D) :: H) ->
    Γ = Γ' -> derrec rules prems (G ++ (Γ', Δ, d) :: H).
Proof. intros. subst. assumption. Qed.

Lemma derrec_same_nsR: forall Y X D rules prems G H Γ d (Δ Δ' : X),
  derrec rules prems (G ++ (Γ : Y, Δ : X, d : D) :: H) ->
    Δ = Δ' -> derrec rules prems (G ++ (Γ, Δ', d) :: H).
Proof. intros. subst. assumption. Qed.

Lemma dersrec_all: forall X rules prems (cs : list X),
  iffT (dersrec rules prems cs) (ForallT (derrec rules prems) cs).
Proof.  intros.
induction cs ; unfold iffT ; apply pair ; intro.
apply ForallT_nil. apply dlNil.
inversion X0. apply ForallT_cons. assumption.
unfold iffT in IHcs. destruct IHcs. tauto.
inversion X0. subst. apply dlCons.  assumption.
unfold iffT in IHcs. destruct IHcs. tauto.
Qed.

Definition dersrecD_all X rs ps cs := iffT_D1 (@dersrec_all X rs ps cs).
Definition dersrecI_all X rs ps cs := iffT_D2 (@dersrec_all X rs ps cs).

Lemma prems_dersrec X rules prems cs:
  ForallT prems cs -> @dersrec X rules prems cs.
Proof. induction cs ; intros. apply dlNil.
inversion X0. subst. apply dlCons. apply dpI. assumption. tauto. Qed.

Lemma dersrec_forall: forall X rules prems (cs : list X),
  iffT (dersrec rules prems cs) (forall c, InT c cs -> derrec rules prems c).
Proof. intros. rewrite dersrec_all. rewrite ForallT_forall. reflexivity. Qed.

Definition dersrecD_forall X rs ps cs := iffT_D1 (@dersrec_forall X rs ps cs).
Definition dersrecI_forall X rs ps cs := iffT_D2 (@dersrec_forall X rs ps cs).

Lemma dersrec_nil: forall X rules prems, dersrec rules prems ([] : list X).
Proof. apply dlNil. Qed.

(* this is very difficult for such an obvious result,
  better if we can rewrite based on iffT *)
Lemma dersrec_app: forall X rules prems cs ds,
  iffT (dersrec rules prems (cs ++ ds : list X))
    (prod (dersrec rules prems cs) (dersrec rules prems ds)).
Proof. intros. eapply iffT_trans. apply dersrec_forall.
unfold iffT. split ; intros.
split ; apply dersrecI_forall ; intros ; apply X0.
apply InT_appL. assumption.  apply InT_appR. assumption.
apply InT_appE in X1. sD.
eapply dersrecD_forall. 2 : eassumption. assumption.
eapply dersrecD_forall. 2 : eassumption. assumption. Qed.

Definition dersrec_appD X rules prems cs ds :=
  iffT_D1 (@dersrec_app X rules prems cs ds).
Definition dersrec_appL X rules prems cs ds da :=
  fst (@dersrec_appD X rules prems cs ds da).
Definition dersrec_appR X rules prems cs ds da :=
  snd (@dersrec_appD X rules prems cs ds da).
Definition dersrec_appJ X rules prems cs ds :=
  iffT_D2 (@dersrec_app X rules prems cs ds).
Definition dersrec_appI X rules prems cs ds :=
  prod_uncurry (@dersrec_appJ X rules prems cs ds).

Lemma dersrec_single: forall X rules prems c,
  iffT (dersrec rules prems [c]) (derrec rules prems (c : X)).
Proof. intros.  rewrite dersrec_all. rewrite ForallT_single. reflexivity. Qed.

Definition dersrec_singleD X rs ps c := iffT_D1 (@dersrec_single X rs ps c).
Definition dersrec_singleI X rs ps c := iffT_D2 (@dersrec_single X rs ps c).

Lemma dersrec_map_single: forall X Y (f : X -> Y) rules prems c,
  iffT (dersrec rules prems (map f [c])) (derrec rules prems (f c)).
Proof. simpl. intros. apply dersrec_single. Qed.

Lemma dersrec_map_2: forall X Y (f : X -> Y) rules prems c d,
  iffT (dersrec rules prems (map f [c ; d]))
    (derrec rules prems (f c) * derrec rules prems (f d)).
Proof. intros. rewrite dersrec_all. rewrite ForallT_map_2. reflexivity. Qed.

(* try using the induction principle derrec_all_rect *)
Theorem derrec_trans_imp: forall X rules prems (concl : X),
  derrec rules (derrec rules prems) concl -> derrec rules prems concl.
Proof.  intros. revert X0.
eapply derrec_all_rect. tauto.
intros.  eapply derI. exact X0.
apply dersrecI_all. exact X2. Qed.

Lemma derrec_rmono_s: forall W (rulesa rulesb : rlsT W) prems,
  rsub rulesa rulesb ->
  (forall concl, derrec rulesa prems concl -> derrec rulesb prems concl) *
  (forall cs, dersrec rulesa prems cs -> dersrec rulesb prems cs).
Proof. intros. apply derrec_dersrec_rect_mut ; intros.
- apply dpI. assumption.
- eapply derI. unfold rsub in X. apply X. eassumption. assumption.
- apply dlNil.
- apply dlCons ; assumption. Qed.

Definition derrec_rmono W rulesa rulesb prems concl rs :=
  fst (@derrec_rmono_s W rulesa rulesb prems rs) concl.
Definition dersrec_rmono W rulesa rulesb prems rs :=
  snd (@derrec_rmono_s W rulesa rulesb prems rs).

Theorem derl_derrec_trans': forall X rules prems,
  (forall rps (concl : X), derl rules rps concl ->
    dersrec rules prems rps -> derrec rules prems concl) *
  (forall rps cs, dersl rules rps cs ->
    dersrec rules prems rps -> dersrec rules prems cs).
Proof.  intros.
apply derl_dersl_rect_mut.
- intros.  inversion X0. assumption.
- intros. eapply derI. eassumption. tauto.
- tauto.
- intros until 0. intros dc dsdc dscs dspc dspps.
apply dersrecD_all in dspps.  apply dlCons.
+ apply dsdc.  apply ForallT_appendD1 in dspps.
apply dersrecI_all. exact dspps.
+ apply dspc.  apply ForallT_appendD2 in dspps.
apply dersrecI_all. exact dspps. Qed.

Definition derl_derrec_trans X rules prems :=
  fst (@derl_derrec_trans' X rules prems).
Definition dersl_dersrec_trans X rules prems :=
  snd (@derl_derrec_trans' X rules prems).

Theorem derrec_derl_deriv': forall X rules prems,
  (forall (concl : X),
    derrec (derl rules) prems concl -> derrec rules prems concl) *
  (forall cs, dersrec (derl rules) prems cs -> dersrec rules prems cs).
Proof.  intros.
apply derrec_dersrec_rect_mut.
- apply dpI.
- intros. eapply derl_derrec_trans in r. eassumption.  assumption.
- apply dlNil.
- intros. apply dlCons ; assumption.  Qed.

Definition derrec_derl_deriv X rules prems :=
  fst (@derrec_derl_deriv' X rules prems).
Definition dersrec_derl_deriv X rules prems :=
  snd (@derrec_derl_deriv' X rules prems).

Definition derl_derrec X rules prems rps (concl : X) drrc prems_cond :=
  @derl_derrec_trans X rules prems rps (concl : X) drrc
    (@prems_dersrec X rules prems rps prems_cond).

Definition derl_derrec_nil X rules prems (concl : X) drrc :=
  @derl_derrec_trans X rules prems [] (concl : X) drrc
    (@dlNil X rules prems).

Lemma dersl_dersrec_nil X rules prems (cs : list X):
  dersl rules [] cs -> dersrec rules prems cs.
Proof. induction cs ; intros. apply dlNil.
inversion X0. destruct ps. simpl in H0. subst.
apply dlCons. apply derl_derrec_nil. assumption. tauto.
simpl in H0. discriminate H0.  Qed.

Lemma dersl_cons: forall X rules qs p (ps : list X),
  dersl rules qs (p :: ps) -> sigT (fun qsa => sigT (fun qsb =>
    prod (qs = qsa ++ qsb) (prod (derl rules qsa p) (dersl rules qsb ps)))).
Proof.  intros.  inversion X0. subst.
eapply existT.  eapply existT.  apply pair.  reflexivity. tauto. Qed.

Lemma dersl_app_eq: forall X rules (psa psb : list X) qs,
  dersl rules qs (psa ++ psb) -> sigT (fun qsa => sigT (fun qsb =>
    prod (qs = qsa ++ qsb) (prod (dersl rules qsa psa) (dersl rules qsb psb)))).
Proof.  intro.  intro.  intro.  intro.  induction psa.  intros.
apply existT with [].  apply existT with qs. simpl. simpl in X0.
apply pair. trivial.
apply pair. apply dtNil. apply X0.

simpl. intros. apply dersl_cons in X0.
cD.  pose (IHpsa _ X4).  cD. subst.
eapply existT.  eapply existT.
apply pair.  apply app_assoc.  apply pair.
apply dtCons. assumption.  assumption.  assumption.
Qed.

Lemma derl_trans': forall X (rules : list X -> X -> Type),
  (forall (rps : list X) (concl : X), derl rules rps concl ->
  forall (pss : list X), dersl rules pss rps -> derl rules pss concl) *
  (forall (rps : list X) (cs : list X), dersl rules rps cs ->
  forall (pss : list X), dersl rules pss rps -> dersl rules pss cs).
Proof.  intros.
apply derl_dersl_rect_mut.
- intros. inversion_clear X0. inversion_clear X2.
rewrite app_nil_r.  assumption.
- intros until 0. intros rps dsl dsds pss0 ds0. apply dsds in ds0.
eapply dtderI. eassumption. assumption.
- intros. assumption.
- intros until 0. intros d dsd dsl dsds pss0 dspps.
apply dersl_app_eq in dspps. cD. subst. apply dtCons.
apply dsd. assumption. apply dsds. assumption. Qed.

Definition derl_trans X rules pss rps concl d :=
  fst (@derl_trans' X rules) rps concl d pss.
Definition dersl_trans X rules pss rps cs ds :=
  snd (@derl_trans' X rules) rps cs ds pss.

(* alternatively, just induction on the list of conclusions *)
Lemma dersl_trans_alt: forall X (rules : list X -> X -> Type)
           (cs rps : list X), dersl rules rps cs ->
	 forall (pss : list X), dersl rules pss rps -> dersl rules pss cs.
Proof.  intro.  intro.  intro.
induction cs.
intros. inversion X0. subst. assumption.
intros.  apply dersl_cons in X0. cD. subst.
apply dersl_app_eq in X1. cD. subst.
apply dtCons. eapply derl_trans. eassumption. assumption.
firstorder.  Qed.

Theorem derl_dersl_deriv': forall X rules,
  (forall prems (concl : X),
    derl (derl rules) prems concl -> derl rules prems concl) *
  (forall prems cs,
    dersl (derl rules) prems cs -> dersl rules prems cs).
Proof. intros.
apply derl_dersl_rect_mut.
- intro. apply asmI.
- intros. eapply derl_trans. eassumption.  assumption.
- apply dtNil.
- intros.  apply dtCons.  assumption.  assumption. Qed.

Definition derl_deriv' X rules := fst (@derl_dersl_deriv' X rules).
Definition dersl_deriv' X rules := snd (@derl_dersl_deriv' X rules).
Definition derl_deriv X rules := rsubI _ _ (@derl_deriv' X rules).
Definition dersl_deriv X rules := rsubI _ _ (@dersl_deriv' X rules).

Theorem derl_dersl_mono': forall X rulesa rulesb, rsub rulesa rulesb ->
  (forall prems (concl : X),
    derl rulesa prems concl -> derl rulesb prems concl) *
  (forall prems cs,
    dersl rulesa prems cs -> dersl rulesb prems cs).
Proof. intros X rulesa rulesb rsab.
apply derl_dersl_rect_mut.
- apply asmI.
- intros. eapply dtderI. unfold rsub in rsab.
apply rsab.  eassumption.  assumption.
- apply dtNil.
- intros.  apply dtCons.  assumption.  assumption. Qed.

Definition derl_mono' X rulesa rulesb rsab :=
  fst (@derl_dersl_mono' X rulesa rulesb rsab).
Definition dersl_mono' X rulesa rulesb rsab :=
  snd (@derl_dersl_mono' X rulesa rulesb rsab).

Definition derl_mono X rulesa rulesb rsab :=
  rsubI _ _ (@derl_mono' X rulesa rulesb rsab).
Definition dersl_mono X rulesa rulesb rsab :=
  rsubI _ _ (@dersl_mono' X rulesa rulesb rsab).

Lemma derrec_nil_derl_s X rules: (forall concl,
  derrec rules (@emptyT X) concl -> derl rules [] concl) *
  (forall cs, dersrec rules (@emptyT X) cs -> dersl rules [] cs).
Proof.
apply derrec_dersrec_rect_mut ; intros.
- inversion p.
- eapply dtderI ; eassumption.
- apply dtNil.
- eapply dtCons_eq. eassumption. eassumption. tauto. Qed.

Definition derrec_nil_derl X rules := fst (@derrec_nil_derl_s X rules).
Definition dersrec_nil_dersl X rules := snd (@derrec_nil_derl_s X rules).

Definition derI_rules_mono X rules rulesb prems ps concl rs fuv :=
  @derI X rulesb prems ps concl (@rsub_imp _ _ rules rulesb rs ps concl fuv).
(*
Check derrec_trans_imp.
Check derl_derrec_trans.
Check derrec_derl_deriv.
Check dersl_app_eq.
Check derl_trans.
Check dersl_trans.
Check derl_deriv.
*)

(** induction for two proof trees **)

Lemma derrec_all_rect2:
  forall X Y (rulesx : list X -> X -> Type) (rulesy : list Y -> Y -> Type)
    (premsx : X -> Type) (premsy : Y -> Type) (Q : X -> Y -> Type),
    (forall px, premsx px -> forall cy, derrec rulesy premsy cy -> Q px cy) ->
    (forall py, premsy py -> forall cx, derrec rulesx premsx cx -> Q cx py) ->
    (forall psx cx psy cy, rulesx psx cx -> rulesy psy cy ->
      dersrec rulesx premsx psx -> dersrec rulesy premsy psy ->
      ForallT (fun px => Q px cy) psx -> ForallT (Q cx) psy -> Q cx cy) ->
    forall (conclx : X), derrec rulesx premsx conclx ->
    forall (concly : Y), derrec rulesy premsy concly ->
    Q conclx concly.
Proof.  intros until conclx. intro Dx.
eapply (derrec_all_rect (Q := fun conclx =>
  forall concly : Y, derrec rulesy premsy concly -> Q conclx concly)).
intros.  apply X0. exact X3. exact X4.
intros until concly. intro Dy.
eapply (derrec_all_rect (Q := Q concl)).
intros. apply X1. exact X6.  eapply derI ; eassumption.
intros. eapply X2. eassumption. eassumption. assumption. assumption.
eapply ForallT_impl in X5. exact X5.
intros. simpl. apply X9. eapply derI ; eassumption.
assumption.  assumption.  assumption.  Qed.
(*
Check derrec_all_rect2.
*)
(* version with no premises *)
Definition derrec_all_rect2_nops X Y rulesx rulesy Q :=
  @derrec_all_rect2 X Y rulesx rulesy emptyT emptyT Q
  (@emptyT_any' X _) (@emptyT_any' Y _).
(*
Check derrec_all_rect2_nops.
*)
(** admissibility **)

Inductive adm X rules ps c : Type :=
  | admI : (dersrec rules (@emptyT X) ps -> derrec rules (@emptyT X) c) ->
    adm X rules ps c.

Definition admD X rules ps c (a : @adm X rules ps c) :=
  match a with | admI d => d end.
Definition admDs X rules p c a d := @admD X rules [p] c a (dersrec_singleI d).

Lemma derl_sub_adm X rules ps c : @derl X rules ps c -> adm rules ps c.
Proof. intro. apply admI.  apply derl_derrec_trans. assumption. Qed.

Definition rsub_derl_adm X rules := rsubI _ _ (@derl_sub_adm X rules).

Definition in_adm X rules ps c r := derl_sub_adm (@in_derl X rules ps c r).
Definition rsub_adm X rules := rsubI _ _ (@in_adm X rules).

Lemma derrec_adm' X rls:
  (forall c, derrec (adm rls) (@emptyT X) c -> derrec rls (@emptyT X) c) *
  (forall cs, dersrec (adm rls) (@emptyT X) cs -> dersrec rls (@emptyT X) cs).
Proof. apply derrec_dersrec_rect_mut ; intros.
- inversion p.
- inversion r. apply X1. apply X0.
- apply dlNil.
- apply dlCons ; assumption. Qed.

Definition derrec_adm X rls := fst (@derrec_adm' X rls).
Definition dersrec_adm X rls := snd (@derrec_adm' X rls).

Lemma adm_adm X rules ps c : @adm X (adm rules) ps c -> adm rules ps c.
Proof. intros aa. inversion aa. apply admI. intros dps.
apply derrec_adm. apply X0. eapply dersrec_rmono.
apply rsubI. apply in_adm. assumption.  Qed.

Lemma derl_adm_s X rules :
  (forall ps (c : X), derl (adm rules) ps c -> adm rules ps c) *
  (forall ps cs, dersl (adm rules) ps cs -> ForallT (adm rules ps) cs).
Proof. apply derl_dersl_rect_mut ; intros.
- apply admI. intro. inversion X0. assumption.
- apply admI. destruct r. intros dpss. apply d0.
apply dersrecI_forall. intros c icp.
eapply ForallTD_forall in X0.
destruct X0. apply d1. apply dpss. apply icp.
- apply ForallT_nil.
- apply ForallT_cons. apply admI. inversion X0.
intro. apply X2. apply dersrec_appL in X3. assumption.
apply ForallTI_forall. intros x ixcs.
apply admI. intros dsa.
eapply ForallTD_forall in X1.
inversion X1. apply X2. apply dersrec_appR in dsa.
exact dsa.  exact ixcs. Qed.

Definition derl_adm X rules := fst (@derl_adm_s X rules).
Definition dersl_adm X rules := snd (@derl_adm_s X rules).

(* also adm (derl rules) = adm rules *)

(* plug-in replacement for derl_derrec_trans *)
Lemma adm_derrec_trans X rules rps concl: @adm X rules rps concl ->
  dersrec rules (@emptyT X) rps -> derrec rules (@emptyT X) concl.
Proof. intros a drs. destruct a. apply d. apply drs. Qed.

Lemma adm_single_trans X rules prems p c:
  adm rules prems p -> @adm X rules [p] c -> adm rules prems c.
Proof. split. destruct X0. inversion X1.
intro dps. apply X0. right. apply (d dps). left. Qed.

Lemma derrec_eq_swap : forall (T : Type) rules prems G H
    (pf : (G : T) = H),
    derrec rules prems G ->
    derrec rules prems H.
Proof.  intros. subst. assumption. Qed.

Lemma dersrec_double: forall X rules prems c1 c2,
  iffT (dersrec rules prems [c1;c2]) ((derrec rules prems (c1 : X)) * (derrec rules prems (c2 : X))).
Proof.
  intros. split; intros H.
  split; (eapply dersrecD_forall; [apply H |]).
  constructor 1. reflexivity.
  constructor 2. constructor 1. reflexivity.
  eapply dersrecI_forall. intros c Hc.
  inversion Hc as [ | ? ? H2]; subst. apply H.
  inversion H2 as [ | ? ? H3]; subst. apply H.
  inversion H3.
Qed.

Definition dersrec_doubleD X rs ps c1 c2 := iffT_D1 (@dersrec_double X rs ps c1 c2).