(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.totalorder.QposMinMax.
Require Import CoRN.model.reals.Cauchy_IR.
Require Import CoRN.tactics.CornTac.
From Coq Require Import Lia.
Require Import CoRN.model.metric2.Qmetric.
Require Import CoRN.model.totalorder.QMinMax.
Require Import Coq.QArith.Qabs.
Require Export CoRN.reals.fast.CRFieldOps.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

Set Automatic Introduction.

Local Open Scope nat_scope.

Opaque Qmin Qmax.

(**
** Isomorphism between CR and Cauchy_IR
In prove that CR is a real number structure, we must climb the algebraic
heirarchy.  The easiest way of doing this is to construct an isomorphism
between Cauchy_IR and CR because they are similar strucutres.
Then we can leverage the proofs that Cauchy_IR is a real number structure.

*** CR to Cauchy_IR
*)

Definition CRasCauchy_IR_raw (x:CR) (n:nat)
  := approximate x (Qpos2QposInf (1 # P_of_succ_nat n)).

Lemma CRasCauchy_IR_raw_is_Cauchy : forall (x:CR),
Cauchy_prop (R:=Q_as_COrdField) (CRasCauchy_IR_raw x).
Proof.
 intros x e He.
 destruct e as [en ed].
 destruct en as [|en|en]. inversion He. 2: inversion He.
 unfold CRasCauchy_IR_raw.
 exists (pred (nat_of_P (2*ed))).
 rewrite <- anti_convert_pred_convert.
 intros m Hm.
 change (ball (en#ed) (approximate x (Qpos2QposInf (1 # P_of_succ_nat m)))
              (approximate x (Qpos2QposInf (1#(2*ed))))).
 eapply ball_weak_le ;[|apply regFun_prf].
 simpl.
 apply Qle_trans with (((1 # P_of_succ_nat (pred (nat_of_P (2*ed)))) + (1 # 2 * ed)))%Q.
  eapply plus_resp_leEq.
  change (P_of_succ_nat (pred (nat_of_P (2*ed))) <= P_of_succ_nat m)%Z.
  rewrite <-!POS_anti_convert. apply inj_le. lia.
 rewrite <- anti_convert_pred_convert.
 stepl ((2#1)*(1#(2*ed)))%Q; [|simpl; ring].
 change ((2#1)*((1/2)*(1/ed)) <= en#ed)%Q.
 ring_simplify.
 change ((2#2)*(1/ed)<=en#ed)%Q.
 setoid_replace (2#2)%Q  with 1%Q by constructor.
 ring_simplify.
 auto with *.
Qed.

Definition CRasCauchy_IR (x:CR) : Cauchy_IR :=
Build_CauchySeq _ _ (CRasCauchy_IR_raw_is_Cauchy x).

Lemma CRasCauchy_IR_wd : forall (x y:CR), (x==y)%CR -> CRasCauchy_IR x[=]CRasCauchy_IR y.
Proof.
 intros x y Hxy.
 eapply Eq_alt_2_2.
 intros e He.
 destruct e as [en ed].
 destruct en as [|en|en]. inversion He. 2: inversion He.
 exists (pred(nat_of_P (2*ed))).
 intros m Hm.
 simpl.
 unfold CRasCauchy_IR_raw.
 set (d:=(1 # P_of_succ_nat m)%Qpos).
 change (ball (en#ed) (approximate x (Qpos2QposInf d)) (approximate y (Qpos2QposInf d))).
 eapply ball_weak_le;[|apply Hxy].
 unfold d. simpl.
 ring_simplify.
 apply Qle_trans with ((2#1)*(1#(2 * ed)))%Q.
  eapply mult_resp_leEq_lft;try discriminate.
  change ((2*ed)<=P_of_succ_nat m)%Z.
  rewrite <- Zpos_mult_morphism.
  rewrite (anti_convert_pred_convert (2*ed)).
  do 2 rewrite <- POS_anti_convert.
  apply inj_le.
  auto with *.
 change (1#2*ed)%Q with ((1#2)*(1#ed))%Q.
 ring_simplify.
 auto with *.
Qed.

(**
*** Cauchy_IR to CR
*)

Definition Cauchy_IRasCR_raw (x:Cauchy_IR) (e:QposInf) : Q.
Proof.
 revert e.
 intros [e|];[|exact 0%Q].
 destruct x as [f Hf].
 unfold Cauchy_prop in Hf.
 destruct (Hf (proj1_sig e) (Qpos_ispos e)) as [n Hn].
 exact (f n).
Defined.

Lemma Cauchy_IRasCR_is_Regular : forall (x:Cauchy_IR),
    is_RegularFunction Qball (Cauchy_IRasCR_raw x).
Proof.
 intros [f Hf] e1 e2.
 simpl.
 destruct (Hf (proj1_sig e1) (Qpos_ispos e1)) as [n1 Hn1].
 destruct (Hf (proj1_sig e2) (Qpos_ispos e2)) as [n2 Hn2].
 cut (forall (e1 e2:Qpos) n1 n2, n2 <= n1 ->
   (forall m : nat, n1 <= m -> AbsSmall (R:=Q_as_COrdField) (proj1_sig e1) (f m[-]f n1)) ->
     (forall m : nat, n2 <= m -> AbsSmall (R:=Q_as_COrdField) (proj1_sig e2) (f m[-]f n2)) ->
       Qball (proj1_sig e1 + proj1_sig e2) (f n1) (f n2)).
  intros H.
  destruct (le_ge_dec n1 n2).
   eapply ball_sym;simpl.
   assert (QposEq (e1+e2) (e2+e1)) by (unfold QposEq; simpl; ring).
   apply (ball_wd _ H0 _ _ (reflexivity _) _ _ (reflexivity _)). clear H0.
   apply H; assumption.
  auto.
 clear - Hf.
 intros e1 e2 n1 n2 H Hn1 Hn2.
 assert (QposEq (e1+e2) (e2+e1)) by (unfold QposEq; simpl; ring).
 apply (ball_wd _ H0 _ _ (reflexivity _) _ _ (reflexivity _)). clear H0.
 eapply ball_weak. apply Qpos_nonneg.
 eapply Hn2.
 assumption.
Qed.

Definition Cauchy_IRasCR (x:Cauchy_IR) : CR :=
Build_RegularFunction (Cauchy_IRasCR_is_Regular x).

Lemma Cauchy_IRasCR_wd
  : forall (x y:Cauchy_IR), x[=]y -> (Cauchy_IRasCR x==Cauchy_IRasCR y)%CR.
Proof.
 intros [x Hx] [y Hy] Hxy.
 apply regFunEq_equiv, regFunEq_e.
 intros e.
 apply ball_closed.
 intros d dpos.
 simpl.
 destruct (Hx (proj1_sig e) (Qpos_ispos e)) as [a Ha].
 destruct (Hy (proj1_sig e) (Qpos_ispos e)) as [b Hb].
 destruct (Eq_alt_2_1 _ _ _ Hxy _ dpos) as [c Hc].
 simpl in Hc.
 unfold Qball.
 set (n:=max (max a b) c).
 unfold QAbsSmall.
 setoid_replace (x a - y b)%Q
   with ((x a - x n) + (y n - y b) + (x n - y n))%Q.
 2: ring.
 autorewrite with QposElim.
 repeat (eapply AbsSmall_plus).
   apply AbsSmall_minus.
   apply Ha;unfold n;apply le_trans with (max a b); auto with *.
  apply Hb; unfold n;apply le_trans with (max a b); auto with *.
 apply Hc; unfold n;auto with *.
Qed.

(** Composition is the identity *)
Lemma CRasCR : forall x:CR, (Cauchy_IRasCR (CRasCauchy_IR x)==x)%CR.
Proof.
 intros x.
 apply regFunEq_equiv, regFunEq_e.
 intros e.
 simpl.
 destruct (CRasCauchy_IR_raw_is_Cauchy x (proj1_sig e) (Qpos_ispos e)) as [n Hn].
 unfold CRasCauchy_IR_raw in *.
 apply ball_closed.
 intros d dpos.
 setoid_replace (proj1_sig e+proj1_sig e+d)%Q
   with (proj1_sig (e+(exist _ _ dpos+e))%Qpos)
   by (simpl; ring).
 destruct d as [dn dd].
 destruct dn as [|dn|dn]. inversion dpos. 2: inversion dpos.
 apply ball_triangle with (approximate x (Qpos2QposInf (1#P_of_succ_nat (n+(nat_of_P dd)))))%Qpos.
 - apply ball_sym.
  eapply Hn;auto with *.
 - eapply ball_weak_le;[|apply regFun_prf].
 simpl.
 eapply plus_resp_leEq;simpl.
 apply Qle_trans with (1#dd)%Q.
  change (dd <= P_of_succ_nat (n + nat_of_P dd))%Z.
  destruct n.
   simpl.
   rewrite P_of_succ_nat_o_nat_of_P_eq_succ.
   rewrite Pplus_one_succ_r.
   rewrite Zpos_plus_distr.
   auto with *.
  rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ.
  rewrite <- nat_of_P_plus_morphism.
  rewrite P_of_succ_nat_o_nat_of_P_eq_succ.
  rewrite Pplus_one_succ_r.
  repeat rewrite Zpos_plus_distr.
  rewrite <- Zplus_assoc.
  rewrite Zplus_comm.
  rewrite <- Zplus_assoc.
  rewrite <- Zpos_plus_distr.
  rewrite <- Pplus_one_succ_l.
  change (dd+0 <=  dd + Pos.succ (P_of_succ_nat n))%Z.
  auto with *.
 change (dd <= dn*dd)%Z.
 auto with *.
Qed.

Lemma Cauchy_IRasCauchy_IR : forall x:Cauchy_IR, CRasCauchy_IR (Cauchy_IRasCR x)[=]x.
Proof.
 intros [x Hx].
 eapply Eq_alt_2_2.
 intros e He.
 assert (Z:(0<(1#2)*e)%Q).
  rewrite <- (Qmult_0_r (1#2)).
  eapply mult_resp_less_lft.
   exact He.
  constructor.
 destruct (Hx _ Z) as [n Hn].
 destruct e as [en ed].
 destruct en as [|en|en]. inversion He. 2: inversion He.
 exists (max n (nat_of_P ed)).
 intros m Hm.
 simpl.
 destruct Hx as [n' Hn'].
 apply AbsSmall_minus.
 destruct (le_lt_dec n' m) as [H|H].
  eapply AbsSmall_trans;[|apply Hn';assumption].
  change (ed < en*(P_of_succ_nat m))%Z.
  apply Z.lt_le_trans with (P_of_succ_nat m).
   rewrite <- POS_anti_convert.
   rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
   apply inj_lt.
   apply le_lt_n_Sm.
   apply le_trans with (max n (nat_of_P ed));auto with *.
  change (1*P_of_succ_nat m <= en * P_of_succ_nat m)%Z.
  apply Zmult_lt_0_le_compat_r;auto with *.
 stepl ((1#2)*(Z.pos en#ed)+(1#2)*(Z.pos en#ed))%Q; [| simpl; ring].
 rstepr ((x m[-]x n)[+](x n[-]x n')).
 assert (Y:n <= m).
  apply le_trans with (max n (nat_of_P ed));auto with *.
 apply AbsSmall_plus.
  apply Hn.
  assumption.
 apply AbsSmall_minus; auto with *.
Qed.

(** Equalities are well defined. *)
Lemma Cauchy_IR_eq_as_CR_eq : forall (x y:Cauchy_IR),
((Cauchy_IRasCR x) == (Cauchy_IRasCR y))%CR <-> x[=]y.
Proof.
 intros x y.
 split;[|apply Cauchy_IRasCR_wd].
 intros H.
 stepl (CRasCauchy_IR (Cauchy_IRasCR x)); [| apply Cauchy_IRasCauchy_IR].
 stepr (CRasCauchy_IR (Cauchy_IRasCR y)); [| apply Cauchy_IRasCauchy_IR].
 apply CRasCauchy_IR_wd.
 assumption.
Qed.

Lemma CR_eq_as_Cauchy_IR_eq : forall (x y:CR),
(CRasCauchy_IR x [=] CRasCauchy_IR y) <-> (x==y)%CR.
Proof.
 intros x y.
 set (x':=CRasCauchy_IR x).
 set (y':=CRasCauchy_IR y).
 rewrite <- (CRasCR x).
 rewrite <- (CRasCR y).
 symmetry.
 apply Cauchy_IR_eq_as_CR_eq.
Qed.

Local Open Scope uc_scope.
(**
*** Functions preserved by isomorphism.
*)
Lemma reverse_iso_wd_fun : forall
(f:Cauchy_IR -> Cauchy_IR)
(g:CR -> CR),
(forall x y, (x==y -> g x == g y)%CR) ->
(forall (x:Cauchy_IR),
(g (Cauchy_IRasCR x) == Cauchy_IRasCR (f x))%CR) ->
forall (x:CR),
(f (CRasCauchy_IR x) [=] CRasCauchy_IR (g x)).
Proof.
 intros f g g_wd H x.
 stepl (CRasCauchy_IR (Cauchy_IRasCR (f (CRasCauchy_IR x)))); [| apply Cauchy_IRasCauchy_IR].
 apply CRasCauchy_IR_wd.
 symmetry.
 transitivity (g (Cauchy_IRasCR (CRasCauchy_IR x))).
  apply g_wd.
  symmetry.
  apply CRasCR.
 apply H.
Qed.

Lemma reverse_iso_uc_fun : forall
(f:Cauchy_IR -> Cauchy_IR)
(g:CR --> CR),
(forall (x:Cauchy_IR),
(g (Cauchy_IRasCR x) == Cauchy_IRasCR (f x))%CR) ->
forall (x:CR),
(f (CRasCauchy_IR x) [=] CRasCauchy_IR (g x)).
Proof.
 intros f g H x.
 apply reverse_iso_wd_fun.
  apply uc_wd.
 assumption.
Qed.

Lemma reverse_iso_bin_wd_fun : forall
(f:Cauchy_IR -> Cauchy_IR -> Cauchy_IR)
(g:CR -> CR -> CR),
(forall w x, (w == x)%CR -> forall y z, (y == z -> g w y == g x z)%CR) ->
(forall (x y:Cauchy_IR),
(g (Cauchy_IRasCR x) (Cauchy_IRasCR y) == Cauchy_IRasCR (f x y))%CR) ->
forall (x y:CR),
(f (CRasCauchy_IR x) (CRasCauchy_IR y) [=] CRasCauchy_IR (g x y)).
Proof.
 intros f g g_wd H x y.
 stepl (CRasCauchy_IR (Cauchy_IRasCR (f (CRasCauchy_IR x) (CRasCauchy_IR y))));
   [| apply Cauchy_IRasCauchy_IR].
 apply CRasCauchy_IR_wd.
 symmetry.
 transitivity (g (Cauchy_IRasCR (CRasCauchy_IR x)) (Cauchy_IRasCR (CRasCauchy_IR y))); [|apply H].
 apply g_wd; symmetry; apply CRasCR.
Qed.

Lemma reverse_iso_bin_uc_fun : forall
(f:Cauchy_IR -> Cauchy_IR -> Cauchy_IR)
(g:CR --> CR --> CR),
(forall (x y:Cauchy_IR),
(g (Cauchy_IRasCR x) (Cauchy_IRasCR y) == Cauchy_IRasCR (f x y))%CR) ->
forall (x y:CR),
(f (CRasCauchy_IR x) (CRasCauchy_IR y) [=] CRasCauchy_IR (g x y)).
Proof.
 intros f g H x y.
 apply (reverse_iso_bin_wd_fun f (ucFun2 g)).
  apply ucFun2_wd.
 assumption.
Qed.

(** injection of rationals is preserved. *)
Lemma Cauchy_IR_inject_Q_as_CR_inject_Q : forall x:Q,
(' x == Cauchy_IRasCR (Cauchy_CReals.inject_Q _ x))%CR.
Proof.
 intros x.
 apply regFunEq_equiv, regFunEq_e.
 intros e.
 simpl.
 destruct (CS_seq_const Q_as_COrdField x (proj1_sig e) (Qpos_ispos e)).
 eapply ball_refl.
 apply (Qpos_nonneg (e + e)).
Qed.

#[global]
Hint Rewrite Cauchy_IR_inject_Q_as_CR_inject_Q : CRtoCauchy_IR.

Lemma CR_inject_Q_as_Cauchy_IR_inject_Q : forall x:Q,
Cauchy_CReals.inject_Q _ x [=] CRasCauchy_IR (' x)%CR.
Proof.
 intros x.
 eapply Eq_alt_2_2.
 simpl.
 intros e He.
 exists 0.
 intros m Hm.
 unfold cg_minus.
 rstepr ([0]:Q).
 apply zero_AbsSmall.
 apply Qlt_le_weak.
 assumption.
Qed.

(** plus is preserved. *)
Lemma Cauchy_IR_plus_as_CR_plus : forall x y:Cauchy_IR,
(Cauchy_IRasCR x + Cauchy_IRasCR y == Cauchy_IRasCR (x[+]y))%CR.
Proof.
 intros [x Hx] [y Hy].
 apply regFunEq_equiv, regFunEq_e.
 intros e.
 simpl.
 unfold Cap_raw.
 simpl.
 destruct (Hx (proj1_sig ((1 # 2) * e)%Qpos)) as [n1 Hn1].
 destruct (Hy (proj1_sig ((1 # 2) * e)%Qpos)) as [n2 Hn2].
 destruct (CS_seq_plus) as [n3 Hn3].
 set (n:= max n3 (max n1 n2)).
 change (@ball Q_as_MetricSpace (proj1_sig e+proj1_sig e) (x n1 + y n2) (x n3 + y n3))%Q.
 apply ball_triangle with (x n + y n)%Q.
  assert (QposEq e (((1 # 2) * e +(1 # 2) * e))) by (unfold QposEq; simpl; ring).
  apply (ball_wd _ H _ _ (reflexivity _) _ _ (reflexivity _)). clear H.
  apply ball_triangle with (x n1 + y n)%Q; simpl; unfold Qball.
  unfold QAbsSmall.
  setoid_replace (x n1 + y n2 - (x n1 + y n))%Q with (y n2 - y n)%Q.
  2: ring.
   apply AbsSmall_minus.
   apply Hn2.
   unfold n.
   rewrite max_assoc.
   auto with *.
   unfold QAbsSmall.
   setoid_replace (x n1 + y n - (x n + y n))%Q with (x n1 - x n)%Q.
   2: ring.
  apply AbsSmall_minus.
  apply Hn1.
  unfold n.
  rewrite (max_comm n1).
  rewrite max_assoc.
  auto with *.
 eapply Hn3; unfold n; auto with *.
Qed.

#[global]
Hint Rewrite Cauchy_IR_plus_as_CR_plus : CRtoCauchy_IR.

Lemma CR_plus_as_Cauchy_IR_plus : forall x y:CR,
CRasCauchy_IR x [+] CRasCauchy_IR y [=] CRasCauchy_IR (x+y)%CR.
Proof.
 apply reverse_iso_bin_uc_fun.
 apply Cauchy_IR_plus_as_CR_plus.
Qed.

(** opp is preserved. *)
Lemma Cauchy_IR_opp_as_CR_opp : forall x:Cauchy_IR,
(-Cauchy_IRasCR x == Cauchy_IRasCR ([--]x))%CR.
Proof.
 intros [x Hx].
 apply regFunEq_equiv, regFunEq_e.
 intros e.
 simpl.
 destruct (Hx (proj1_sig e) (Qpos_ispos e)) as [n1 Hn1].
 destruct (CS_seq_inv Q_as_COrdField x Hx (proj1_sig e) (Qpos_ispos e)) as [n2 Hn2].
 set (n:=(max n1 n2)).
 change (@ball Q_as_MetricSpace (proj1_sig e+proj1_sig e) (- x n1) (- x n2))%Q.
 apply (@ball_triangle Q_as_MetricSpace _ _ _ (- x n)%Q). simpl; unfold Qball.
 unfold QAbsSmall.
 setoid_replace (- x n1 - - x n)%Q with (x n - x n1)%Q.
 2: ring. apply (Hn1 n). apply Nat.le_max_l.
 apply Hn2. apply Nat.le_max_r.
Qed.

#[global]
Hint Rewrite Cauchy_IR_opp_as_CR_opp : CRtoCauchy_IR.

Lemma CR_opp_as_Cauchy_IR_opp : forall x:CR,
[--](CRasCauchy_IR x) [=] CRasCauchy_IR (- x)%CR.
Proof.
 apply reverse_iso_uc_fun.
 apply Cauchy_IR_opp_as_CR_opp.
Qed.

(** le is preserved. *)
Lemma Cauchy_IR_le_as_CR_le : forall (x y:Cauchy_IR),
(Cauchy_IRasCR x <= Cauchy_IRasCR y)%CR <-> x[<=]y.
Proof.
 intros [x Hx] [y Hy].
 split.
  intros H1 [n [e He H2]].
  assert (H1':=H1 ((1#3)*(exist _ _ He))%Qpos).
  clear H1.
  simpl in H1'.
  unfold Cap_raw in H1'; simpl in H1'.
  destruct (Hy (proj1_sig ((1 # 2) * ((1#3)* exist _ _ He))%Qpos)) as [n1 Hn1] in H1'.
  destruct (Hx (proj1_sig ((1 # 2) * ((1#3)* exist _ _ He))%Qpos)) as [n2 Hn2] in H1'.
  simpl in H2.
  set (m:=max n (max n1 n2)).
  assert (m1:n<=m);[unfold m; auto with *|].
  assert (m2:n1<=m);[unfold m; apply le_trans with (max n1 n2); auto with *|].
  assert (m3:n2<=m);[unfold m; apply le_trans with (max n1 n2); auto with *|].
  apply (Qle_not_lt _ _ H1').
  eapply inv_cancel_less;simpl.
  clear H1'.
  autorewrite with QposElim in *.
  apply Qlt_le_trans with ((2#3)*e)%Q.
   ring_simplify.
   eapply mult_resp_less.
    constructor.
   assumption.
  stepl (e + - ((1#2)*((1#3)*e)) + - ((1#2)*((1#3)*e)))%Q; [| simpl; ring].
  stepr ((x m - y m) + (y m - y n1) + -(x m - x n2))%Q; [| simpl; ring].
  eapply plus_resp_leEq_both.
   apply plus_resp_leEq_both.
    apply H2; assumption.
   refine (proj1 (Hn1 m _));assumption.
  apply inv_resp_leEq.
  refine (proj2 (Hn2 m _));assumption.
 (*Other Direction*)
 intros H e.
 simpl.
 unfold Cap_raw; simpl.
 destruct (Hy (proj1_sig ((1 # 2) * e)%Qpos)) as [n1 Hn1].
 destruct (Hx (proj1_sig ((1 # 2) * e)%Qpos)) as [n2 Hn2].
 apply Qnot_lt_le.
 intros A.
 apply H; clear H.
 exists (max n1 n2).
 simpl.
 set (n:=max n1 n2).
 exists (- proj1_sig e + - (y n1 + - x n2))%Q.
  rewrite <- Qlt_minus_iff.
  assumption.
 intros m Hm.
 unfold cg_minus.
 simpl.
 stepr ((x m - x n2) + -(y m - y n1) + -(y n1 + - x n2))%Q; [| simpl; ring].
 eapply plus_resp_leEq.
 stepl (-((1 # 2) * proj1_sig e) + - ((1 # 2) * proj1_sig e))%Q; [| simpl; ring].
 apply plus_resp_leEq_both.
  refine (proj1 (Hn2 _ _)).
  apply le_trans with n; [unfold n;auto with *|assumption].
 apply inv_resp_leEq.
 refine (proj2 (Hn1 _ _)).
 apply le_trans with n; [unfold n;auto with *|assumption].
Qed.

#[global]
Hint Rewrite Cauchy_IR_le_as_CR_le : CRtoCauchy_IR.

Lemma CR_le_as_Cauchy_IR_le : forall (x y:CR),
CRasCauchy_IR x[<=]CRasCauchy_IR y <-> (x<=y)%CR.
Proof.
 intros x y.
 rewrite <- Cauchy_IR_le_as_CR_le.
 do 2 rewrite -> CRasCR.
 reflexivity.
Qed.

(** mult is preserved. *)
Lemma Cauchy_IR_mult_as_CRmult_bounded : forall x y:Cauchy_IR,
forall (z:Qpos) (N:nat), (forall i:nat, (N<=i) -> AbsSmall (proj1_sig z) (CS_seq _ y i)) ->
(ucFun2 (CRmult_bounded z) (Cauchy_IRasCR x) (Cauchy_IRasCR y) == Cauchy_IRasCR (x[*]y))%CR.
Proof.
 intros [x Hx] y z N Hz.
 destruct y as [y Hy].
 apply regFunEq_equiv, regFunEq_e.
 intros e.
 simpl.
 destruct CS_seq_mult as [n3 Hn3].
 unfold Cap_raw.
 simpl in *.
 destruct Hx as [n1 Hn1].
 apply Qscale_modulus_elim.
  intros Hxn1.
  pose (n:=(max n3 (max n1 N))).
  rewrite -> Hxn1.
  assert (Qeq (0 * Qmax (- proj1_sig z) (Qmin (proj1_sig z)
    (Cauchy_IRasCR_raw (Build_CauchySeq Q_as_COrdField y Hy)(QposInf_bind (fun e0 : Qpos => e0) QposInfinity))))%Q (0 * y n)%Q).
   ring.
  rewrite -> H. clear H.
  change (@ball Q_as_MetricSpace (proj1_sig e+proj1_sig e) (0 * y n) (x n3 * y n3))%Q.
  apply ball_triangle with (x n*y n)%Q;[|eapply Hn3; unfold n; auto with *].
  apply ball_sym.
  simpl.
  setoid_replace (0 * y n)%Q with (x n1 * y n)%Q.
  2: rewrite Hxn1; reflexivity.
  unfold Qball.
  unfold QAbsSmall.
  setoid_replace (x n * y n - x n1 * y n)%Q with ((x n - x n1)*y n)%Q.
  2: ring.
  apply AbsSmall_trans with ((1#2)*proj1_sig e)%Q.
   apply half_3.
   apply Qpos_ispos.
   stepl (((1#2)*proj1_sig e/ proj1_sig z)* proj1_sig z)%Q;
     [| simpl;field;apply Qpos_nonzero].
  apply mult_AbsSmall;[apply Hn1|apply Hz]; unfold n; apply le_trans with (max n1 N); auto with *.
 intros w Hw.
 simpl.
 destruct (Hy (proj1_sig w) (Qpos_ispos w)) as [n2 Hn2].
 pose (n:=(max (max n1 n2) (max n3 N))).
 assert (n1 <= n);[unfold n; apply le_trans with (max n1 n2); auto with *|].
 assert (n2 <= n);[unfold n; apply le_trans with (max n1 n2); auto with *|].
 assert (n3 <= n);[unfold n; apply le_trans with (max n3 N); auto with *|].
 assert (N <= n);[unfold n; apply le_trans with (max n3 N); auto with *|].
 change (Qball (proj1_sig e+proj1_sig e))
   with (@ball Q_as_MetricSpace (proj1_sig e + proj1_sig e)).
 apply ball_triangle with (x n * y n)%Q;[|eapply Hn3; assumption].
 clear Hn3.
 assert (QposEq e ((1#2)*e + (1#2)*e)) by (unfold QposEq; simpl; ring).
 apply (ball_wd _ H3 _ _ (reflexivity _) _ _ (reflexivity _)). clear H3.
 apply ball_triangle with (x n1 * y n)%Q; apply ball_sym; simpl; unfold Qball.
 unfold QAbsSmall.
 setoid_replace (x n1 * y n - x n1 * Qmax (- proj1_sig z) (Qmin (proj1_sig z) (y n2)))%Q
   with (x n1*(y n - Qmax (- proj1_sig z) (Qmin (proj1_sig z) (y n2))))%Q. 2: ring.
 simpl.
  stepl (((1#2)*proj1_sig e/proj1_sig w)*proj1_sig w)%Q; [| simpl;field;apply Qpos_nonzero].
  apply mult_AbsSmall;[apply Hw|].
  destruct (Hz n H2) as [X0 X1].
  destruct (Hn2 _ H0) as [X2 X3].
  unfold cg_minus in *.
  simpl in *.
  change (Qmax (- proj1_sig z) (Qmin (proj1_sig z) (y n2)))%Q
    with (QboundAbs z (y n2))%Q.
  assert (A0:(- proj1_sig w<=0)%Q).
   rewrite -> Qle_minus_iff.
   ring_simplify.
   apply Qpos_nonneg.
  rewrite -> Qle_minus_iff in *.
  clear - A0 X0 X1 X2 X3 Hn2 H0.
  ring_simplify in A0.
  ring_simplify in X0.
  ring_simplify in X1.
  ring_simplify in X2.
  ring_simplify in X3.
  apply QboundAbs_elim; intros I; try solve [apply Hn2;assumption]; rewrite -> Qle_minus_iff in I.
   apply AbsSmall_minus.
   unfold cg_minus;simpl.
   apply leEq_imp_AbsSmall.
    apply X1.
   rewrite -> Qle_minus_iff.
   stepr ((y n + (-1 # 1) * y n2 + proj1_sig w)+(y n2 + - proj1_sig z))%Q; [| simpl; ring].
   eapply plus_resp_nonneg; assumption.
  eapply leEq_imp_AbsSmall; simpl; ring_simplify.
   apply X0.
  rewrite -> Qle_minus_iff.
  stepr ((proj1_sig w + (-1 # 1) * y n + y n2)+(- proj1_sig z + - y n2))%Q; [| simpl; ring].
  eapply plus_resp_nonneg; assumption.
  unfold QAbsSmall.
  setoid_replace (x n * y n - x n1 * y n)%Q with ((x n - x n1)*y n)%Q. 2: ring.
 autorewrite with QposElim.
 stepl (((1#2)*proj1_sig e/proj1_sig z)*proj1_sig z)%Q; [| simpl; field; apply Qpos_nonzero].
 apply mult_AbsSmall;[apply Hn1;assumption|apply Hz;assumption].
Qed.

Lemma AbsSmall_Qabs : forall x y, (Qabs y <= x)%Q <-> AbsSmall x y.
Proof.
 cut (forall x y, (0 <= y)%Q -> ((Qabs y <= x)%Q <-> AbsSmall (R:=Q_as_COrdField) x y)).
  intros H x y.
  generalize (H x y) (H x (-y)%Q).
  clear H.
  rewrite -> Qabs_opp.
  apply Qabs_case; intros H H1 H2.
   auto.
  assert (X:AbsSmall (R:=Q_as_COrdField) x y <-> AbsSmall (R:=Q_as_COrdField) x (- y)%Q).
   split.
    apply inv_resp_AbsSmall.
   intros X.
   stepr (- - y)%Q; [| simpl; ring].
   apply inv_resp_AbsSmall.
   assumption.
  rewrite -> X.
  eapply H2.
  rewrite -> Qle_minus_iff in H.
  ring_simplify in H.
  ring_simplify.
  apply H.
 intros x y H.
 rewrite -> Qabs_pos;[|assumption].
 split.
  intros H0.
  apply leEq_imp_AbsSmall; assumption.
 intros [_ H0].
 assumption.
Qed.

Lemma Cauchy_IR_mult_as_CR_mult : forall x y:Cauchy_IR,
((Cauchy_IRasCR x)*(Cauchy_IRasCR y) == Cauchy_IRasCR (x[*]y))%CR.
Proof.
 intros x [y Hy].
 destruct (CS_seq_bounded _ y Hy) as [k Hk [n Hn]].
 set (y':=Build_CauchySeq Q_as_COrdField y Hy).
 set (k':=(exist _ _ Hk)).
 transitivity ((ucFun2 (CRmult_bounded (CR_b (1 # 1) (Cauchy_IRasCR y')+k')%Qpos) (Cauchy_IRasCR x)
   (Cauchy_IRasCR y'))).
  apply CRmult_bounded_weaken.
    apply CR_b_lowerBound.
   apply CR_b_upperBound.
   simpl.
  rewrite -> Qle_minus_iff.
  ring_simplify.
  auto with *.
 apply Cauchy_IR_mult_as_CRmult_bounded with n.
 intros i Hi.
 eapply AbsSmall_trans;[|apply Hn;assumption].
 simpl.
 rewrite -> Qlt_minus_iff.
 unfold k'.
 autorewrite with QposElim.
 ring_simplify.
 clear.
 destruct Hy.
 rewrite Qplus_comm.
 apply Q.Qplus_lt_le_0_compat.
 reflexivity. apply Qabs_nonneg.
Qed.

#[global]
Hint Rewrite Cauchy_IR_mult_as_CR_mult : CRtoCauchy_IR.

Lemma CR_mult_as_Cauchy_IR_mult : forall x y:CR,
(CRasCauchy_IR x)[*](CRasCauchy_IR y) [=] CRasCauchy_IR (x*y)%CR.
Proof.
 apply reverse_iso_bin_wd_fun.
  apply CRmult_wd.
 apply Cauchy_IR_mult_as_CR_mult.
Qed.

(** lt is preserved. *)
Lemma Cauchy_IR_lt_as_CR_lt_1 : forall (x y:Cauchy_IR),
x[<]y -> (Cauchy_IRasCR x < Cauchy_IRasCR y)%CR.
Proof.
 intros x y [n [e He Hn]].
 exists (exist _ _ He).
 abstract ( autorewrite with CRtoCauchy_IR; intros [m [d Hd Hm]];
   refine (Qle_not_lt _ _ (Hn (max n m) _) _);[auto with *|]; rewrite -> Qlt_minus_iff;
     apply Qlt_le_trans with d;[assumption|]; autorewrite with QposElim in Hm; eapply Hm; auto with *
       ).
Defined.

Lemma CR_lt_as_Cauchy_IR_lt_1 : forall (x y:CR),
(x < y)%CR -> (CRasCauchy_IR x)[<](CRasCauchy_IR y).
Proof.
 intros x y [e He].
 apply shift_zero_less_minus'.
 apply (less_leEq_trans _ [0] (Cauchy_CReals.inject_Q _ (proj1_sig e))).
  eapply ing_lt.
  apply Qpos_ispos.
 unfold cg_minus.
 stepr (CRasCauchy_IR (y-x))%CR.
  stepl (CRasCauchy_IR (' proj1_sig e)%CR).
   rewrite <- Cauchy_IR_le_as_CR_le.
   do 2 rewrite -> CRasCR.
   assumption.
  eapply CR_inject_Q_as_Cauchy_IR_inject_Q.
 stepl (CRasCauchy_IR y[+]CRasCauchy_IR(- x)%CR).
  apply plus_resp_eq.
  eapply CR_opp_as_Cauchy_IR_opp.
 eapply CR_plus_as_Cauchy_IR_plus.
Qed.

Lemma Cauchy_IR_lt_as_CR_lt_2 : forall (x y:Cauchy_IR),
((Cauchy_IRasCR x) < (Cauchy_IRasCR y))%CR -> x[<]y.
Proof.
 intros x y H.
 stepl (CRasCauchy_IR (Cauchy_IRasCR (x))); [| apply Cauchy_IRasCauchy_IR].
 stepr (CRasCauchy_IR (Cauchy_IRasCR (y))); [| apply Cauchy_IRasCauchy_IR].
 apply CR_lt_as_Cauchy_IR_lt_1.
 assumption.
Qed.

Lemma CR_lt_as_Cauchy_IR_lt_2 : forall (x y:CR),
(CRasCauchy_IR x)[<](CRasCauchy_IR y) -> (x < y)%CR.
Proof.
 intros x y H.
 eapply CRltT_wd;try apply CRasCR.
 apply Cauchy_IR_lt_as_CR_lt_1.
 assumption.
Qed.

(** appartness is preserved. *)
Lemma Cauchy_IR_ap_as_CR_ap_1 : forall (x y:Cauchy_IR),
x[#]y -> (CRapartT (Cauchy_IRasCR x) (Cauchy_IRasCR y))%CR.
Proof.
 intros x y [H|H];[left|right];apply Cauchy_IR_lt_as_CR_lt_1; apply H.
Defined.

Lemma CR_ap_as_Cauchy_IR_ap_1 : forall (x y:CR),
CRapartT x y -> (CRasCauchy_IR x) [#] (CRasCauchy_IR y).
Proof.
 intros x y [H|H];[left|right];apply CR_lt_as_Cauchy_IR_lt_1; apply H.
Defined.

Lemma Cauchy_IR_ap_as_CR_ap_2 : forall (x y:Cauchy_IR),
(CRapartT (Cauchy_IRasCR x) (Cauchy_IRasCR y))%CR -> x[#]y.
Proof.
 intros x y [H|H];[left|right];apply Cauchy_IR_lt_as_CR_lt_2; apply H.
Qed.

Lemma CR_ap_as_Cauchy_IR_ap_2 : forall (x y:CR),
(CRasCauchy_IR x) [#] (CRasCauchy_IR y) -> CRapartT x y.
Proof.
 intros x y [H|H];[left|right];apply CR_lt_as_Cauchy_IR_lt_2; apply H.
Defined.

(** inv is preserved. *)
Lemma Cauchy_IR_inv_as_CRinv_pos : forall (x:Cauchy_IR) x_,
forall (z:Qpos) (N:nat), (forall i:nat, (N<=i) -> (proj1_sig z <= (CS_seq _ x i))%Q) ->
(CRinv_pos z (Cauchy_IRasCR x) == Cauchy_IRasCR (f_rcpcl x (@inr _ _ x_)))%CR.
Proof.
 intros [x Hx] [a [d d_ x_]] z n Hn.
 apply regFunEq_equiv, regFunEq_e.
 intros e.
 simpl.
 unfold Qinv_modulus.
 destruct (Hx (proj1_sig z * proj1_sig z * proj1_sig e)%Q) as [b Hb].
 destruct (CS_seq_recip) as [c Hc].
 set (y := (CS_seq_recip_seq Q_as_COrdField x d d_ a
             (fun (n : nat) (H : le a n) =>
              leEq_wdr Q_as_COrdField d
                (@cg_minus Q_as_CGroup (x n) (Qmake Z0 xH)) (x n) (x_ n H)
                (cg_inv_zero Q_as_CGroup (x n))))) in *.
 unfold CS_seq_recip_seq in y.
 simpl in y.
 set (m:=max (max a n) (max b c)).
 assert (Hm1: c<=m).
  unfold m; apply le_trans with (max b c); auto with *.
 change (@ball Q_as_MetricSpace (proj1_sig e+proj1_sig e) (/ Qmax (proj1_sig z) (x b))%Q (y c)).
 apply ball_triangle with (y m);[|eapply Hc;assumption].
 clear Hc.
 unfold y.
 destruct (lt_le_dec m a) as [Z|Z].
  elim (le_not_lt _ _ Z).
  unfold m.
  apply lt_le_trans with (S (max a n)); auto with *.
 change (AbsSmall (proj1_sig e) (/ Qmax (proj1_sig z) (x b)-1 * / x m))%Q.
 clear y.
 assert (T:(~ (x m == 0)%Q /\ ~ (Qmax (proj1_sig z) (x b) == 0)%Q)).
  split; apply (ap_symmetric_unfolded Q_as_CSetoid); eapply Qlt_not_eq.
   apply Qlt_le_trans with (proj1_sig z).
    apply Qpos_ispos.
   apply Hn.
   apply le_trans with (max a n).
    auto with *.
   unfold m; auto with *.
  apply Qlt_le_trans with (proj1_sig z); auto with *.
  stepr ((/(Qmax (proj1_sig z) (x b))*/(x m))*(x m - (Qmax (proj1_sig z) (x b))))%Q;
    [| simpl; field; assumption].
  stepl ((/ Qmax (proj1_sig z) (x b) * / x m)*((Qmax (proj1_sig z) (x b))*(x m)* proj1_sig e))%Q;
    [| simpl;field; assumption].
 apply mult_resp_AbsSmall.
  assert (foo:forall q:Q, (0<=q -> 0<=/q)%Q).
   intros [[|p|p] q] qH; apply qH.
  apply mult_resp_nonneg.
   apply foo.
   apply Qle_trans with (proj1_sig z).
    apply Qpos_nonneg.
   apply Qmax_ub_l.
  apply foo.
  apply Qle_trans with (proj1_sig z).
   apply Qpos_nonneg.
  apply Hn.
  apply le_trans with (max a n); unfold m; auto with *.
 simpl in x_.
 apply (AbsSmall_leEq_trans _ (proj1_sig z*proj1_sig z*proj1_sig e)%Q).
  apply mult_resp_leEq_rht;[apply mult_resp_leEq_both|]; try apply Qpos_nonneg.
   apply Qmax_ub_l.
  apply Hn.
  apply le_trans with (max a n); unfold m; auto with *.
 assert (W:AbsSmall (R:=Q_as_COrdField) (proj1_sig z * proj1_sig z * proj1_sig e)%Q (x m - x b)%Q).
  apply Hb.
  apply le_trans with (max b c); unfold m; auto with *.
 apply Qmax_case;intros C;[|assumption].
 apply leEq_imp_AbsSmall.
  unfold Qminus.
  rewrite <- Qle_minus_iff.
  apply Hn.
  apply le_trans with (max a n); unfold m; auto with *.
 apply Qle_trans with (x m - x b)%Q.
  rewrite -> Qle_minus_iff.
  stepr (proj1_sig z + - x b)%Q; [| simpl; ring].
  rewrite <- Qle_minus_iff.
  assumption.
 destruct W; assumption.
Qed.

Lemma Cauchy_IR_nonZero_as_CR_nonZero_1 : forall (x:Cauchy_IR),
Dom (f_rcpcl' _) x -> (CRapartT (Cauchy_IRasCR x) 0)%CR.
Proof.
 intros x x_.
 eapply CRapartT_wd.
   reflexivity.
  symmetry.
  apply Cauchy_IR_inject_Q_as_CR_inject_Q.
 apply Cauchy_IR_ap_as_CR_ap_1.
 assumption.
Defined.

Lemma CR_nonZero_as_Cauchy_IR_nonZero_1 : forall (x:CR),
(CRapartT x 0)%CR -> Dom (f_rcpcl' _) (CRasCauchy_IR x).
Proof.
 intros x x_.
 change ((CRasCauchy_IR x)[#][0]).
 stepr (CRasCauchy_IR 0%CR).
  apply CR_ap_as_Cauchy_IR_ap_1.
  assumption.
 eapply CR_inject_Q_as_Cauchy_IR_inject_Q.
Defined.

Lemma Cauchy_IR_inv_as_CR_inv_short : forall (x:Cauchy_IR) x_,
(@CRinvT (Cauchy_IRasCR x) (Cauchy_IR_nonZero_as_CR_nonZero_1 _ x_) == Cauchy_IRasCR (f_rcpcl x x_))%CR.
Proof.
 intros [x Hx] [H|H].
  set (x':=(Build_CauchySeq Q_as_COrdField x Hx)) in *.
  assert (H':(cm_unit Cauchy_IR)[<][--](x':Cauchy_IR)).
   apply inv_cancel_less.
   rstepl x'.
   assumption.
  set (y:= (Cauchy_IRasCR [--](f_rcpcl (F:=Cauchy_IR) ([--](x':Cauchy_IR)) (@inr _ _ H')))%CR).
  transitivity y.
   destruct H as [n [e He H]].
   change (-(CRinv_pos (exist _ _ He) (- Cauchy_IRasCR (Build_CauchySeq Q_as_COrdField x Hx)))==y)%CR.
   unfold y.
   rewrite <- Cauchy_IR_opp_as_CR_opp.
   apply CRopp_wd.
   set (X := (Cauchy_IRasCR (f_rcpcl (F:=Cauchy_IR) [--](x':Cauchy_IR)
     (@inr (R_lt Q_as_COrdField [--](x':Cauchy_IR) ([0]:Cauchy_IR)) ([0][<][--](x':Cauchy_IR)) H')))%CR).
   rewrite -> Cauchy_IR_opp_as_CR_opp.
   eapply Cauchy_IR_inv_as_CRinv_pos.
   intros i Hi.
   autorewrite with QposElim.
   simpl.
   stepr (0 - x i)%Q; [| simpl; ring].
   eapply H.
   apply Hi.
  unfold y.
  apply Cauchy_IRasCR_wd.
  eapply mult_cancel_lft.
   left.
   apply H.
  stepr ([1]:Cauchy_IR).
   eapply eq_transitive.
    apply cring_inv_mult_lft.
   apply eq_symmetric.
   eapply eq_transitive;[|apply cring_inv_mult_rht].
   apply eq_symmetric.
   apply x_div_x.
  apply eq_symmetric.
  apply x_div_x.
 destruct H as [n [e He H]].
  eapply Cauchy_IR_inv_as_CRinv_pos.
 intros i Hi.
 autorewrite with QposElim.
 simpl in *.
 stepr (x i- 0)%Q; [| simpl; ring].
 apply H.
 apply Hi.
Qed.

#[global]
Hint Rewrite Cauchy_IR_inv_as_CR_inv_short : CRtoCauchy_IR.

Lemma Cauchy_IR_inv_as_CR_inv : forall (x:Cauchy_IR) x_ H,
(@CRinvT (Cauchy_IRasCR x) H == Cauchy_IRasCR (f_rcpcl x x_))%CR.
Proof.
 intros x x_ H.
 rewrite <- Cauchy_IR_inv_as_CR_inv_short.
 apply CRinvT_irrelevant.
Qed.

Lemma CR_inv_as_Cauchy_IR_inv : forall (x:CR) x_ H,
f_rcpcl (CRasCauchy_IR x) H [=] CRasCauchy_IR (@CRinvT x x_).
Proof.
 intros x x_ H.
 stepl (CRasCauchy_IR (Cauchy_IRasCR (f_rcpcl (CRasCauchy_IR x) H))); [| apply Cauchy_IRasCauchy_IR].
 apply CRasCauchy_IR_wd.
 rewrite <- Cauchy_IR_inv_as_CR_inv_short.
 apply CRinvT_wd.
 apply CRasCR.
Qed.

Lemma CR_inv_as_Cauchy_IR_inv_short : forall (x:CR) x_,
f_rcpcl (CRasCauchy_IR x) (CR_nonZero_as_Cauchy_IR_nonZero_1 _ x_) [=] CRasCauchy_IR (@CRinvT x x_).
Proof.
 intros.
 apply CR_inv_as_Cauchy_IR_inv.
Qed.


Require Import Ascii.
Require Import Coq.Lists.List.

Require Import Parsers.Regular.

Local Open Scope char_scope.

Require Import Coq.micromega.Lia.

Ltac simpl_env :=
  repeat match goal with
  | H: _ /\ _ |- _ => destruct H
  | H: @ex _ _ |- _ => destruct H
  end.
Ltac red_parses_all :=
  unfold "$>" in *;
  unfold "<$" in *;
  repeat (match goal with
  | H: Parses _ (bind _ _) _ |- _ =>
    erewrite bind_spec in H
  | H: Parses _ (_ >>= _) _ |- _ =>
    let H' := fresh "H" in
    erewrite bind_spec in H;
    pose proof inv_bind H as H';
    clear H
  | H: Parses _ (pAlt _ _) _ |- _ =>
    let H' := fresh "H" in
    pose proof inv_alt H as H';
    clear H
  | H: Parses _ (pStar _) _ |- _ =>
    let H' := fresh "H" in
    pose proof inv_star H as H';
    clear H
  | H: Parses _ (char _) _ |- _ =>
    let H' := fresh "H" in
    pose proof inv_char H as H';
    clear H
  | H: Parses _ (pBind _ _) _ |- _ =>
    let H' := fresh "H" in
    pose proof inv_bind H as H';
    clear H
  | H: Parses _ (_ $ _) _ |- _ =>
    let H' := fresh "H" in
    pose proof inv_cat H as H';
    clear H
  | H: Parses _ (pPure _) _ |- _ =>
    let H' := fresh "H" in
    pose proof inv_pure H as H';
    clear H
  | H: Parses _ pAny _ |- _ =>
    let H' := fresh "H" in
    pose proof inv_any H as H';
    clear H
  end; simpl_env; subst).

Section Single.

  Definition dig : parser nat :=
    (char "0" @ fun _ => 0) ||
    (char "1" @ fun _ => 1) ||
    (char "2" @ fun _ => 2) ||
    (char "3" @ fun _ => 3) ||
    (char "4" @ fun _ => 4) ||
    (char "5" @ fun _ => 5) ||
    (char "6" @ fun _ => 6) ||
    (char "7" @ fun _ => 7) ||
    (char "8" @ fun _ => 8) ||
    (char "9" @ fun _ => 9).

  Fixpoint digs_2_num (digs: list nat) : nat :=
    match digs with
    | nil => 0
    | d :: ds => d + digs_2_num ds * 10
    end.

  Definition digs : parser (list nat) := pStar dig.

  Definition num : parser nat := digs @ fun x => digs_2_num (rev x).

  (* Eval vm_compute in parses_derivs ("1" :: "2" :: nil) num. *)
  Definition num_len : parser (nat * nat) :=
    digs @ fun x => (digs_2_num x, length x).

  Definition net_str_suff (n: nat) : parser (list ascii) :=
    (char ":" $> ((repeat n pAny) <$ char ",")).

  Lemma list_eq_char:
    forall {A} {x:A} {xs xs'},
      x :: xs = x :: xs' <-> xs = xs'.
  Proof.
    intros; split; intros.
    - inversion H; auto.
    - subst; auto.
  Qed.

  Lemma repeat_n_any_spec:
    forall n s v,
      Parses s (repeat n pAny) v ->
      s = v.
  Proof.
    intros n.
    induction n; intros; simpl repeat in *. try now (red_parses_all; intuition eauto).

    red_parses_all.
    erewrite app_nil_r; erewrite <- app_comm_cons; simpl.
    erewrite app_nil_r.
    f_equal.
    intuition eauto.
  Qed.

  Lemma net_str_suff_spec :
    forall s n v,
      Parses s (net_str_suff n) v ->
      length s = n + 2 /\ s = ":" :: v ++ "," :: nil.
  Proof.
    intros.
    unfold net_str_suff in H.
    red_parses_all.
    simpl.
    repeat erewrite app_nil_r.
    erewrite app_length.
    simpl.
    split.
    -
      erewrite repeat_len_spec with (n' := 1); [| | eauto].
      + Lia.lia.
      + intros.
        red_parses_all.
        auto.
    - pose proof repeat_n_any_spec _ _ _ H.
      subst.
      auto.
  Qed.

  Definition net_str :=
    num >>= net_str_suff.

  Lemma repeat_any:
    forall {s s' n},
      Parses s (repeat n pAny) s' <->
      s = s' /\
      n = length s.
  Proof.
  induction s; simpl; intros.
    -
      split; intros.
      + destruct n; simpl in *; red_parses_all; [intuition eauto|].
        exfalso.
        inversion H.
      + destruct H; subst.
        econstructor.
    -
      split; intros.
      +
        destruct n.
        * exfalso.
          simpl in H.
          inversion H.
        * simpl in H.
          red_parses_all.
          inversion H.
          simpl in *;
          subst.
          clear H.
          specialize (IHs x0 n).
          destruct IHs.
          repeat erewrite app_nil_r in *.
          specialize (H H3).
          intuition (subst; eauto).
      + destruct H; subst.
        simpl repeat.
        assert (a :: s = ((a :: s) ++ nil)) by shelve.
        erewrite H.
        clear H.
        econstructor.
        *
          assert (a :: s = (((a :: nil) ++ s))) by shelve.
          erewrite H.
          clear H.
          econstructor; [econstructor|].
          eapply parse_map; [eapply IHs; intuition eauto | exact eq_refl].
        * simpl.
          erewrite app_nil_r.
          econstructor.

    Unshelve.
    all: try erewrite app_nil_r; exact eq_refl.
  Qed.

  Theorem net_str_spec:
    forall s v,
    Parses s net_str v <->
    exists s',
      s = s' ++ (":" :: v ++ ("," :: nil)) /\
      Parses s' num (length v).
  Proof.
    intros.
    split; intros.
    - unfold net_str in *.
      red_parses_all.
      pose proof net_str_suff_spec _ _ _ H1.
      simpl_env.
      unfold net_str_suff in *.
      red_parses_all.
      simpl in *; subst.
      repeat erewrite app_length in H.
      simpl in *.
      pose proof @repeat_any.
      specialize (H3 x5 v x).
      simpl_env.
      destruct H3.
      specialize (H3 H2).
      simpl_env; subst.
      repeat erewrite app_nil_r.
      eexists; intuition eauto.
    - intros.
      simpl_env; subst.
      unfold net_str.
      econstructor; eauto.
      unfold net_str_suff.
      assert (":" :: v ++ "," :: nil = (":" :: v ++ "," :: nil) ++ nil) by (erewrite app_nil_r; exact eq_refl).
      erewrite H; clear H.
      econstructor; [|shelve].
      assert (":" :: v ++ "," :: nil = (":" :: nil) ++ v ++ "," :: nil) by exact eq_refl.

      erewrite H; clear H.
      econstructor; try eapply parse_char; intuition eauto.

      assert (v ++ "," :: nil = (v ++ "," :: nil) ++ nil) by (erewrite app_nil_r; exact eq_refl).
      erewrite H.
      clear H.
      eapply parse_map; [|shelve].
      unfold "<$".
      erewrite bind_spec.

      econstructor; [|shelve].
      eapply parse_cat; intuition eauto; try eapply parse_char; intuition eauto.

      pose proof @repeat_any.
      evar (v': list ascii).
      specialize (H v v' (length v)).
      subst v'.
      destruct H.
      eapply H1.
      intuition eauto.
      Unshelve.
      5: econstructor.
      3: exact eq_refl.
      econstructor.
  Qed.

  Definition parse_netstr s := parses_derivs s net_str.

  (* Time Eval vm_compute in eval_derivs _ digs' eps_digs' test_digs num'. *)

  (* Eval vm_compute in parse' test_digs num. *)

  Definition test_hw_netstr := ("1" ::
  "3" ::
  ":" ::
  "h" ::
  "e" ::
  "l" ::
  "l" ::
  "o" ::
  "," ::
  " " ::
  "w" ::
  "o" ::
  "r" ::
  "l" ::
  "d" ::
  "!" ::
  "," :: nil).

  (* Time Eval vm_compute in parse_netstr test_hw_netstr. *)

End Single.

Module Nested.
  Inductive fmt : Set :=
  | base : fmt
  | nested: forall (inner: list fmt), fmt.

  Inductive sized_fmt : Set :=
  | base_sz: forall (s: list ascii) (sz: nat), sized_fmt
  | nested_sz: forall (inner: list sized_fmt) (sz: nat), sized_fmt.

  Fixpoint ind_fmt (P: fmt -> Prop) (P_base: P base) (rec: forall nst, Forall P nst -> P (nested nst)) (f: fmt) : P f :=
    match f with
    | base => P_base
    | nested fs =>
      rec _ ((fix lrec l :=
        match l as l' return Forall P l' with
        | nil => Forall_nil _
        | f :: fs => Forall_cons _ (ind_fmt _ P_base rec _) (lrec fs)
        end
      ) fs)
    end.

  Fixpoint ind_sz_fmt (P: sized_fmt -> Prop) (P_base: forall s n, P (base_sz s n)) (rec: forall nst n, Forall P nst -> P (nested_sz nst n)) (f: sized_fmt) : P f :=
    match f with
    | base_sz s n => P_base s n
    | nested_sz fs n =>
      rec _ _ ((fix lrec l :=
        match l as l' return Forall P l' with
        | nil => Forall_nil _
        | f :: fs => Forall_cons _ (ind_sz_fmt _ P_base rec _) (lrec fs)
        end
      ) fs)
    end.

  Definition get_sz (f: sized_fmt) :=
    match f with
    | base_sz _ x => x
    | nested_sz _ x => x
    end.

  Fixpoint sum_sizes_deep (sfmt: sized_fmt) : nat :=
    match sfmt with
    | base_sz _ x => x
    | nested_sz inner _ => List.fold_left (fun x y => x + y) (List.map sum_sizes_deep inner) 0
    end.

  Inductive proper_sz : sized_fmt -> Prop :=
    | proper_base: forall data len, length data = len -> proper_sz (base_sz data len)
    | proper_nested: forall inner len,
      Forall proper_sz inner ->
      sum_sizes_deep (nested_sz inner len) = len ->
      proper_sz (nested_sz inner len).
  Require Import Coq.Arith.PeanoNat.
  Lemma proper_shallow:
    forall f,
    proper_sz f ->
    get_sz f = sum_sizes_deep f.
  Proof.
    intros f.
    induction f using ind_sz_fmt;
    intros; simpl; intuition eauto.
    revert H.
    revert H0.
    revert n.
    induction nst; intros; simpl; intuition eauto.
    - inversion H0; subst.
      simpl in H4;
      subst; auto.
    - inversion H0;
      simpl in *;
      subst.
      auto.
  Qed.

  Lemma fold_sum:
    forall n l,
      n + List.fold_left (fun x y => x + y) l 0 = List.fold_left (fun x y => x + y) l n.
  Proof.
    intros.
    revert n;
    induction l; intros; simpl; try Lia.lia.
    erewrite <- IHl with (n := a).
    erewrite Plus.plus_assoc.
    eapply IHl.
  Qed.

  Lemma proper_sz_cons :
    forall f inner len n,
      proper_sz (nested_sz inner len) ->
      proper_sz f ->
      get_sz f = n ->
      proper_sz (nested_sz (f :: inner) (n + len)).
  Proof.
    intros.
    econstructor.
    - inversion H;
      econstructor; intuition eauto.
    - pose proof @proper_shallow.
      inversion H;
      subst.
      erewrite <- H6.
      erewrite proper_shallow; intuition eauto.
      simpl sum_sizes_deep.
      erewrite fold_sum.
      auto.
  Qed.

  Fixpoint add_len {A: Set} (p: parser A) : parser (A * nat) :=
    match p with
    | pPure v => pPure v @ fun x => (x, 0)
    | pAny => pAny @ fun x => (x, 1)
    | pFail => pFail
    | pBind p f =>
      add_len p >>=
      fun '(x, n) => (add_len (f x) @ fun '(y, m) => (y, n + m))
    | pStar p => pStar (add_len p) @
      fun xs => let '(r, lens) := List.split xs in
        (r, List.fold_left (fun x y => x + y) lens 0)

    | pAlt l r => pAlt (add_len l) (add_len r)
    end.

  Definition num_with_len := add_len num.

  (* Time Eval vm_compute in parses_derivs ("0" :: "0" :: "1" :: "2" :: nil) num_with_len. *)

  Lemma inv_add_len:
    forall {A} {s} {p: parser A} {v},
      Parses s (add_len p) v ->
      exists v' n,
      Parses s p v' /\ n = length s /\ v = (v', n).
  Proof.
    intros ? ? ?.
    revert s.
    induction p; intros; simpl add_len in *;
    try match goal with
    | H: Parses _ pFail _ |- _ => inversion H
    end.
    - red_parses_all; simpl;
      repeat match goal with
      | |- exists _, _ => eexists
      end;
      intuition (econstructor || eauto).
    - pose proof inv_alt H.
      clear H.
      destruct H0.
      +
        specialize (IHp1 s v H).
        simpl_env.
        repeat match goal with
        | |- exists _, _ => eexists
        end;
        intuition eauto; try eapply AltL; intuition eauto;
        subst;
        exact eq_refl.

      +
        specialize (IHp2 s v H).
        simpl_env.
        repeat match goal with
        | |- exists _, _ => eexists
        end;
        intuition eauto; try eapply AltR; intuition eauto;
        subst;
        exact eq_refl.
    - red_parses_all.
      repeat match goal with
      | |- exists _, _ => eexists
      end; simpl; try econstructor; intuition eauto.
      econstructor.
    - red_parses_all.
      specialize (IHp x0 x H1).
      simpl_env; subst.
      red_parses_all.
      specialize (H x2 x3 x H3).
      simpl_env; subst.
      repeat erewrite app_nil_r.
      exists x1.
      exists (length x0 + length x3);
      erewrite app_length;
      intuition eauto.
      econstructor; intuition eauto.
    - red_parses_all.
      destruct H; simpl_env; subst; simpl in *.
      + do 2 eexists; intuition (econstructor || eauto).
      + erewrite app_nil_r.
        specialize (IHp x1 x3 H3).
        simpl_env; subst.
        do 2 eexists; intuition eauto.
        2: shelve.
        (* TODO: need an induction principle for pstar parsing *)
        admit.

  Admitted.

  Lemma add_len_spec :
    forall {A} {s} {p: parser A} {v n},
      Parses s p v ->
      length s = n ->
      Parses s (add_len p) (v, n).
  Proof.
    intros ? ? ?.
    revert s.
    induction p; intros; red_parses_all; simpl add_len;
    try now (econstructor; intuition eauto);
    intuition eauto.
    - inversion H.
    - admit.
      (* eapply parse_map; try econstructor; intuition eauto. *)
    - destruct H1; [eapply AltL | eapply AltR]; intuition eauto.
    - admit.
      (* econstructor.
      2: eapply parse_map. ; try econstructor; intuition eauto. *)
    - admit.
  Admitted.

  Definition net_with_len : parser (sized_fmt * nat) :=
    num_with_len >>= fun '(n, len) => (net_str_suff n) >>= fun b => pPure (base_sz b n, len + n + 2).

  Definition test_fmt : sized_fmt :=
    nested_sz ((nested_sz (base_sz ("a" :: "b" :: "c" :: nil) 3 :: nil) 3) :: nil) 3.

  Goal proper_sz test_fmt.
  Proof.
    unfold test_fmt.
    repeat econstructor.
  Qed.

  (* Eval vm_compute in proper_sz test_fmt. *)

  Fixpoint sum_sizes_shallow (sfs: list (sized_fmt)) : nat :=
    match sfs with
    | nil => 0
    | sf :: sfs' =>
      match sf with
      | base_sz _ n => n
      | nested_sz _ n => n
      end + sum_sizes_shallow sfs'
    end.

  Equations interp_fmt (f: fmt) : parser (sized_fmt * nat) by struct f :=
    interp_fmt base := net_with_len;
    interp_fmt (nested fs) :=
      (num_with_len <$ char ":") >>= fun '(n, len) =>
      (filter (interp_fmt_lst fs <$ char ",") (fun '(fs, n') => Nat.eqb n n') @
      fun '(fs, n') => (nested_sz fs (sum_sizes_shallow fs), n' + len + 2))
  where interp_fmt_lst (fs: list fmt) : parser (list sized_fmt * nat) by struct fs :=
    interp_fmt_lst nil := pPure (nil, 0);
    interp_fmt_lst (f :: fs') :=
      interp_fmt f $ interp_fmt_lst fs' @ fun '((sf, sz), (sfs, sz')) => (sf :: sfs, sz + sz').

  Lemma net_with_len_corr :
    forall s v n,
      Parses s net_with_len (v, n) ->
      proper_sz v.
  Proof.
    intros.
    unfold net_with_len in H.
    red_parses_all.
    destruct x.
    red_parses_all.
    pose proof net_str_suff_spec _ _ _ H1.

    inversion H2.
    simpl_env; subst.
    econstructor.

    simpl length in H.
    erewrite app_length in H.
    simpl length in H.
    Lia.lia.
  Qed.

  Lemma interp_fmt_lst_corr:
    forall nst c s l n,
      (Forall
        (fun f : fmt =>
        forall (s : string) (v : sized_fmt) (n : nat),
        Parses s (interp_fmt f) (v, n) -> proper_sz v)
        (c :: nst)) ->
      (Parses s (interp_fmt_clause_2_interp_fmt_lst interp_fmt (c :: nst) nst) (l, n)) ->
      proper_sz (nested_sz l (sum_sizes_shallow l)).
  Proof.
    intros nst c s l n.
    revert n.
    revert nst.
    revert s.
    revert c.
    induction l; intros; simpl in *.
    - red_parses_all.
      destruct nst; simpl in *; intuition eauto; red_parses_all.
      *
        inversion H1.
        econstructor; intuition eauto.
      * destruct x4;
        destruct x5;
        inversion H3.
    - destruct nst; [simpl in *; red_parses_all; inversion H1|].
      eapply proper_sz_cons.
      * simpl in H0.

        eapply IHl; intuition eauto.
        red_parses_all.
        admit.
      * inversion H.
        admit.
        (* inversion H5.
        subst.
        intuition eauto. *)
      * destruct a; auto.
        (* assert proper_sz (nested_sz l0 (sum_sizes_shallow l0)) by shelve.
        eapply proper_sz_cons; intuition eauto. *)
    Admitted.

  Theorem interp_fmt_corr:
    forall f s v n,
      Parses s (interp_fmt f) (v, n) ->
      proper_sz v.
  Proof.
    intros f.
    induction f using ind_fmt.
    - intros; eapply net_with_len_corr; intuition eauto.
    - induction nst.
      + intros.
        autorewrite with interp_fmt in H0.
        red_parses_all.
        destruct x.
        red_parses_all.
        pose proof inv_filter H2.
        clear H2.
        red_parses_all.
        simpl_env.
        destruct x.
        red_parses_all.
        inversion H4.
        simpl.
        subst.
        inversion H3.
        subst.
        simpl.
        repeat econstructor.
      + intros.
        autorewrite with interp_fmt in H0.
        red_parses_all.
        destruct x.
        red_parses_all.
        pose proof inv_filter H2.
        clear H2.
        simpl_env.
        red_parses_all.
        destruct x8.
        destruct x9.
        inversion H3;
        subst.
        clear H3.
        simpl.
        eapply proper_sz_cons; intuition eauto.
        * eapply interp_fmt_lst_corr; intuition eauto.
        * inversion H.
          eapply H6; intuition eauto.
  Qed.

    Definition test_hw_nested := (
      "1" ::
      "6" ::
      ":" ::
      "5" ::
      ":" ::
      "h" ::
      "e" ::
      "l" ::
      "l" ::
      "o" ::
      "," ::
      "5" ::
      ":" ::
      "w" ::
      "o" ::
      "r" ::
      "l" ::
      "d" ::
      "," ::
      "," :: nil).

  (* Eval vm_compute in parses_derivs test_hw_nested (interp_fmt (nested (base :: base :: nil))). *)

End Nested.


Require Import Utf8_core.
Require ILLVarInt. (* Don't want import it. *)
Import ILLVarInt.MILL. (* only this *)
Import FormulaMultiSet. (* and this *)

Local Notation "'P'" := (Proposition 1%nat):Emma.
Local Notation "'R'" := (Proposition 2%nat):Emma. (* Meets Rodolph *)
Local Notation "'G'" := (Proposition 3%nat):Emma.
Local Notation "'B'" := (Proposition 4%nat):Emma.
Local Notation "'V'" := (Proposition 5%nat):Emma.
Local Notation "'A'" := (Proposition 6%nat):Emma.
Local Notation "'E'" := (Proposition 7%nat):Emma.
Local Notation "'M'" := (Proposition 8%nat):Emma.
Open Scope Emma.

Reserved Notation "x ▷ y" (ILL_proof global ,at level 70, no associativity).

Inductive ILL_proof : env → formula → Prop :=
  Id : ∀ Γ p, Γ == {p} -> Γ ▷ p
(* | Cut : ∀ Γ Δ p q, Γ ▷ p → p::Δ ▷ q → Δ ∪ Γ ▷ q  *)
| Impl_R : ∀ Γ p q, p::Γ ▷ q → Γ ▷ p ⊸ q
| Impl_L : ∀ Γ Δ Δ' p q r, p ⊸ q ∈ Γ -> Γ \ p⊸q == Δ ∪ Δ' ->  Δ ⊢ p → q::Δ' ▷ r → Γ ▷ r
| Times_R : ∀ Γ Δ Δ' p q , Γ == Δ ∪ Δ' -> Δ ▷ p → Δ' ▷ q → Γ ▷ p ⊗ q
| Times_L : ∀ Γ p q r , p ⊗ q ∈ Γ -> q :: p :: (Γ \ p⊗q) ▷ r → Γ ▷ r
| One_R : ∀ Γ, Γ == ∅ -> Γ ▷ 1
| One_L : ∀ Γ p , 1 ∈ Γ -> Γ \ 1 ▷ p → Γ ▷ p
| And_R : ∀ Γ p q , Γ ▷ p → Γ ▷ q → Γ ▷ p & q
| And_L_1 : ∀ Γ p q r , p&q ∈ Γ ->  p:: (Γ \ p&q) ▷ r → Γ ▷ r
| And_L_2 : ∀ Γ p q r , p&q ∈ Γ ->  q::(Γ \ p&q) ▷ r → Γ ▷ r
| Oplus_L : ∀ Γ p q r , p⊕q ∈ Γ ->  p :: (Γ \ p⊕q) ▷ r → q :: (Γ \ p⊕q) ▷ r → Γ ▷ r
| Oplus_R_1 : ∀ Γ p q , Γ == {p} → Γ ▷ p → Γ ▷ p ⊕ q
| Oplus_R_2 : ∀ Γ p q , Γ == {q} → Γ ▷ q → Γ ▷ p ⊕ q
| T_ : ∀ Γ, Γ ▷ ⊤
| Zero_ : ∀ Γ p , 0 ∈ Γ → Γ ▷ p
| Bang_D : ∀ Γ p q , !p∈Γ -> p :: (Γ \ !p) ▷ q → Γ ▷ q
| Bang_C : ∀ Γ p q , !p∈Γ -> !p :: Γ ▷ q →  Γ ▷ q
| Bang_W : ∀ Γ p q , !p∈Γ -> Γ \ !p ▷ q →  Γ ▷ q
  (* Syntax defined simutaneously. *)
  where " x ▷ y " := (ILL_proof x y):Restr_scope.

Local Open Scope Restr_scope.
Section Reachability.
  Set Implicit Arguments.
  Variable pred: ∀ {e} {f} (h:e ▷ f), Prop.
  (** This property is true when pred holds for all nodes above the root
     of h (it has not to hold for the root itself). *)
  Inductive IReach: ∀ {e} {f} (h: e ▷ f) , Prop :=
  | ROK: ∀ Γ p (h:Γ▷p), pred h → IReach h
  | RImpl_R: ∀ Γ p q h, IReach h → IReach (Impl_R Γ p q h)
(*   | RImpl_L1: ∀ Γ Δ Δ' p q r hin heq h h', IReach h → IReach (Impl_L Γ Δ Δ' p q r hin heq h h') *)(* Pas cette branche *)
  | RImpl_L2: ∀ Γ Δ Δ' p q r hin heq h h', IReach h' → IReach (Impl_L Γ Δ Δ' p q r hin heq h h')
  | RTimes_R1: ∀ Γ Δ Δ' p q heq h h', IReach h → IReach (Times_R Γ Δ Δ' p q heq h h')
  | RTimes_R2: ∀ Γ Δ Δ' p q heq h h', IReach h' → IReach (Times_R Γ Δ Δ' p q heq h h')
  | RTimes_L: ∀ Γ p q r hin h, IReach h → IReach (Times_L Γ p q r hin h)
  | ROne_L: ∀ Γ p hin h, IReach h → IReach (One_L Γ p hin h)
  | RAnd_R1: ∀ Γ p q h h', IReach h' → IReach (And_R  Γ p q h h')
  | RAnd_R2: ∀ Γ p q h h', IReach h  → IReach (And_R  Γ p q h h')
  | RAnd_L_2: ∀ Γ p q r hin h, IReach h → IReach (And_L_2 Γ p q r hin h)
  | RAnd_L_1: ∀ Γ p q r hin h, IReach h → IReach (And_L_1 Γ p q r hin h)
  | ROplus_L1: ∀ Γ p q r hin h h', IReach h' → IReach (Oplus_L  Γ p q r hin h h')
  | ROplus_L2: ∀ Γ p q r hin h h', IReach h  → IReach (Oplus_L  Γ p q r hin h h')
  | ROplus_R_2: ∀ Γ p q heq h, IReach h  → IReach (Oplus_R_2 Γ p q heq h)
  | ROplus_R_1: ∀ Γ p q heq h, IReach h  → IReach (Oplus_R_1 Γ p q heq h)
  | RBang_D: ∀ Γ p q hin h, IReach h → (IReach (Bang_D Γ p q hin h))
  | RBang_C: ∀ Γ p q hin h, IReach h → (IReach (Bang_C Γ p q hin h))
  | RBang_W: ∀ Γ p q hin h, IReach h → (IReach (Bang_W Γ p q hin h)).

End Reachability.

Open Scope Restr_scope.

Module titi.
Section Reachability2.
  Set Implicit Arguments.
  Variable pred: ∀ {e} {f} (h:e ⊢ f), Prop.
  (** This property is true when pred holds for all nodes above the root
     of h (it has not to hold for the root itself). *)
  Inductive IReach: ∀ {e} {f} (h: e ⊢ f) , Prop :=
  | ROK: ∀ Γ p h, @pred Γ p h → IReach h
  | RImpl_R: ∀ Γ p q h, IReach h → IReach (ILLVarInt.MILL.Impl_R Γ p q h)
(*   | RImpl_L1: ∀ Γ Δ Δ' p q r hin heq h h', IReach h → IReach (ILLVarInt.MILL.Impl_L Γ Δ Δ' p q r hin heq h h') *)
  | RImpl_L2: ∀ Γ Δ Δ' p q r hin heq h h', IReach h' → IReach (ILLVarInt.MILL.Impl_L Γ Δ Δ' p q r hin heq h h')
  | RTimes_R1: ∀ Γ Δ Δ' p q heq h h', IReach h → IReach (ILLVarInt.MILL.Times_R Γ Δ Δ' p q heq h h')
  | RTimes_R2: ∀ Γ Δ Δ' p q heq h h', IReach h' → IReach (ILLVarInt.MILL.Times_R Γ Δ Δ' p q heq h h')
  | RTimes_L: ∀ Γ p q r hin h, IReach h → IReach (ILLVarInt.MILL.Times_L Γ p q r hin h)
  | ROne_L: ∀ Γ p hin h, IReach h → IReach (ILLVarInt.MILL.One_L Γ p hin h)
  | RAnd_R1: ∀ Γ p q h h', IReach h' → IReach (ILLVarInt.MILL.And_R  Γ p q h h')
  | RAnd_R2: ∀ Γ p q h h', IReach h  → IReach (ILLVarInt.MILL.And_R  Γ p q h h')
  | RAnd_L_2: ∀ Γ p q r hin h, IReach h → IReach (ILLVarInt.MILL.And_L_2 Γ p q r hin h)
  | RAnd_L_1: ∀ Γ p q r hin h, IReach h → IReach (ILLVarInt.MILL.And_L_1 Γ p q r hin h)
  | ROplus_L1: ∀ Γ p q r hin h h', IReach h' → IReach (ILLVarInt.MILL.Oplus_L  Γ p q r hin h h')
  | ROplus_L2: ∀ Γ p q r hin h h', IReach h  → IReach (ILLVarInt.MILL.Oplus_L  Γ p q r hin h h')
  | ROplus_R_2: ∀ Γ p q h, IReach h  → IReach (ILLVarInt.MILL.Oplus_R_2 Γ p q h)
  | ROplus_R_1: ∀ Γ p q h, IReach h  → IReach (ILLVarInt.MILL.Oplus_R_1 Γ p q h)
  | RBang_D: ∀ Γ p q hin h, IReach h → (IReach (ILLVarInt.MILL.Bang_D Γ p q hin h))
  | RBang_C: ∀ Γ p q hin h, IReach h → (IReach (ILLVarInt.MILL.Bang_C Γ p q hin h))
  | RBang_W: ∀ Γ p q hin h, IReach h → (IReach (ILLVarInt.MILL.Bang_W Γ p q hin h)).

End Reachability2.
End titi.

Open Scope Restr_scope.

Definition atheseA Γ p (h:Γ⊢p) := Γ == {A} /\ p = A.
Definition atheseA' Γ p (h:Γ ▷ p) := Γ == {A} /\ p = A.

Unset Implicit Arguments.

Ltac small_subst:=
  match goal with
    | H: Logic.eq ?x ?y |- _ => rewrite H
  end.

Local Obligation Tactic := simpl;intros; try solve [ repeat small_subst ; reflexivity | discriminate].
Set Transparent Obligations.

Program Fixpoint f Γ (h:Γ⊢A⊕M) {struct h} : Γ▷A⊕M :=
  match h with
    | ILLVarInt.MILL.Id Γ p heq => (Id Γ (A ⊕ M) heq)
    | ILLVarInt.MILL.Impl_R Γ p q x => _
    | ILLVarInt.MILL.Impl_L Γ Δ Δ' p q r hin heq  x x0 => Impl_L Γ Δ Δ' p q r hin heq x (f (q::Δ') x0)
    | ILLVarInt.MILL.Times_R Γ Δ Δ' p q heq x x0 => _
    | ILLVarInt.MILL.Times_L Γ p q r hin x => Times_L Γ p q r hin (f (q :: p :: (Γ \ p ⊗ q)) x)
    | ILLVarInt.MILL.One_R Γ heq => _
    | ILLVarInt.MILL.One_L Γ p hin x => One_L Γ p hin (f (Γ\1) x)
    | ILLVarInt.MILL.And_R Γ p q x x0 => _
    | ILLVarInt.MILL.And_L_1 Γ p q r hin x => And_L_1 Γ p q r hin (f (p :: (Γ \ p & q)) x)
    | ILLVarInt.MILL.And_L_2 Γ p q r hin x => And_L_2 Γ p q r hin (f (q :: (Γ \ p & q)) x)
    | ILLVarInt.MILL.Oplus_L Γ p q r hin x x0 => Oplus_L Γ p q r hin (f (p :: (Γ \ p ⊕ q)) x) (f (q :: (Γ \ p ⊕ q)) x0)
    | ILLVarInt.MILL.Oplus_R_1 Γ p q x => fA Γ x
    | ILLVarInt.MILL.Oplus_R_2 Γ p q x => fM Γ x
    | ILLVarInt.MILL.T_ Γ => T_ Γ
    | ILLVarInt.MILL.Zero_ Γ p hin => Zero_ Γ p hin
    | ILLVarInt.MILL.Bang_D Γ p q hin x => Bang_D Γ p q hin (f (p :: (Γ \ !p)) x)
    | ILLVarInt.MILL.Bang_C Γ p q hin x => Bang_C Γ p q hin (f (!p :: Γ) x)
    | ILLVarInt.MILL.Bang_W Γ p q hin x => Bang_W Γ p q hin (f (Γ \ !p) x)
  end
with fA Γ (h:Γ⊢A) {struct h} : Γ▷A⊕M :=
  match h with
    | ILLVarInt.MILL.Id Γ p heq => (Oplus_R_1 Γ p M heq (Id Γ p heq))
    | ILLVarInt.MILL.Impl_R Γ p q x => _
    | ILLVarInt.MILL.Impl_L Γ Δ Δ' p q r hin heq  x x0 => Impl_L Γ Δ Δ' p q (A⊕M) hin heq x (fA (q::Δ') x0)
    | ILLVarInt.MILL.Times_R Γ Δ Δ' p q heq x x0 => _
    | ILLVarInt.MILL.Times_L Γ p q r hin x => Times_L Γ p q (A⊕M) hin (fA (q :: p :: (Γ \ p ⊗ q)) x)
    | ILLVarInt.MILL.One_R Γ heq => _
    | ILLVarInt.MILL.One_L Γ p hin x => One_L Γ (A⊕M) hin (fA (Γ\1) x)
    | ILLVarInt.MILL.And_R Γ p q x x0 => _
    | ILLVarInt.MILL.And_L_1 Γ p q r hin x => And_L_1 Γ p q (A⊕M) hin (fA (p :: (Γ \ p & q)) x)
    | ILLVarInt.MILL.And_L_2 Γ p q r hin x => And_L_2 Γ p q (A⊕M) hin (fA (q :: (Γ \ p & q)) x)
    | ILLVarInt.MILL.Oplus_L Γ p q r hin x x0 => Oplus_L Γ p q (A⊕M) hin (fA (p :: (Γ \ p ⊕ q)) x) (fA (q :: (Γ \ p ⊕ q)) x0)
    | ILLVarInt.MILL.Oplus_R_1 Γ p q x => fA Γ x
    | ILLVarInt.MILL.Oplus_R_2 Γ p q x => fM Γ x
    | ILLVarInt.MILL.T_ Γ => T_ Γ
    | ILLVarInt.MILL.Zero_ Γ p hin => Zero_ Γ (A⊕M) hin
    | ILLVarInt.MILL.Bang_D Γ p q hin x => Bang_D Γ p (A⊕M) hin (fA (p :: (Γ \ !p)) x)
    | ILLVarInt.MILL.Bang_C Γ p q hin x => Bang_C Γ p (A⊕M) hin (fA (!p :: Γ) x)
    | ILLVarInt.MILL.Bang_W Γ p q hin x => Bang_W Γ p (A⊕M) hin (fA (Γ \ !p) x)
  end
with fM Γ (h:Γ⊢M) {struct h} : Γ▷A⊕M :=
  match h with
    | ILLVarInt.MILL.Id Γ p heq => (Oplus_R_2 Γ A p _ (Id Γ p heq))
    | ILLVarInt.MILL.Impl_R Γ p q x => _
    | ILLVarInt.MILL.Impl_L Γ Δ Δ' p q r hin heq  x x0 => Impl_L Γ Δ Δ' p q (A⊕M) hin heq x (fM (q::Δ') x0)
    | ILLVarInt.MILL.Times_R Γ Δ Δ' p q heq x x0 => _
    | ILLVarInt.MILL.Times_L Γ p q r hin x => Times_L Γ p q (A⊕M) hin (fM (q :: p :: (Γ \ p ⊗ q)) x)
    | ILLVarInt.MILL.One_R Γ heq => _
    | ILLVarInt.MILL.One_L Γ p hin x => One_L Γ (A⊕M) hin (fM (Γ\1) x)
    | ILLVarInt.MILL.And_R Γ p q x x0 => _
    | ILLVarInt.MILL.And_L_1 Γ p q r hin x => And_L_1 Γ p q (A⊕M) hin (fM (p :: (Γ \ p & q)) x)
    | ILLVarInt.MILL.And_L_2 Γ p q r hin x => And_L_2 Γ p q (A⊕M) hin (fM (q :: (Γ \ p & q)) x)
    | ILLVarInt.MILL.Oplus_L Γ p q r hin x x0 => Oplus_L Γ p q (A⊕M) hin (fM (p :: (Γ \ p ⊕ q)) x) (fM (q :: (Γ \ p ⊕ q)) x0)
    | ILLVarInt.MILL.Oplus_R_1 Γ p q x => fA Γ x
    | ILLVarInt.MILL.Oplus_R_2 Γ p q x => fM Γ x
    | ILLVarInt.MILL.T_ Γ => T_ Γ
    | ILLVarInt.MILL.Zero_ Γ p hin => Zero_ Γ (A⊕M) hin
    | ILLVarInt.MILL.Bang_D Γ p q hin x => Bang_D Γ p (A⊕M) hin (fM (p :: (Γ \ !p)) x)
    | ILLVarInt.MILL.Bang_C Γ p q hin x => Bang_C Γ p (A⊕M) hin (fM (!p :: Γ) x)
    | ILLVarInt.MILL.Bang_W Γ p q hin x => Bang_W Γ p (A⊕M) hin (fM (Γ \ !p) x)
  end
.

Next Obligation of f.
  inversion Heq_anonymous;reflexivity.
Defined.
Next Obligation of f.
  inversion Heq_anonymous;reflexivity.
Defined.

Preterm of f.

Definition f :
Tactics.fix_proto (∀ Γ : env, Γ ⊢ A ⊕ M → Γ ▷ A ⊕ M)
→ Tactics.fix_proto (∀ Γ : env, Γ ⊢ A → Γ ▷ A ⊕ M)
  → Tactics.fix_proto (∀ Γ : env, Γ ⊢ M → Γ ▷ A ⊕ M)
    → (∀ Γ : env, Γ ⊢ A ⊕ M → Γ ▷ A ⊕ M)
:=
λ (f : Tactics.fix_proto (∀ Γ : env, Γ ⊢ A ⊕ M → Γ ▷ A ⊕ M))
(fA : Tactics.fix_proto (∀ Γ : env, Γ ⊢ A → Γ ▷ A ⊕ M))
(fM : Tactics.fix_proto (∀ Γ : env, Γ ⊢ M → Γ ▷ A ⊕ M))
(Γ : env) (h : Γ ⊢ A ⊕ M),
let branch_0:=
 λ (Γ0 : t) (p : formula) (heq : Γ0 == {p}) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Id Γ0 p heq) h),
 Id Γ0 (A ⊕ M)
   (λ x : Maps'.key,
    Logic.eq_rect (Maps'.find (elt:=nat) x ({p}))
      (λ H : option nat, Maps'.find (elt:=nat) x Γ0 = H)
      (heq x) (Maps'.find (elt:=nat) x ({A ⊕ M}))
      (f_obligation_1 Γ h Γ0 p heq Heq_Γ Heq_anonymous Heq_h x)) in
let branch_1:=
 λ (Γ0 : t) (p q : formula) (x : p :: Γ0 ⊢ q) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p ⊸ q = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Impl_R Γ0 p q x) h),
 f_obligation_2 Γ h Γ0 p q x Heq_Γ Heq_anonymous Heq_h in
let branch_2:=
 λ (Γ0 Δ Δ' : t) (p q r : formula) (hin : p ⊸ q ∈ Γ0)
 (heq : Γ0 \ p ⊸ q == Δ ∪ Δ') (x : Δ ⊢ p) (x0 : q :: Δ' ⊢ r)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : r = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Impl_L Γ0 Δ Δ' p q r hin heq x x0) h),
 Logic.eq_rect r (λ H : formula, Γ0 ▷ H)
   (Impl_L Γ0 Δ Δ' p q r hin heq x
      (Logic.eq_rect (A ⊕ M) (λ H : formula, q :: Δ' ▷ H)
         (f (q :: Δ')
            (Logic.eq_rect r (λ H : formula, q :: Δ' ⊢ H) x0
               (A ⊕ M)
               (f_obligation_3 Γ h Γ0 Δ Δ' p q r hin heq x x0 Heq_Γ
                  Heq_anonymous Heq_h))) r
         (f_obligation_4 Γ h Γ0 Δ Δ' p q r hin heq x x0 Heq_Γ Heq_anonymous
            Heq_h))) (A ⊕ M)
   (f_obligation_5 Γ h Γ0 Δ Δ' p q r hin heq x x0 Heq_Γ Heq_anonymous Heq_h) in
let branch_3:=
 λ (Γ0 Δ Δ' : t) (p q : formula) (heq : Γ0 == Δ ∪ Δ')
 (x : Δ ⊢ p) (x0 : Δ' ⊢ q) (Heq_Γ : Γ0 = Γ) (Heq_anonymous : p ⊗ q = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Times_R Γ0 Δ Δ' p q heq x x0) h),
 f_obligation_6 Γ h Γ0 Δ Δ' p q heq x x0 Heq_Γ Heq_anonymous Heq_h in
let branch_4:=
 λ (Γ0 : t) (p q r : formula) (hin : p ⊗ q ∈ Γ0)
 (x : q :: p :: (Γ0 \ p ⊗ q) ⊢ r) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : r = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Times_L Γ0 p q r hin x) h),
 Logic.eq_rect r (λ H : formula, Γ0 ▷ H)
   (Times_L Γ0 p q r hin
      (Logic.eq_rect (A ⊕ M) (λ H : formula, q :: p :: (Γ0 \ p ⊗ q) ▷ H)
         (f (q :: p :: (Γ0 \ p ⊗ q))
            (Logic.eq_rect r (λ H : formula, q :: p :: (Γ0 \ p ⊗ q) ⊢ H) x
               (A ⊕ M)
               (f_obligation_7 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h)))
         r (f_obligation_8 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h)))
   (A ⊕ M) (f_obligation_9 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h) in
let branch_5:=
 λ (Γ0 : t) (heq : Γ0 == ∅) (Heq_Γ : Γ0 = Γ) (Heq_anonymous : 1 = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.One_R Γ0 heq) h),
 f_obligation_10 Γ h Γ0 heq Heq_Γ Heq_anonymous Heq_h in
let branch_6:=
 λ (Γ0 : t) (p : formula) (hin : 1 ∈ Γ0) (x : Γ0 \ 1 ⊢ p)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : p = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.One_L Γ0 p hin x) h),
 Logic.eq_rect p (λ H : formula, Γ0 ▷ H)
   (One_L Γ0 p hin
      (Logic.eq_rect (A ⊕ M) (λ H : formula, Γ0 \ 1 ▷ H)
         (f (Γ0 \ 1)
            (Logic.eq_rect p (λ H : formula, Γ0 \ 1 ⊢ H) x
               (A ⊕ M)
               (f_obligation_11 Γ h Γ0 p hin x Heq_Γ Heq_anonymous Heq_h))) p
         (f_obligation_12 Γ h Γ0 p hin x Heq_Γ Heq_anonymous Heq_h)))
   (A ⊕ M) (f_obligation_13 Γ h Γ0 p hin x Heq_Γ Heq_anonymous Heq_h) in
let branch_7:=
 λ (Γ0 : env) (p q : formula) (x : Γ0 ⊢ p) (x0 : Γ0 ⊢ q)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : p & q = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.And_R Γ0 p q x x0) h),
 f_obligation_14 Γ h Γ0 p q x x0 Heq_Γ Heq_anonymous Heq_h in
let branch_8:=
 λ (Γ0 : t) (p q r : formula) (hin : p & q ∈ Γ0) (x : p :: (Γ0 \ p & q) ⊢ r)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : r = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.And_L_1 Γ0 p q r hin x) h),
 Logic.eq_rect r (λ H : formula, Γ0 ▷ H)
   (And_L_1 Γ0 p q r hin
      (Logic.eq_rect (A ⊕ M) (λ H : formula, p :: (Γ0 \ p & q) ▷ H)
         (f (p :: (Γ0 \ p & q))
            (Logic.eq_rect r (λ H : formula, p :: (Γ0 \ p & q) ⊢ H) x
               (A ⊕ M)
               (f_obligation_15 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h)))
         r (f_obligation_16 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h)))
   (A ⊕ M) (f_obligation_17 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h) in
let branch_9:=
 λ (Γ0 : t) (p q r : formula) (hin : p & q ∈ Γ0) (x : q :: (Γ0 \ p & q) ⊢ r)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : r = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.And_L_2 Γ0 p q r hin x) h),
 Logic.eq_rect r (λ H : formula, Γ0 ▷ H)
   (And_L_2 Γ0 p q r hin
      (Logic.eq_rect (A ⊕ M) (λ H : formula, q :: (Γ0 \ p & q) ▷ H)
         (f (q :: (Γ0 \ p & q))
            (Logic.eq_rect r (λ H : formula, q :: (Γ0 \ p & q) ⊢ H) x
               (A ⊕ M)
               (f_obligation_18 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h)))
         r (f_obligation_19 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h)))
   (A ⊕ M) (f_obligation_20 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h) in
let branch_10:=
 λ (Γ0 : t) (p q r : formula) (hin : p ⊕ q ∈ Γ0) (x : p :: (Γ0 \ p ⊕ q) ⊢ r)
 (x0 : q :: (Γ0 \ p ⊕ q) ⊢ r) (Heq_Γ : Γ0 = Γ) (Heq_anonymous : r = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Oplus_L Γ0 p q r hin x x0) h),
 Logic.eq_rect r (λ H : formula, Γ0 ▷ H)
   (Oplus_L Γ0 p q r hin
      (Logic.eq_rect (A ⊕ M) (λ H : formula, p :: (Γ0 \ p ⊕ q) ▷ H)
         (f (p :: (Γ0 \ p ⊕ q))
            (Logic.eq_rect r (λ H : formula, p :: (Γ0 \ p ⊕ q) ⊢ H) x
               (A ⊕ M)
               (f_obligation_21 Γ h Γ0 p q r hin x x0 Heq_Γ Heq_anonymous
                  Heq_h))) r
         (f_obligation_22 Γ h Γ0 p q r hin x x0 Heq_Γ Heq_anonymous Heq_h))
      (Logic.eq_rect (A ⊕ M) (λ H : formula, q :: (Γ0 \ p ⊕ q) ▷ H)
         (f (q :: (Γ0 \ p ⊕ q))
            (Logic.eq_rect r (λ H : formula, q :: (Γ0 \ p ⊕ q) ⊢ H) x0
               (A ⊕ M)
               (f_obligation_23 Γ h Γ0 p q r hin x x0 Heq_Γ Heq_anonymous
                  Heq_h))) r
         (f_obligation_24 Γ h Γ0 p q r hin x x0 Heq_Γ Heq_anonymous Heq_h)))
   (A ⊕ M) (f_obligation_25 Γ h Γ0 p q r hin x x0 Heq_Γ Heq_anonymous Heq_h) in
let branch_11:=
 λ (Γ0 : env) (p q : formula) (x : Γ0 ⊢ p) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p ⊕ q = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Oplus_R_1 Γ0 p q x) h),
 fA Γ0
   (Logic.eq_rect p (λ H : formula, Γ0 ⊢ H) x A
      (f_obligation_26 Γ h Γ0 p q x Heq_Γ Heq_anonymous Heq_h)) in
let branch_12:=
 λ (Γ0 : env) (p q : formula) (x : Γ0 ⊢ q) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p ⊕ q = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Oplus_R_2 Γ0 p q x) h),
 fM Γ0
   (Logic.eq_rect q (λ H : formula, Γ0 ⊢ H) x M
      (f_obligation_27 Γ h Γ0 p q x Heq_Γ Heq_anonymous Heq_h)) in
let branch_13:=
 λ (Γ0 : env) (Heq_Γ : Γ0 = Γ) (Heq_anonymous : ⊤ = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.T_ Γ0) h),
 Logic.eq_rect (⊤) (λ H : formula, Γ0 ▷ H) (T_ Γ0)
   (A ⊕ M) (f_obligation_28 Γ h Γ0 Heq_Γ Heq_anonymous Heq_h) in
let branch_14:=
 λ (Γ0 : t) (p : formula) (hin : 0 ∈ Γ0) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Zero_ Γ0 p hin) h),
 Logic.eq_rect p (λ H : formula, Γ0 ▷ H) (Zero_ Γ0 p hin)
   (A ⊕ M) (f_obligation_29 Γ h Γ0 p hin Heq_Γ Heq_anonymous Heq_h) in
let branch_15:=
 λ (Γ0 : t) (p q : formula) (hin : !p ∈ Γ0) (x : p :: (Γ0 \ !p) ⊢ q)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : q = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Bang_D Γ0 p q hin x) h),
 Logic.eq_rect q (λ H : formula, Γ0 ▷ H)
   (Bang_D Γ0 p q hin
      (Logic.eq_rect (A ⊕ M) (λ H : formula, p :: (Γ0 \ !p) ▷ H)
         (f (p :: (Γ0 \ !p))
            (Logic.eq_rect q (λ H : formula, p :: (Γ0 \ !p) ⊢ H) x
               (A ⊕ M)
               (f_obligation_30 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h)))
         q (f_obligation_31 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h)))
   (A ⊕ M) (f_obligation_32 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h) in
let branch_16:=
 λ (Γ0 : t) (p q : formula) (hin : !p ∈ Γ0) (x : !p :: Γ0 ⊢ q)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : q = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Bang_C Γ0 p q hin x) h),
 Logic.eq_rect q (λ H : formula, Γ0 ▷ H)
   (Bang_C Γ0 p q hin
      (Logic.eq_rect (A ⊕ M) (λ H : formula, !p :: Γ0 ▷ H)
         (f (!p :: Γ0)
            (Logic.eq_rect q (λ H : formula, !p :: Γ0 ⊢ H) x
               (A ⊕ M)
               (f_obligation_33 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h)))
         q (f_obligation_34 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h)))
   (A ⊕ M) (f_obligation_35 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h) in
let branch_17:=
 λ (Γ0 : t) (p q : formula) (hin : !p ∈ Γ0) (x : Γ0 \ !p ⊢ q)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : q = A ⊕ M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Bang_W Γ0 p q hin x) h),
 Logic.eq_rect q (λ H : formula, Γ0 ▷ H)
   (Bang_W Γ0 p q hin
      (Logic.eq_rect (A ⊕ M) (λ H : formula, Γ0 \ !p ▷ H)
         (f (Γ0 \ !p)
            (Logic.eq_rect q (λ H : formula, Γ0 \ !p ⊢ H) x
               (A ⊕ M)
               (f_obligation_36 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h)))
         q (f_obligation_37 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h)))
   (A ⊕ M) (f_obligation_38 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h) in
match
  h as h0 in (e ⊢ f0)
  return (e = Γ → f0 = A ⊕ M → JMeq.JMeq h0 h → e ▷ A ⊕ M)
with
| ILLVarInt.MILL.Id Γ0 p heq => branch_0 Γ0 p heq
| ILLVarInt.MILL.Impl_R Γ0 p q x => branch_1 Γ0 p q x
| ILLVarInt.MILL.Impl_L Γ0 Δ Δ' p q r hin heq x x0 =>
    branch_2 Γ0 Δ Δ' p q r hin heq x x0
| ILLVarInt.MILL.Times_R Γ0 Δ Δ' p q heq x x0 =>
    branch_3 Γ0 Δ Δ' p q heq x x0
| ILLVarInt.MILL.Times_L Γ0 p q r hin x => branch_4 Γ0 p q r hin x
| ILLVarInt.MILL.One_R Γ0 heq => branch_5 Γ0 heq
| ILLVarInt.MILL.One_L Γ0 p hin x => branch_6 Γ0 p hin x
| ILLVarInt.MILL.And_R Γ0 p q x x0 => branch_7 Γ0 p q x x0
| ILLVarInt.MILL.And_L_1 Γ0 p q r hin x => branch_8 Γ0 p q r hin x
| ILLVarInt.MILL.And_L_2 Γ0 p q r hin x => branch_9 Γ0 p q r hin x
| ILLVarInt.MILL.Oplus_L Γ0 p q r hin x x0 => branch_10 Γ0 p q r hin x x0
| ILLVarInt.MILL.Oplus_R_1 Γ0 p q x => branch_11 Γ0 p q x
| ILLVarInt.MILL.Oplus_R_2 Γ0 p q x => branch_12 Γ0 p q x
| ILLVarInt.MILL.T_ Γ0 => branch_13 Γ0
| ILLVarInt.MILL.Zero_ Γ0 p hin => branch_14 Γ0 p hin
| ILLVarInt.MILL.Bang_D Γ0 p q hin x => branch_15 Γ0 p q hin x
| ILLVarInt.MILL.Bang_C Γ0 p q hin x => branch_16 Γ0 p q hin x
| ILLVarInt.MILL.Bang_W Γ0 p q hin x => branch_17 Γ0 p q hin x
end Logic.eq_refl Logic.eq_refl JMeq.JMeq_refl
.

Preterm of fA.
Definition fA :
Tactics.fix_proto (∀ Γ : env, Γ ⊢ A ⊕ M → Γ ▷ A ⊕ M)
→ Tactics.fix_proto (∀ Γ : env, Γ ⊢ A → Γ ▷ A ⊕ M)
  → Tactics.fix_proto (∀ Γ : env, Γ ⊢ M → Γ ▷ A ⊕ M)
    → (∀ Γ : env, Γ ⊢ A → Γ ▷ A ⊕ M)
:=
λ (_ : Tactics.fix_proto (∀ Γ : env, Γ ⊢ A ⊕ M → Γ ▷ A ⊕ M))
(fA : Tactics.fix_proto (∀ Γ : env, Γ ⊢ A → Γ ▷ A ⊕ M))
(fM : Tactics.fix_proto (∀ Γ : env, Γ ⊢ M → Γ ▷ A ⊕ M))
(Γ : env) (h : Γ ⊢ A),
let branch_0:=
 λ (Γ0 : t) (p : formula) (heq : Γ0 == {p}) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p = A) (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Id Γ0 p heq) h),
 Logic.eq_rect (p ⊕ M) (λ H : formula, Γ0 ▷ H)
   (Oplus_R_1 Γ0 p M heq (Id Γ0 p heq)) (A ⊕ M)
   (fA_obligation_1 Γ h Γ0 p heq Heq_Γ Heq_anonymous Heq_h) in
let branch_1:=
 λ (Γ0 : t) (p q : formula) (x : p :: Γ0 ⊢ q) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p ⊸ q = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Impl_R Γ0 p q x) h),
 fA_obligation_2 Γ h Γ0 p q x Heq_Γ Heq_anonymous Heq_h in
let branch_2:=
 λ (Γ0 Δ Δ' : t) (p q r : formula) (hin : p ⊸ q ∈ Γ0)
 (heq : Γ0 \ p ⊸ q == Δ ∪ Δ') (x : Δ ⊢ p) (x0 : q :: Δ' ⊢ r)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : r = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Impl_L Γ0 Δ Δ' p q r hin heq x x0) h),
 Impl_L Γ0 Δ Δ' p q (A ⊕ M) hin heq x
   (fA (q :: Δ')
      (Logic.eq_rect r (λ H : formula, q :: Δ' ⊢ H) x0
         A
         (fA_obligation_3 Γ h Γ0 Δ Δ' p q r hin heq x x0 Heq_Γ Heq_anonymous
            Heq_h))) in
let branch_3:=
 λ (Γ0 Δ Δ' : t) (p q : formula) (heq : Γ0 == Δ ∪ Δ')
 (x : Δ ⊢ p) (x0 : Δ' ⊢ q) (Heq_Γ : Γ0 = Γ) (Heq_anonymous : p ⊗ q = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Times_R Γ0 Δ Δ' p q heq x x0) h),
 fA_obligation_4 Γ h Γ0 Δ Δ' p q heq x x0 Heq_Γ Heq_anonymous Heq_h in
let branch_4:=
 λ (Γ0 : t) (p q r : formula) (hin : p ⊗ q ∈ Γ0)
 (x : q :: p :: (Γ0 \ p ⊗ q) ⊢ r) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : r = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Times_L Γ0 p q r hin x) h),
 Times_L Γ0 p q (A ⊕ M) hin
   (fA (q :: p :: (Γ0 \ p ⊗ q))
      (Logic.eq_rect r (λ H : formula, q :: p :: (Γ0 \ p ⊗ q) ⊢ H) x
         A (fA_obligation_5 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h))) in
let branch_5:=
 λ (Γ0 : t) (heq : Γ0 == ∅) (Heq_Γ : Γ0 = Γ) (Heq_anonymous : 1 = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.One_R Γ0 heq) h),
 fA_obligation_6 Γ h Γ0 heq Heq_Γ Heq_anonymous Heq_h in
let branch_6:=
 λ (Γ0 : t) (p : formula) (hin : 1 ∈ Γ0) (x : Γ0 \ 1 ⊢ p)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : p = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.One_L Γ0 p hin x) h),
 One_L Γ0 (A ⊕ M) hin
   (fA (Γ0 \ 1)
      (Logic.eq_rect p (λ H : formula, Γ0 \ 1 ⊢ H) x
         A (fA_obligation_7 Γ h Γ0 p hin x Heq_Γ Heq_anonymous Heq_h))) in
let branch_7:=
 λ (Γ0 : env) (p q : formula) (x : Γ0 ⊢ p) (x0 : Γ0 ⊢ q)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : p & q = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.And_R Γ0 p q x x0) h),
 fA_obligation_8 Γ h Γ0 p q x x0 Heq_Γ Heq_anonymous Heq_h in
let branch_8:=
 λ (Γ0 : t) (p q r : formula) (hin : p & q ∈ Γ0) (x : p :: (Γ0 \ p & q) ⊢ r)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : r = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.And_L_1 Γ0 p q r hin x) h),
 And_L_1 Γ0 p q (A ⊕ M) hin
   (fA (p :: (Γ0 \ p & q))
      (Logic.eq_rect r (λ H : formula, p :: (Γ0 \ p & q) ⊢ H) x
         A (fA_obligation_9 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h))) in
let branch_9:=
 λ (Γ0 : t) (p q r : formula) (hin : p & q ∈ Γ0) (x : q :: (Γ0 \ p & q) ⊢ r)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : r = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.And_L_2 Γ0 p q r hin x) h),
 And_L_2 Γ0 p q (A ⊕ M) hin
   (fA (q :: (Γ0 \ p & q))
      (Logic.eq_rect r (λ H : formula, q :: (Γ0 \ p & q) ⊢ H) x
         A (fA_obligation_10 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h))) in
let branch_10:=
 λ (Γ0 : t) (p q r : formula) (hin : p ⊕ q ∈ Γ0) (x : p :: (Γ0 \ p ⊕ q) ⊢ r)
 (x0 : q :: (Γ0 \ p ⊕ q) ⊢ r) (Heq_Γ : Γ0 = Γ) (Heq_anonymous : r = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Oplus_L Γ0 p q r hin x x0) h),
 Oplus_L Γ0 p q (A ⊕ M) hin
   (fA (p :: (Γ0 \ p ⊕ q))
      (Logic.eq_rect r (λ H : formula, p :: (Γ0 \ p ⊕ q) ⊢ H) x
         A (fA_obligation_11 Γ h Γ0 p q r hin x x0 Heq_Γ Heq_anonymous Heq_h)))
   (fA (q :: (Γ0 \ p ⊕ q))
      (Logic.eq_rect r (λ H : formula, q :: (Γ0 \ p ⊕ q) ⊢ H) x0
         A (fA_obligation_12 Γ h Γ0 p q r hin x x0 Heq_Γ Heq_anonymous Heq_h))) in
let branch_11:=
 λ (Γ0 : env) (p q : formula) (x : Γ0 ⊢ p) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p ⊕ q = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Oplus_R_1 Γ0 p q x) h),
 fA Γ0
   (Logic.eq_rect p (λ H : formula, Γ0 ⊢ H) x A
      (fA_obligation_13 Γ h Γ0 p q x Heq_Γ Heq_anonymous Heq_h)) in
let branch_12:=
 λ (Γ0 : env) (p q : formula) (x : Γ0 ⊢ q) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p ⊕ q = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Oplus_R_2 Γ0 p q x) h),
 fM Γ0
   (Logic.eq_rect q (λ H : formula, Γ0 ⊢ H) x M
      (fA_obligation_14 Γ h Γ0 p q x Heq_Γ Heq_anonymous Heq_h)) in
let branch_13:=
 λ (Γ0 : env) (Heq_Γ : Γ0 = Γ) (Heq_anonymous : ⊤ = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.T_ Γ0) h),
 Logic.eq_rect (⊤) (λ H : formula, Γ0 ▷ H) (T_ Γ0)
   (A ⊕ M) (fA_obligation_15 Γ h Γ0 Heq_Γ Heq_anonymous Heq_h) in
let branch_14:=
 λ (Γ0 : t) (p : formula) (hin : 0 ∈ Γ0) (_ : Γ0 = Γ)
 (_ : p = A) (_ : JMeq.JMeq (ILLVarInt.MILL.Zero_ Γ0 p hin) h),
 Zero_ Γ0 (A ⊕ M) hin in
let branch_15:=
 λ (Γ0 : t) (p q : formula) (hin : !p ∈ Γ0) (x : p :: (Γ0 \ !p) ⊢ q)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : q = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Bang_D Γ0 p q hin x) h),
 Bang_D Γ0 p (A ⊕ M) hin
   (fA (p :: (Γ0 \ !p))
      (Logic.eq_rect q (λ H : formula, p :: (Γ0 \ !p) ⊢ H) x
         A (fA_obligation_16 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h))) in
let branch_16:=
 λ (Γ0 : t) (p q : formula) (hin : !p ∈ Γ0) (x : !p :: Γ0 ⊢ q)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : q = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Bang_C Γ0 p q hin x) h),
 Bang_C Γ0 p (A ⊕ M) hin
   (fA (!p :: Γ0)
      (Logic.eq_rect q (λ H : formula, !p :: Γ0 ⊢ H) x
         A (fA_obligation_17 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h))) in
let branch_17:=
 λ (Γ0 : t) (p q : formula) (hin : !p ∈ Γ0) (x : Γ0 \ !p ⊢ q)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : q = A)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Bang_W Γ0 p q hin x) h),
 Bang_W Γ0 p (A ⊕ M) hin
   (fA (Γ0 \ !p)
      (Logic.eq_rect q (λ H : formula, Γ0 \ !p ⊢ H) x
         A (fA_obligation_18 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h))) in
match
  h as h0 in (e ⊢ f0) return (e = Γ → f0 = A → JMeq.JMeq h0 h → e ▷ A ⊕ M)
with
| ILLVarInt.MILL.Id Γ0 p heq => branch_0 Γ0 p heq
| ILLVarInt.MILL.Impl_R Γ0 p q x => branch_1 Γ0 p q x
| ILLVarInt.MILL.Impl_L Γ0 Δ Δ' p q r hin heq x x0 =>
    branch_2 Γ0 Δ Δ' p q r hin heq x x0
| ILLVarInt.MILL.Times_R Γ0 Δ Δ' p q heq x x0 =>
    branch_3 Γ0 Δ Δ' p q heq x x0
| ILLVarInt.MILL.Times_L Γ0 p q r hin x => branch_4 Γ0 p q r hin x
| ILLVarInt.MILL.One_R Γ0 heq => branch_5 Γ0 heq
| ILLVarInt.MILL.One_L Γ0 p hin x => branch_6 Γ0 p hin x
| ILLVarInt.MILL.And_R Γ0 p q x x0 => branch_7 Γ0 p q x x0
| ILLVarInt.MILL.And_L_1 Γ0 p q r hin x => branch_8 Γ0 p q r hin x
| ILLVarInt.MILL.And_L_2 Γ0 p q r hin x => branch_9 Γ0 p q r hin x
| ILLVarInt.MILL.Oplus_L Γ0 p q r hin x x0 => branch_10 Γ0 p q r hin x x0
| ILLVarInt.MILL.Oplus_R_1 Γ0 p q x => branch_11 Γ0 p q x
| ILLVarInt.MILL.Oplus_R_2 Γ0 p q x => branch_12 Γ0 p q x
| ILLVarInt.MILL.T_ Γ0 => branch_13 Γ0
| ILLVarInt.MILL.Zero_ Γ0 p hin => branch_14 Γ0 p hin
| ILLVarInt.MILL.Bang_D Γ0 p q hin x => branch_15 Γ0 p q hin x
| ILLVarInt.MILL.Bang_C Γ0 p q hin x => branch_16 Γ0 p q hin x
| ILLVarInt.MILL.Bang_W Γ0 p q hin x => branch_17 Γ0 p q hin x
end Logic.eq_refl Logic.eq_refl JMeq.JMeq_refl.

Preterm of fM.
Definition fM :
Tactics.fix_proto (∀ Γ : env, Γ ⊢ A ⊕ M → Γ ▷ A ⊕ M)
→ Tactics.fix_proto (∀ Γ : env, Γ ⊢ A → Γ ▷ A ⊕ M)
  → Tactics.fix_proto (∀ Γ : env, Γ ⊢ M → Γ ▷ A ⊕ M)
    → (∀ Γ : env, Γ ⊢ M → Γ ▷ A ⊕ M)
:=
λ (_ : Tactics.fix_proto (∀ Γ : env, Γ ⊢ A ⊕ M → Γ ▷ A ⊕ M))
(fA : Tactics.fix_proto (∀ Γ : env, Γ ⊢ A → Γ ▷ A ⊕ M))
(fM : Tactics.fix_proto (∀ Γ : env, Γ ⊢ M → Γ ▷ A ⊕ M))
(Γ : env) (h : Γ ⊢ M),
let branch_0:=
 λ (Γ0 : t) (p : formula) (heq : Γ0 == {p}) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p = M) (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Id Γ0 p heq) h),
 Logic.eq_rect (A ⊕ p) (λ H : formula, Γ0 ▷ H)
   (Oplus_R_2 Γ0 A p heq
      (Id Γ0 p heq)) (A ⊕ M)
   (fM_obligation_2 Γ h Γ0 p heq Heq_Γ Heq_anonymous Heq_h) in
let branch_1:=
 λ (Γ0 : t) (p q : formula) (x : p :: Γ0 ⊢ q) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p ⊸ q = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Impl_R Γ0 p q x) h),
 fM_obligation_3 Γ h Γ0 p q x Heq_Γ Heq_anonymous Heq_h in
let branch_2:=
 λ (Γ0 Δ Δ' : t) (p q r : formula) (hin : p ⊸ q ∈ Γ0)
 (heq : Γ0 \ p ⊸ q == Δ ∪ Δ') (x : Δ ⊢ p) (x0 : q :: Δ' ⊢ r)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : r = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Impl_L Γ0 Δ Δ' p q r hin heq x x0) h),
 Impl_L Γ0 Δ Δ' p q (A ⊕ M) hin heq x
   (fM (q :: Δ')
      (Logic.eq_rect r (λ H : formula, q :: Δ' ⊢ H) x0
         M
         (fM_obligation_4 Γ h Γ0 Δ Δ' p q r hin heq x x0 Heq_Γ Heq_anonymous
            Heq_h))) in
let branch_3:=
 λ (Γ0 Δ Δ' : t) (p q : formula) (heq : Γ0 == Δ ∪ Δ')
 (x : Δ ⊢ p) (x0 : Δ' ⊢ q) (Heq_Γ : Γ0 = Γ) (Heq_anonymous : p ⊗ q = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Times_R Γ0 Δ Δ' p q heq x x0) h),
 fM_obligation_5 Γ h Γ0 Δ Δ' p q heq x x0 Heq_Γ Heq_anonymous Heq_h in
let branch_4:=
 λ (Γ0 : t) (p q r : formula) (hin : p ⊗ q ∈ Γ0)
 (x : q :: p :: (Γ0 \ p ⊗ q) ⊢ r) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : r = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Times_L Γ0 p q r hin x) h),
 Times_L Γ0 p q (A ⊕ M) hin
   (fM (q :: p :: (Γ0 \ p ⊗ q))
      (Logic.eq_rect r (λ H : formula, q :: p :: (Γ0 \ p ⊗ q) ⊢ H) x
         M (fM_obligation_6 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h))) in
let branch_5:=
 λ (Γ0 : t) (heq : Γ0 == ∅) (Heq_Γ : Γ0 = Γ) (Heq_anonymous : 1 = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.One_R Γ0 heq) h),
 fM_obligation_7 Γ h Γ0 heq Heq_Γ Heq_anonymous Heq_h in
let branch_6:=
 λ (Γ0 : t) (p : formula) (hin : 1 ∈ Γ0) (x : Γ0 \ 1 ⊢ p)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : p = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.One_L Γ0 p hin x) h),
 One_L Γ0 (A ⊕ M) hin
   (fM (Γ0 \ 1)
      (Logic.eq_rect p (λ H : formula, Γ0 \ 1 ⊢ H) x
         M (fM_obligation_8 Γ h Γ0 p hin x Heq_Γ Heq_anonymous Heq_h))) in
let branch_7:=
 λ (Γ0 : env) (p q : formula) (x : Γ0 ⊢ p) (x0 : Γ0 ⊢ q)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : p & q = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.And_R Γ0 p q x x0) h),
 fM_obligation_9 Γ h Γ0 p q x x0 Heq_Γ Heq_anonymous Heq_h in
let branch_8:=
 λ (Γ0 : t) (p q r : formula) (hin : p & q ∈ Γ0) (x : p :: (Γ0 \ p & q) ⊢ r)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : r = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.And_L_1 Γ0 p q r hin x) h),
 And_L_1 Γ0 p q (A ⊕ M) hin
   (fM (p :: (Γ0 \ p & q))
      (Logic.eq_rect r (λ H : formula, p :: (Γ0 \ p & q) ⊢ H) x
         M (fM_obligation_10 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h))) in
let branch_9:=
 λ (Γ0 : t) (p q r : formula) (hin : p & q ∈ Γ0) (x : q :: (Γ0 \ p & q) ⊢ r)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : r = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.And_L_2 Γ0 p q r hin x) h),
 And_L_2 Γ0 p q (A ⊕ M) hin
   (fM (q :: (Γ0 \ p & q))
      (Logic.eq_rect r (λ H : formula, q :: (Γ0 \ p & q) ⊢ H) x
         M (fM_obligation_11 Γ h Γ0 p q r hin x Heq_Γ Heq_anonymous Heq_h))) in
let branch_10:=
 λ (Γ0 : t) (p q r : formula) (hin : p ⊕ q ∈ Γ0) (x : p :: (Γ0 \ p ⊕ q) ⊢ r)
 (x0 : q :: (Γ0 \ p ⊕ q) ⊢ r) (Heq_Γ : Γ0 = Γ) (Heq_anonymous : r = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Oplus_L Γ0 p q r hin x x0) h),
 Oplus_L Γ0 p q (A ⊕ M) hin
   (fM (p :: (Γ0 \ p ⊕ q))
      (Logic.eq_rect r (λ H : formula, p :: (Γ0 \ p ⊕ q) ⊢ H) x
         M (fM_obligation_12 Γ h Γ0 p q r hin x x0 Heq_Γ Heq_anonymous Heq_h)))
   (fM (q :: (Γ0 \ p ⊕ q))
      (Logic.eq_rect r (λ H : formula, q :: (Γ0 \ p ⊕ q) ⊢ H) x0
         M (fM_obligation_13 Γ h Γ0 p q r hin x x0 Heq_Γ Heq_anonymous Heq_h))) in
let branch_11:=
 λ (Γ0 : env) (p q : formula) (x : Γ0 ⊢ p) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p ⊕ q = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Oplus_R_1 Γ0 p q x) h),
 fA Γ0
   (Logic.eq_rect p (λ H : formula, Γ0 ⊢ H) x A
      (fM_obligation_14 Γ h Γ0 p q x Heq_Γ Heq_anonymous Heq_h)) in
let branch_12:=
 λ (Γ0 : env) (p q : formula) (x : Γ0 ⊢ q) (Heq_Γ : Γ0 = Γ)
 (Heq_anonymous : p ⊕ q = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Oplus_R_2 Γ0 p q x) h),
 fM Γ0
   (Logic.eq_rect q (λ H : formula, Γ0 ⊢ H) x M
      (fM_obligation_15 Γ h Γ0 p q x Heq_Γ Heq_anonymous Heq_h)) in
let branch_13:=
 λ (Γ0 : env) (Heq_Γ : Γ0 = Γ) (Heq_anonymous : ⊤ = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.T_ Γ0) h),
 Logic.eq_rect (⊤) (λ H : formula, Γ0 ▷ H) (T_ Γ0)
   (A ⊕ M) (fM_obligation_16 Γ h Γ0 Heq_Γ Heq_anonymous Heq_h) in
let branch_14:=
 λ (Γ0 : t) (p : formula) (hin : 0 ∈ Γ0) (_ : Γ0 = Γ)
 (_ : p = M) (_ : JMeq.JMeq (ILLVarInt.MILL.Zero_ Γ0 p hin) h),
 Zero_ Γ0 (A ⊕ M) hin in
let branch_15:=
 λ (Γ0 : t) (p q : formula) (hin : !p ∈ Γ0) (x : p :: (Γ0 \ !p) ⊢ q)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : q = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Bang_D Γ0 p q hin x) h),
 Bang_D Γ0 p (A ⊕ M) hin
   (fM (p :: (Γ0 \ !p))
      (Logic.eq_rect q (λ H : formula, p :: (Γ0 \ !p) ⊢ H) x
         M (fM_obligation_17 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h))) in
let branch_16:=
 λ (Γ0 : t) (p q : formula) (hin : !p ∈ Γ0) (x : !p :: Γ0 ⊢ q)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : q = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Bang_C Γ0 p q hin x) h),
 Bang_C Γ0 p (A ⊕ M) hin
   (fM (!p :: Γ0)
      (Logic.eq_rect q (λ H : formula, !p :: Γ0 ⊢ H) x
         M (fM_obligation_18 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h))) in
let branch_17:=
 λ (Γ0 : t) (p q : formula) (hin : !p ∈ Γ0) (x : Γ0 \ !p ⊢ q)
 (Heq_Γ : Γ0 = Γ) (Heq_anonymous : q = M)
 (Heq_h : JMeq.JMeq (ILLVarInt.MILL.Bang_W Γ0 p q hin x) h),
 Bang_W Γ0 p (A ⊕ M) hin
   (fM (Γ0 \ !p)
      (Logic.eq_rect q (λ H : formula, Γ0 \ !p ⊢ H) x
         M (fM_obligation_19 Γ h Γ0 p q hin x Heq_Γ Heq_anonymous Heq_h))) in
match
  h as h0 in (e ⊢ f0) return (e = Γ → f0 = M → JMeq.JMeq h0 h → e ▷ A ⊕ M)
with
| ILLVarInt.MILL.Id Γ0 p heq => branch_0 Γ0 p heq
| ILLVarInt.MILL.Impl_R Γ0 p q x => branch_1 Γ0 p q x
| ILLVarInt.MILL.Impl_L Γ0 Δ Δ' p q r hin heq x x0 =>
    branch_2 Γ0 Δ Δ' p q r hin heq x x0
| ILLVarInt.MILL.Times_R Γ0 Δ Δ' p q heq x x0 =>
    branch_3 Γ0 Δ Δ' p q heq x x0
| ILLVarInt.MILL.Times_L Γ0 p q r hin x => branch_4 Γ0 p q r hin x
| ILLVarInt.MILL.One_R Γ0 heq => branch_5 Γ0 heq
| ILLVarInt.MILL.One_L Γ0 p hin x => branch_6 Γ0 p hin x
| ILLVarInt.MILL.And_R Γ0 p q x x0 => branch_7 Γ0 p q x x0
| ILLVarInt.MILL.And_L_1 Γ0 p q r hin x => branch_8 Γ0 p q r hin x
| ILLVarInt.MILL.And_L_2 Γ0 p q r hin x => branch_9 Γ0 p q r hin x
| ILLVarInt.MILL.Oplus_L Γ0 p q r hin x x0 => branch_10 Γ0 p q r hin x x0
| ILLVarInt.MILL.Oplus_R_1 Γ0 p q x => branch_11 Γ0 p q x
| ILLVarInt.MILL.Oplus_R_2 Γ0 p q x => branch_12 Γ0 p q x
| ILLVarInt.MILL.T_ Γ0 => branch_13 Γ0
| ILLVarInt.MILL.Zero_ Γ0 p hin => branch_14 Γ0 p hin
| ILLVarInt.MILL.Bang_D Γ0 p q hin x => branch_15 Γ0 p q hin x
| ILLVarInt.MILL.Bang_C Γ0 p q hin x => branch_16 Γ0 p q hin x
| ILLVarInt.MILL.Bang_W Γ0 p q hin x => branch_17 Γ0 p q hin x
end Logic.eq_refl Logic.eq_refl JMeq.JMeq_refl.

Print Assumptions f.
Print Assumptions fA.
Print Assumptions fM.

Lemma f':∀ Γ X (h':X=A⊕M)(h:Γ⊢X) ,  Γ▷A⊕M
with fA':∀ Γ X  (h':X=A) (h:Γ⊢A),Γ▷A⊕M
with fM':∀ Γ X  (h':X=M) (h:Γ⊢M),Γ▷A⊕M.
Show Proof.
  intros Γ X h' h.
  apply f.
  unfold Tactics.fix_proto.
  intros Γ0 H.
  eapply f' with X.
  assumption.
  rewrite h'.
  assumption.
  unfold Tactics.fix_proto.
  intros Γ0 H.
  eapply fA' with A;trivial.
  unfold Tactics.fix_proto.
  intros Γ0 H.
  eapply fM' with M;trivial.
  rewrite <- h'.
  assumption.

  intros Γ X h' h.
  apply fA.
  unfold Tactics.fix_proto.
  intros Γ0 H.
  eapply f' with (A⊕M);trivial.
  unfold Tactics.fix_proto.
  intros Γ0 H.
  eapply fA' with X;trivial.
  unfold Tactics.fix_proto.
  intros Γ0 H.
  eapply fM' with M;trivial.
  assumption.

  intros Γ X h' h.
  apply fM.
  unfold Tactics.fix_proto.
  intros Γ0 H.
  eapply f' with (A⊕M);trivial.
  unfold Tactics.fix_proto.
  intros Γ0 H.
  eapply fA' with A;trivial.
  unfold Tactics.fix_proto.
  intros Γ0 H.
  eapply fM' with X;trivial.
  assumption.
Defined.
Print f'.

(*
Program Fixpoint toto Γ (h:Γ⊢A⊕M) (hI:IReach atheseA' (f' _ _ _ h)): titi.IReach atheseA h :=
    match h with
      | ILLVarInt.MILL.Id Γ p x => _
      | ILLVarInt.MILL.Impl_R Γ p q x => _
      | ILLVarInt.MILL.Impl_L Γ Δ Δ' p q r x x0 x1 x2 => _
      | ILLVarInt.MILL.Times_R Γ Δ Δ' p q x x0 x1 => _
      | ILLVarInt.MILL.Times_L Γ p q r x x0 => _
      | ILLVarInt.MILL.One_R Γ x => _
      | ILLVarInt.MILL.One_L Γ p x x0 => _
      | ILLVarInt.MILL.And_R Γ p q x x0 => _
      | ILLVarInt.MILL.And_L_1 Γ p q r x x0 => _
      | ILLVarInt.MILL.And_L_2 Γ p q r x x0 => _
      | ILLVarInt.MILL.Oplus_L Γ p q r x x0 x1 => _
      | ILLVarInt.MILL.Oplus_R_1 Γ p q x0 => _
      | ILLVarInt.MILL.Oplus_R_2 Γ p q x0 => _
      | ILLVarInt.MILL.T_ Γ => _
      | ILLVarInt.MILL.Zero_ Γ p x => _
      | ILLVarInt.MILL.Bang_D Γ p q x x0 => _
      | ILLVarInt.MILL.Bang_C Γ p q x x0 => _
      | ILLVarInt.MILL.Bang_W Γ p q x x0 => _
    end
.
Preterm of toto.
Next Obligation of toto.
*)

(*
Lemma essai : (∀ Γ X (heq:X=A⊕M)(h:Γ⊢X), IReach atheseA' (f' _ _ heq h) → titi.IReach atheseA h).
Proof.
  fix 4.
  intros Γ X heq h H.
  subst X.
  refine (match
           h as h0 in (e ⊢ f)
             return (e = Γ → f = A ⊕ M → JMeq.JMeq h0 h → titi.IReach atheseA h)
           with
           | ILLVarInt.MILL.Id Γ0 p x => _
           | ILLVarInt.MILL.Impl_R Γ0 p q x => _
           | ILLVarInt.MILL.Impl_L Γ0 Δ Δ' p q r x x0 x1 x2 => _
           | ILLVarInt.MILL.Times_R Γ0 Δ Δ' p q x x0 x1 => _
           | ILLVarInt.MILL.Times_L Γ0 p q r x x0 => _
           | ILLVarInt.MILL.One_R Γ0 x => _
           | ILLVarInt.MILL.One_L Γ0 p x x0 => _
           | ILLVarInt.MILL.And_R Γ0 p q x x0 => _
           | ILLVarInt.MILL.And_L_1 Γ0 p q r x x0 => _
           | ILLVarInt.MILL.And_L_2 Γ0 p q r x x0 => _
           | ILLVarInt.MILL.Oplus_L Γ0 p q r x x0 x1 => _
           | ILLVarInt.MILL.Oplus_R_1 Γ0 p q x0 => _
           | ILLVarInt.MILL.Oplus_R_2 Γ0 p q x0 => _
           | ILLVarInt.MILL.T_ Γ0 => _
           | ILLVarInt.MILL.Zero_ Γ0 p x => _
           | ILLVarInt.MILL.Bang_D Γ0 p q x x0 => _
           | ILLVarInt.MILL.Bang_C Γ0 p q x x0 => _
           | ILLVarInt.MILL.Bang_W Γ0 p q x x0 => _
         end Logic.eq_refl Logic.eq_refl JMeq.JMeq_refl).

  intros H0 H1 H2.
  subst.
  assert (JMeq.JMeq H (Id Γ (A⊕M) x)).
  Focus 2.
  constructor 1.
  subst h.
  unfold atheseA.
  simpl in H.
  set  (Y:=(Id Γ (A ⊕ M) (λ x0 : Maps'.key, x x0))) in *.
  assert (Y=(Id Γ (A ⊕ M) (λ x0 : Maps'.key, x x0))) by auto.
  clearbody Y.
  revert H0 H.
  destruct Y.
  dependent inversion Y.

  refine (match H with
            | # => #
          end)

  intros Γ X heq h.
  revert heq.
  case h;clear -essai;intros.

  revert H.
  simpl.
  simpl in H.
  unfold f in H.
subst.

Check (λ (Γ : env) (X : formula) (h : Γ ⊢ X),
 IReach atheseA' (f' Γ X heq h) → titi.IReach atheseA h).

case h.
  revert heq.
  revert h.
  pattern Γ, X.
  apply ILLVarInt.MILL.ILL_proof_ind;clear;intros.
subst.
dependent inversion h.
Show 2.
simpl in H0.
  Check (λ (Γ : env) (X : formula),
    ∀ heq : X = A ⊕ M, IReach atheseA' (f' Γ X heq h) → titi.IReach atheseA h).²
  induction h.
  intros Γ h.
  set (X:=A ⊕ M) in *.
  assert (heq:=refl_equal X).
  unfold X at 2 in heq.
  clearbody X.

  pattern Γ, h.
  simple apply ILLVarInt.MILL.ILL_proof_ind.
  fix 2.
  intros Γ h H.
  refine (match
            h as h0 in (e ⊢ f)
              return (e = Γ → f = A ⊕ M → JMeq.JMeq h0 h → titi.IReach atheseA h)
            with
            | ILLVarInt.MILL.Id Γ0 p x => _
            | ILLVarInt.MILL.Impl_R Γ0 p q x => _
            | ILLVarInt.MILL.Impl_L Γ0 Δ Δ' p q r x x0 x1 x2 => _
            | ILLVarInt.MILL.Times_R Γ0 Δ Δ' p q x x0 x1 => _
            | ILLVarInt.MILL.Times_L Γ0 p q r x x0 => _
            | ILLVarInt.MILL.One_R Γ0 x => _
            | ILLVarInt.MILL.One_L Γ0 p x x0 => _
            | ILLVarInt.MILL.And_R Γ0 p q x x0 => _
            | ILLVarInt.MILL.And_L_1 Γ0 p q r x x0 => _
            | ILLVarInt.MILL.And_L_2 Γ0 p q r x x0 => _
            | ILLVarInt.MILL.Oplus_L Γ0 p q r x x0 x1 => _
            | ILLVarInt.MILL.Oplus_R_1 Γ0 p q x0 => _
            | ILLVarInt.MILL.Oplus_R_2 Γ0 p q x0 => _
            | ILLVarInt.MILL.T_ Γ0 => _
            | ILLVarInt.MILL.Zero_ Γ0 p x => _
            | ILLVarInt.MILL.Bang_D Γ0 p q x x0 => _
            | ILLVarInt.MILL.Bang_C Γ0 p q x x0 => _
            | ILLVarInt.MILL.Bang_W Γ0 p q x x0 => _
          end Logic.eq_refl Logic.eq_refl JMeq.JMeq_refl);intros; subst; subst.
  induction H.
  constructor;subst.
  simpl in H.
  info inversion H.
  Focus 2.
  destruct H.
  setoid_rewrite <- H2.
case h.
Guarded.
  apply essai.

Lemma essai : (∀ Γ p (h:Γ⊢p) h', h' = (f' _ h) → (p=A⊕M) → IReach atheseA' h' → titi.IReach atheseA h).
Proof.
  fix 2.
  intros Γ h h'.
  case h.
  dependent inversion h.
  set (X:=A ⊕ M).
  assert(X=A ⊕ M) by auto.
  clearbody X.
  rewrite <- H in *.

  refine (
    match h with
      | ILLVarInt.MILL.Id Γ p x => _
      | ILLVarInt.MILL.Impl_R Γ p q x => _
      | ILLVarInt.MILL.Impl_L Γ Δ Δ' p q r x x0 x1 x2 => _
      | ILLVarInt.MILL.Times_R Γ Δ Δ' p q x x0 x1 => _
      | ILLVarInt.MILL.Times_L Γ p q r x x0 => _
      | ILLVarInt.MILL.One_R Γ x => _
      | ILLVarInt.MILL.One_L Γ p x x0 => _
      | ILLVarInt.MILL.And_R Γ p q x x0 => _
      | ILLVarInt.MILL.And_L_1 Γ p q r x x0 => _
      | ILLVarInt.MILL.And_L_2 Γ p q r x x0 => _
      | ILLVarInt.MILL.Oplus_L Γ p q r x x0 x1 => _
      | ILLVarInt.MILL.Oplus_R_1 Γ p q x0 => _
      | ILLVarInt.MILL.Oplus_R_2 Γ p q x0 => _
      | ILLVarInt.MILL.T_ Γ => _
      | ILLVarInt.MILL.Zero_ Γ p x => _
      | ILLVarInt.MILL.Bang_D Γ p q x x0 => _
      | ILLVarInt.MILL.Bang_C Γ p q x x0 => _
      | ILLVarInt.MILL.Bang_W Γ p q x x0 => _
    end
  ).
  dependent destruct h.
  intros Γ h.
  induction h.
Qed.

*)