From mathcomp Require Import ssreflect.
Require Import Reals Coquelicot.Coquelicot Fourier.

Lemma ball_Rabs x y e : ball x e y <-> Rabs (y - x) < e.
Proof. intros; tauto. Qed.

Definition filter_Rlt F1 F2 :=
  exists m, filter_prod F1 F2 (fun p => fst p < m < snd p).

Lemma filter_Rlt_witness m (F1 F2  : (R -> Prop) -> Prop) :
  F1 (Rgt m) -> F2 (Rlt m) ->  filter_Rlt F1 F2.
Proof.
exists m; split with (Rgt m) (Rlt m); simpl; auto with real.
Qed.

Lemma filter_Rlt_m_infty_p_infty :
  filter_Rlt (Rbar_locally m_infty) (Rbar_locally p_infty).
Proof.
apply (filter_Rlt_witness 0); exists 0; tauto.
Qed.

Lemma filter_Rlt_m_infty_at_left b :
  filter_Rlt (Rbar_locally m_infty) (at_left b).
Proof.
apply (filter_Rlt_witness (b - 1)).
  now exists (b - 1); intros x cmpx; apply Rlt_gt.
exists pos_half; intros x yb _.
enough (b - x  < 1) by fourier.
apply Rle_lt_trans with (abs (minus b x)).
  now apply Rle_abs.
apply ball_sym in yb; apply AbsRing_norm_compat2 in yb.
apply Rlt_trans with (1 := yb).
rewrite Rmult_1_l; simpl.
fourier.
Qed.

Lemma filter_Rlt_at_right_p_infty b :
  filter_Rlt (at_right b) (Rbar_locally p_infty).
Proof.
apply (filter_Rlt_witness (b + 1)).
  exists pos_half; intros y yb _.
  enough (y - b < 1) by fourier.
  apply Rle_lt_trans with (abs (minus y b)).
    now apply Rle_abs.
  apply AbsRing_norm_compat2 in yb.
  apply Rlt_trans with (1 := yb).
  rewrite Rmult_1_l; simpl.
  fourier.
now exists (b + 1); intros x cmpx.
Qed.

Lemma filter_Rlt_at_point_p_infty b :
  filter_Rlt (at_point b) (Rbar_locally p_infty).
Proof.
apply (filter_Rlt_witness (b + 1)).
  now unfold at_point; fourier.
now exists (b + 1); tauto.
Qed.

Lemma filter_Rlt_m_infty_at_point b :
  filter_Rlt (Rbar_locally m_infty) (at_point b).
Proof.
apply (filter_Rlt_witness (b - 1)).
  now exists (b - 1); tauto.
now unfold at_point; fourier.
Qed.

Local Lemma compare_half_sum a b (altb : a < b) : a < (a + b) / 2 < b.
Proof.
assert ((a + b) / 2 * 2 = a + b) by field.
split; apply Rmult_lt_reg_r with 2; fourier.
Qed.

Lemma filter_Rlt_at_point a b : a < b ->
  filter_Rlt (at_point a) (at_point b).
Proof.
intros altb; apply filter_Rlt_witness with ((a + b) / 2).
  unfold at_point.
  now destruct (compare_half_sum _ _ altb); tauto.
unfold at_point.
now destruct (compare_half_sum _ _ altb); tauto.
Qed.

Lemma Rplus_minus_cancel1 : forall a b, a + b - a = b.
Proof. intros; ring. Qed.

Lemma filter_Rlt_locally a b : a < b ->
  filter_Rlt (Rbar_locally a) (Rbar_locally b).
Proof.
intros ab.
assert (bmap: 0 < (b - a)/2).
  apply Rmult_lt_reg_r with 2;[fourier | ].
  unfold Rdiv; rewrite -> Rmult_0_l, Rmult_assoc.
  rewrite -> Rinv_l, Rmult_1_r;[ | apply Rgt_not_eq]; fourier.
apply (filter_Rlt_witness ((a + b)/2)).
  exists (mkposreal _ bmap); intros y ya.
  enough (yma : y * 2 - a * 2 < b - a).
    apply Rmult_lt_reg_r with 2;[fourier | ].
    unfold Rdiv; rewrite -> Rmult_assoc, Rinv_l;[ | apply Rgt_not_eq; fourier].
    rewrite -> Rmult_1_r; fourier.
  rewrite <- Rmult_minus_distr_r; apply Rmult_lt_reg_r with (/2).
    apply Rinv_0_lt_compat; fourier.
  rewrite -> Rmult_assoc, Rinv_r, Rmult_1_r;[|apply Rgt_not_eq; fourier].
  apply Rle_lt_trans with (abs (minus y a)).
    now apply Rle_abs.
  apply AbsRing_norm_compat2 in ya; apply Rlt_le_trans with (1 := ya).
  now rewrite -> Rmult_1_l; simpl; auto with real.
exists (mkposreal _ bmap); intros y yb.
enough (yma : b * 2 - y * 2 < b - a).
  apply Rmult_lt_reg_r with 2;[fourier | ].
  unfold Rdiv; rewrite -> Rmult_assoc, Rinv_l;[ | apply Rgt_not_eq; fourier].
  rewrite -> Rmult_1_r; fourier.
rewrite <- Rmult_minus_distr_r; apply Rmult_lt_reg_r with (/2).
  apply Rinv_0_lt_compat; fourier.
rewrite -> Rmult_assoc, Rinv_r, Rmult_1_r;[|apply Rgt_not_eq; fourier].
apply Rle_lt_trans with (abs (minus b y)).
  now apply Rle_abs.
apply ball_sym in yb; apply AbsRing_norm_compat2 in yb.
  apply Rlt_le_trans with (1 := yb).
now rewrite -> Rmult_1_l; simpl; auto with real.
Qed.

Lemma filter_Rlt_left_right  a b : a <= b ->
  filter_Rlt (at_left a) (at_right b).
intros ab; apply (filter_Rlt_witness a).
  now exists pos_half; intros y _; apply Rgt_lt.
now exists pos_half; intros y _ yb ; apply Rle_lt_trans with b.
Qed.

Lemma filter_Rlt_trans a F G {FF : Filter F} {GG : Filter G} :
  filter_Rlt F (at_point a) ->
  filter_Rlt (at_point a) G -> filter_Rlt F G.
Proof.
intros [m1 Pm1] [m2 Pm2].
apply filter_Rlt_witness with a.
  destruct Pm1 as [P Q FP atQ cnd1].
  assert (qa : Q a) by now apply atQ; intros; apply ball_center.
  apply (filter_imp P); auto.
  intros x px.
  assert (t := cnd1 x a px qa); simpl in t; destruct t; fourier.
destruct Pm2 as [P Q atP GQ cnd2].
assert (pa : P a) by now apply atP; intros; apply ball_center.
apply (filter_imp Q); auto.
intros x qx.
assert (t := cnd2 a x pa qx); simpl in t; destruct t; fourier.
Qed.

Lemma filter_Rlt_right_left a b : a < b ->
  filter_Rlt (at_right a) (at_left b).
Proof.
intros ab.
assert (bmap: 0 < (b - a)/2).
  apply Rmult_lt_reg_r with 2;[fourier | ].
  unfold Rdiv; rewrite -> Rmult_0_l, Rmult_assoc.
  rewrite -> Rinv_l, Rmult_1_r;[ | apply Rgt_not_eq]; fourier.
apply (filter_Rlt_witness ((a + b)/2)).
  exists (mkposreal _ bmap); intros y ya cmp.
  enough (yma : y * 2 - a * 2 < b - a).
    apply Rmult_lt_reg_r with 2;[fourier | ].
    unfold Rdiv; rewrite -> Rmult_assoc, Rinv_l;[ | apply Rgt_not_eq; fourier].
    rewrite -> Rmult_1_r; fourier.
  rewrite <- Rmult_minus_distr_r; apply Rmult_lt_reg_r with (/2).
    apply Rinv_0_lt_compat; fourier.
  rewrite -> Rmult_assoc, Rinv_r, Rmult_1_r;[|apply Rgt_not_eq; fourier].
  apply Rle_lt_trans with (abs (minus y a)).
    now apply Rle_abs.
  apply AbsRing_norm_compat2 in ya; apply Rlt_le_trans with (1 := ya).
  now rewrite -> Rmult_1_l; simpl; auto with real.
exists (mkposreal _ bmap); intros y yb cmp.
enough (yma : b * 2 - y * 2 < b - a).
  apply Rmult_lt_reg_r with 2;[fourier | ].
  unfold Rdiv; rewrite -> Rmult_assoc, Rinv_l;[ | apply Rgt_not_eq; fourier].
  rewrite -> Rmult_1_r; fourier.
rewrite <- Rmult_minus_distr_r; apply Rmult_lt_reg_r with (/2).
  apply Rinv_0_lt_compat; fourier.
rewrite -> Rmult_assoc, Rinv_r, Rmult_1_r;[|apply Rgt_not_eq; fourier].
apply Rle_lt_trans with (abs (minus b y)).
  now apply Rle_abs.
apply ball_sym in yb; apply AbsRing_norm_compat2 in yb.
  apply Rlt_le_trans with (1 := yb).
now rewrite -> Rmult_1_l; simpl; auto with real.
Qed.

Local Ltac chain_comparisons :=
  match goal with
  | h : ?a <= _ |- ?a < _ => apply Rle_lt_trans with (1 := h)
  | h : _ <= ?a |- _ < ?a => apply Rlt_le_trans with (2 := h)
  | h : ?a < _ |- ?a < _ => apply Rlt_trans with (1 := h)
  | h : _ < ?a |- _ < ?a => apply Rlt_trans with (2 := h)
  end.

Lemma ex_RInt_gen_bound (g : R -> R) (f : R -> R) F G
  {PF : ProperFilter F} {PG : ProperFilter G} :
  filter_Rlt F G ->
  ex_RInt_gen g F G ->
  filter_prod F G
    (fun p => (forall x, fst p < x < snd p -> 0 <= f x <= g x) /\
       ex_RInt f (fst p) (snd p)) ->
    ex_RInt_gen f F G.
Proof.
intros [m mmid] [gl intg] cmp.
assert (F (Rgt m)).
  destruct mmid as [pf pg fpf gpg cmp'].
  apply (filter_imp pf); destruct (filter_ex pg) as [y py]; auto.
  intros x px; destruct (cmp' x y px py) as [it _]; exact it.
assert (G (Rlt m)).
  destruct mmid as [pf pg fpf gpg cmp'].
  apply (filter_imp pg); destruct (filter_ex (F := F) pf) as [x px]; auto.
  intros y py; destruct (cmp' x y px py) as [_ it]; exact it.
exists (lim (filtermap (fun p => RInt f (fst p) (snd p)) (filter_prod F G))).
destruct cmp as [Q1 R1 fq1 gr1 cmp]; simpl in cmp.
assert (cc : cauchy (filtermap (fun p => RInt f (fst p) (snd p))
                       (filter_prod F G))).
  intros eps.
  destruct (intg _ (locally_ball gl (pos_div_2 eps))) as [Qg Rg FQg GRg main].
  assert (fq : F (fun x => Q1 x /\ Qg x /\ m > x))
    by now repeat apply filter_and.
  assert (gr : G (fun x => R1 x /\ Rg x /\ m < x))
    by now repeat apply filter_and.
  destruct (filter_ex _ fq) as [x qx], (filter_ex _ gr) as [y ry].
    exists (RInt f x y).
  exists (fun x => Q1 x /\ Qg x /\ m > x)
         (fun y => R1 y /\ Rg y /\ m < y);
    try now repeat apply filter_and.
  intros u v Qu Rv.
  assert (wlog_cc : forall a b c d,
            Q1 a /\ Qg a ->
            Q1 b /\ Qg b ->
            R1 c /\ Rg c ->
            R1 d /\ Rg d ->
            a <= b -> c <=d -> b < m -> m < c ->
            (ball (RInt f a d) eps (RInt f b c) /\
            ball (RInt f a c) eps (RInt f b d))).
    clear x y qx ry u v Qu Rv; intros a b c d Qa Qb Rc Rd ab cd bm mc.
    assert (ex_RInt f a c /\ ex_RInt f b c /\ ex_RInt f b d).
      now repeat apply conj; apply cmp.
    move main after mc.
    destruct (main a c) as [gac [acP acQ]]; try tauto; simpl in acP.
    assert (ex_RInt g a c) by (eapply ex_intro; eauto).
    destruct (main b c) as [gbc [bcP bcQ]]; try tauto; simpl in bcP.
    assert (ex_RInt g b c) by (eapply ex_intro; eauto).
    destruct (main b d) as [gbd [bdP bdQ]]; try tauto; simpl in bdP.
    assert (ex_RInt g b d) by (eapply ex_intro; eauto).
    assert (ex_RInt f a b).
      now apply ex_RInt_Chasles with c;[ | apply ex_RInt_swap].
    assert (ex_RInt f c d).
      now apply ex_RInt_Chasles with b;[apply ex_RInt_swap | ].
    assert (ex_RInt g a b).
      now apply ex_RInt_Chasles with c;[ | apply ex_RInt_swap];
       eapply ex_intro; eauto.
    assert (ex_RInt g c d).
      now apply ex_RInt_Chasles with b;[apply ex_RInt_swap | ];
       eapply ex_intro; eauto.
    assert (bc : b < c) by (apply Rlt_trans with m; tauto).
    split.
      apply ball_sym, Rle_lt_trans with (Rabs (RInt g a d - RInt g b c)).
        rewrite <- (RInt_Chasles f a b d), <- (RInt_Chasles f b c d),
                <- (RInt_Chasles g a b d), <- (RInt_Chasles g b c d),
               !(Rplus_comm (RInt _ a b)), !Rplus_assoc, !Rplus_minus_cancel1;
         try tauto.
        unfold abs; simpl; rewrite -> !Rabs_right;
        try (apply Rle_ge, Rplus_le_le_0_compat; apply RInt_ge_0; auto);
(* The following fragment duplicated several times. *)
        try (intros x [x1 x2]; enough (0 <= f x <= g x)
           by (solve[tauto | apply Rle_trans with (f x); tauto]);
           apply (cmp a d); try tauto; split;
           solve[repeat (auto; chain_comparisons)]).
        apply Rplus_le_compat; apply RInt_le; try tauto;
(* the following fragment duplicated several times. *)
        try (intros x [x1 x2]; enough (0 <= f x <= g x)
           by (solve[tauto | apply Rle_trans with (f x); tauto]);
           apply (cmp a d); try tauto; split;
           solve[repeat (auto; chain_comparisons)]).
      change (ball (RInt g b c) eps (RInt g a d)).
      replace (pos eps) with (pos_div_2 eps + pos_div_2 eps) by (simpl; field).
      apply ball_triangle with gl.
        now rewrite -> (is_RInt_unique _ _ _ _ bcP); apply ball_sym.
      destruct (main a d) as [gad [adP adQ]]; try tauto; simpl in adP.
      now rewrite -> (is_RInt_unique _ _ _ _ adP).
    change (Rabs (RInt f b d + - RInt f a c) < eps).
    rewrite <- (RInt_Chasles f b c d), <- (RInt_Chasles f a b c),
      Ropp_plus_distr, !Rplus_assoc, (Rplus_comm (RInt f b c)), !Rplus_assoc,
      Rplus_opp_l, Rplus_0_r; try tauto.
    apply Rle_lt_trans with (1 := Rabs_triang _ _);
       rewrite -> Rabs_Ropp, !Rabs_right;
    try (apply Rle_ge, RInt_ge_0; try tauto);
(* the following fragment duplicated several times. *)
        try (intros x [x1 x2]; enough (0 <= f x <= g x)
           by (solve[tauto | apply Rle_trans with (f x); tauto]);
           apply (cmp a d); try tauto; split;
           solve[repeat (auto; chain_comparisons)]).
    replace (pos eps) with (pos_div_2 eps + pos_div_2 eps)
             by (simpl; field).
    assert (dc : RInt f c d <= RInt g c d /\ RInt f a b <= RInt g a b).
      split; apply RInt_le; try tauto;
(* the following fragment duplicated several times. *)
        try (intros x [x1 x2]; enough (0 <= f x <= g x)
           by (solve[tauto | apply Rle_trans with (f x); tauto]);
           apply (cmp a d); try tauto; split;
           solve[repeat (auto; chain_comparisons)]).
    apply Rle_lt_trans with (1 := Rplus_le_compat _ _ _ _ (proj1 dc)(proj2 dc)).
    apply Rle_lt_trans with (1 := Rle_abs _).
    replace (RInt _ _ _ + _) with
      ((RInt g a d - gl) - (RInt g b c - gl)) by (*TODO : explain this! *)
    (rewrite <- (RInt_Chasles g a b d), <- (RInt_Chasles g b c d);
            try tauto; set (zoo := plus); change zoo with Rplus; ring).
    apply Rle_lt_trans with (1 := Rabs_triang _ _), Rplus_lt_compat.
      destruct (main a d) as [gad [adP adQ]]; try tauto; simpl in adP.
      now rewrite -> (is_RInt_unique _ _ _ _ adP).
    now rewrite -> Rabs_Ropp; rewrite -> (is_RInt_unique _ _ _ _ bcP).
  destruct (Rlt_dec x u), (Rlt_dec v y);
   [apply (wlog_cc x u v y) | apply (wlog_cc x u y v) |
    apply ball_sym, (wlog_cc u x v y) | apply ball_sym, (wlog_cc u x y v)];
    try split;
    try solve[tauto | apply Rlt_le; tauto |
      apply Rge_le; tauto | apply Rle_ge; tauto|
      apply Rnot_lt_le; tauto].
intros P [eps Peps].
move cc after Peps.
unfold filtermapi.
assert (tmp := complete_cauchy _ _ cc eps).
destruct tmp as [Q2 R2 Q2P R2P PP2].
exists (fun x => Q2 x /\ Q1 x) (fun x => R2 x /\ R1 x);
  try (apply filter_and; auto).
intros x y [Q2x Q1x] [R2x R1x].
destruct (cmp x y Q1x R1x) as [cmp' [fxy intxy]].
exists fxy; split;[assumption | apply Peps].
rewrite <- (is_RInt_unique _ _ _ _ intxy); apply PP2; auto.
Qed.

Lemma is_RInt_gen_Rle (g : R -> R) gl (f : R -> R) fl F G
  {PF : ProperFilter F} {PG : ProperFilter G} :
  filter_Rlt F G ->
  is_RInt_gen g F G gl ->
  is_RInt_gen f F G fl ->
  filter_prod F G
    (fun p => (forall x, fst p < x < snd p -> f x <= g x)) ->
    fl <= gl.
Proof.
intros [m mmid] intg intf cmp.
apply (filterlim_le (F := filter_prod F G) (fun p => RInt f (fst p) (snd p))
          (fun p => RInt g (fst p) (snd p)) fl gl).
    specialize (intf _ (locally_ball fl (mkposreal _ Rlt_0_1))).
    specialize (intg _ (locally_ball gl (mkposreal _ Rlt_0_1))).
    unfold filtermapi in intg, intf.
    apply: filter_imp (filter_and _ _ (filter_and _ _ intg intf)
                          (filter_and _ _ mmid cmp)).
    intros [a b]; simpl; intros [[[Ig [Hg1 Hg2]] [If [Hf1 Hf2]]] [cmp']].
    apply RInt_le;
      [apply Rle_trans with m;apply Rlt_le | exists If| exists Ig| ]; tauto.
  intros P HP; specialize (intf P HP); unfold filtermapi, filtermap in intf |- *.
  apply: filter_imp intf.
  intros [a b]; simpl; intros [y [inty Py]].
  now  rewrite -> (is_RInt_unique _ _ _ _ inty).
intros P HP; specialize (intg P HP); unfold filtermapi, filtermap in intg |- *.
apply: filter_imp intg.
intros [a b]; simpl; intros [y [inty Py]].
now  rewrite -> (is_RInt_unique _ _ _ _ inty).
Qed.

Lemma is_RInt_gen_at_point_at_right (f : R -> R) (a : R) F {FF : ProperFilter F}
  v : locally a (continuous f) -> is_RInt_gen f (at_point a) F v ->
  filter_Rlt (at_point a) F ->  is_RInt_gen f (at_right a) F v.
Proof.
intros [delta1 pd1] intf [m [P Q FP FQ cmp]]; simpl in cmp.
destruct (pd1 a (ball_center a delta1)
          (ball (f a) (mkposreal _ Rlt_0_1)) (locally_ball _ _)) as
    [delta2 Pd2].
assert (pa : P a) by (apply FP; intros; apply ball_center).
assert (intf2 := intf).
intros P2 PP2; specialize (intf P2 PP2); destruct PP2 as [eps P2eps].
set (M := Rabs (f a) + 1).
assert (M0 : 0 < eps / M).
  apply Rmult_lt_0_compat;[apply cond_pos | apply Rinv_0_lt_compat].
  now assert (0 <= Rabs (f a)) by apply Rabs_pos; unfold M; fourier.
assert (close : forall y, y <> a -> ball a delta2 y -> Rabs (f y) < M).
  intros y ay b_y; unfold M.
  replace (f y) with (f a + (f y - f a)) by ring.
  apply Rle_lt_trans with (1 := Rabs_triang _ _).
  now apply Rplus_lt_compat_l, Pd2; auto.
assert (exrint_close : forall a', ball a delta1 a' -> ex_RInt f a a').
  intros a' baa'.
  apply (ex_RInt_continuous f); intros z pz; apply pd1.
  destruct (Rle_dec a a') as [aa' | a'a].
    rewrite -> Rmin_left, Rmax_right in pz; auto.
    change (Rabs (z - a) < delta1).
    rewrite -> Rabs_right; cycle 1.
      destruct pz; fourier.
    destruct pz; apply Rle_lt_trans with (a' - a); try fourier.
    rewrite <- (Rabs_right (a' - a)); try fourier.
    tauto.
  change (Rabs (z - a) < delta1).
  destruct (Rle_dec a z) as [az | za].
    apply Rnot_le_lt in a'a.
    rewrite -> Rmin_right, Rmax_left in pz; try (destruct pz; fourier).
    assert (za' : z = a).
      now apply Rle_antisym; (destruct pz; fourier).
    now rewrite -> za', Rminus_eq_0, Rabs_R0; case delta1; tauto.
  apply Rnot_le_lt in a'a; apply Rnot_le_lt in za.
  rewrite -> Rmin_right, Rmax_left in pz; try fourier.
  rewrite -> Rabs_left;[ | fourier].
  apply Rle_lt_trans with (a - a'); try (intuition fourier).
  rewrite <- (Rabs_right (a - a')); try (intuition fourier).
  now change (ball a' delta1 a); apply ball_sym; tauto.
assert (pre_ep2 : 0 < eps / 2 * /M).
  repeat apply Rmult_lt_0_compat; try fourier;[destruct eps; tauto | ].
  now apply Rinv_0_lt_compat; unfold M; assert (t := Rabs_pos (f a)); fourier.
set (ep2 := mkposreal _ pre_ep2).
assert (at_right a (fun x => ball a delta1 x /\ ball a ep2 x /\
                             ball a delta2 x /\ a < x /\ x < m)).
  repeat apply filter_and; try (now apply filter_le_within, locally_ball).
    now exists ep2; intros; tauto.
  destruct (filter_ex _ FQ) as [y' Py'].
  assert (ma0 : 0 < m - a).
    now destruct (cmp a y'); auto; fourier.
  exists (mkposreal _ ma0); simpl; intros y.
  intros bay ay; change (Rabs (y - a) < m - a) in bay.
  now rewrite -> Rabs_right in bay; fourier.
specialize (intf2 _ (locally_ball v (pos_div_2 eps))).
destruct intf2 as [Pl Ql FPl FQl closerint].
assert (pla : Pl a) by (apply FPl; intros; apply ball_center).
assert (F (fun y => Q y /\ Ql y)) by (apply filter_and; auto).
exists (fun x => ball a delta1 x /\ ball a ep2 x /\
                 ball a delta2 x /\ a < x /\ x < m)
       (fun y => Q y /\ Ql y); auto.
intros x y bx Ry; exists (RInt f x y).
destruct (closerint a y) as [fay [close_fay]]; try tauto.
split.
  simpl. apply (RInt_correct f x y).
  apply (ex_RInt_Chasles_2 f a);[ | exists fay; tauto].
  split; apply Rlt_le;
    [| apply Rlt_trans with m; assert (t := cmp a y pa (proj1 Ry))]; tauto.
apply P2eps.
assert (Rabs (RInt f a x) < pos_div_2 eps).
  apply Rle_lt_trans with ((x - a) * M).
    apply abs_RInt_le_const;[apply Rlt_le; tauto | | ].
      now apply exrint_close; tauto.
    intros t atx.
    replace (f t) with (f a + (f t - f a)) by ring.
    apply Rle_trans with (1 := Rabs_triang _ _).
    apply Rplus_le_compat;[apply Rle_refl | ].
    apply Rlt_le, (Pd2 t).
    change (Rabs (t - a) < delta2); rewrite -> Rabs_right;[ | intuition fourier].
    apply Rle_lt_trans with (x - a);[intuition fourier | ].
    now rewrite <- (Rabs_right (x - a));[tauto | intuition fourier].
  replace (pos (pos_div_2 eps)) with (ep2 * M).
    rewrite <- (Rabs_right (x - a));[|intuition fourier].
    apply Rmult_lt_compat_r;[unfold M  | tauto].
    now assert (t := Rabs_pos (f a)); fourier.
  simpl; field; unfold M; apply Rgt_not_eq; assert (t := Rabs_pos (f a)).
  now fourier.
replace (pos eps) with (pos_div_2 eps + pos_div_2 eps) by (simpl; field).
apply ball_triangle with (RInt f a y); cycle 1.
  change (Rabs (RInt f x y - RInt f a y) < pos_div_2 eps).
  replace (RInt f a y) with (RInt f a x + RInt f x y); cycle 1.
  apply (RInt_Chasles f).
      now apply exrint_close; tauto.
    apply (ex_RInt_Chasles_2 f a).
      split;[apply Rlt_le; tauto | apply Rlt_le, Rlt_trans with m; try tauto].
    now destruct (cmp a y); tauto.
  now exists fay.
  match goal with |- Rabs ?v < _ => replace v with (-RInt f a x) by ring end.
  now rewrite -> Rabs_Ropp.
now rewrite -> (is_RInt_unique f a y fay).
Qed.

Lemma is_RInt_gen_at_point_at_left (f : R -> R) (a : R) F {FF : ProperFilter F}
  v : locally a (continuous f) -> is_RInt_gen f F (at_point a) v ->
  filter_Rlt F (at_point a) ->  is_RInt_gen f F (at_left a) v.
Proof.
intros [delta1 pd1] intf [m [P Q FP FQ cmp]]; simpl in cmp.
destruct (pd1 a (ball_center a delta1)
          (ball (f a) (mkposreal _ Rlt_0_1)) (locally_ball _ _)) as
    [delta2 Pd2].
assert (qa : Q a) by (apply FQ; intros; apply ball_center).
assert (intf2 := intf).
intros P2 PP2; specialize (intf P2 PP2); destruct PP2 as [eps P2eps].
set (M := Rabs (f a) + 1).
assert (M0 : 0 < eps / M).
  apply Rmult_lt_0_compat;[apply cond_pos | apply Rinv_0_lt_compat].
  now assert (0 <= Rabs (f a)) by apply Rabs_pos; unfold M; fourier.
assert (close : forall y, y <> a -> ball a delta2 y -> Rabs (f y) < M).
  intros y ay b_y; unfold M.
  replace (f y) with (f a + (f y - f a)) by ring.
  apply Rle_lt_trans with (1 := Rabs_triang _ _).
  now apply Rplus_lt_compat_l, Pd2; auto.
assert (exrint_close : forall a', ball a delta1 a' -> ex_RInt f a' a).
  intros a' baa'.
  apply (ex_RInt_continuous f); intros z pz; apply pd1.
  destruct (Rle_dec a a') as [aa' | a'a].
    rewrite -> Rmin_right, Rmax_left in pz; auto.
    change (Rabs (z - a) < delta1).
    rewrite -> Rabs_right; cycle 1.
      destruct pz; fourier.
    destruct pz; apply Rle_lt_trans with (a' - a); try fourier.
    rewrite <- (Rabs_right (a' - a)); try fourier.
    tauto.
  change (Rabs (z - a) < delta1).
  destruct (Rle_dec a z) as [az | za].
    apply Rnot_le_lt in a'a.
    rewrite -> Rmin_left, Rmax_right in pz; try (destruct pz; fourier).
    assert (za' : z = a).
      now apply Rle_antisym; (destruct pz; fourier).
    now rewrite -> za', Rminus_eq_0, Rabs_R0; case delta1; tauto.
  apply Rnot_le_lt in a'a; apply Rnot_le_lt in za.
  rewrite -> Rmin_left, Rmax_right in pz; try fourier.
  rewrite -> Rabs_left;[ | fourier].
  apply Rle_lt_trans with (a - a'); try (intuition fourier).
  rewrite <- (Rabs_right (a - a')); try (intuition fourier).
  now change (ball a' delta1 a); apply ball_sym; tauto.
assert (pre_ep2 : 0 < eps / 2 * /M).
  repeat apply Rmult_lt_0_compat; try fourier;[destruct eps; tauto | ].
  now apply Rinv_0_lt_compat; unfold M; assert (t := Rabs_pos (f a)); fourier.
set (ep2 := mkposreal _ pre_ep2).
assert (at_left a (fun x => ball a delta1 x /\ ball a ep2 x /\
                             ball a delta2 x /\ m < x /\ x < a)).
  repeat apply filter_and; try (now apply filter_le_within, locally_ball).
    destruct (filter_ex _ FP) as [y' Py'].
    assert (ma0 : 0 < a - m).
      now destruct (cmp y' a); auto; fourier.
    exists (mkposreal _ ma0); simpl; intros y.
    now rewrite ball_Rabs; intros bay ay; rewrite Rabs_left in bay; fourier.
  now exists ep2; intros; tauto.
specialize (intf2 _ (locally_ball v (pos_div_2 eps))).
destruct intf2 as [Pl Ql FPl FQl closerint].
assert (pla : Ql a) by (apply FQl; intros; apply ball_center).
assert (F (fun y => P y /\ Pl y)) by (apply filter_and; auto).
exists (fun y => P y /\ Pl y)
       (fun x => ball a delta1 x /\ ball a ep2 x /\
                 ball a delta2 x /\ m < x /\ x < a); auto.
intros x y bx Ry; exists (RInt f x y).
destruct (closerint x a) as [fxa [close_fxa]]; try tauto.
split.
  simpl. apply (RInt_correct f x y).
  apply (ex_RInt_Chasles_1 f _ _ a);[ | exists fxa; tauto].
  split; apply Rlt_le;
    [apply Rlt_trans with m; assert (t := cmp x a (proj1 bx) qa) |]; tauto.
apply P2eps.
assert (Rabs (RInt f y a) < pos_div_2 eps).
  apply Rle_lt_trans with ((a - y) * M).
    apply abs_RInt_le_const;[apply Rlt_le; tauto | | ].
      now apply exrint_close; tauto.
    intros t yta.
    replace (f t) with (f a + (f t - f a)) by ring.
    apply Rle_trans with (1 := Rabs_triang _ _).
    apply Rplus_le_compat;[apply Rle_refl | ].
    apply Rlt_le, (Pd2 t).
    change (Rabs (t - a) < delta2); rewrite -> Rabs_left1;[ |intuition fourier].
    apply Rle_lt_trans with (a - y);[intuition fourier | ].
    rewrite <- (Rabs_right (a - y));[ | intuition fourier].
    now rewrite <- Rabs_Ropp, Ropp_minus_distr; tauto.
  replace (pos (pos_div_2 eps)) with (ep2 * M).
    rewrite <- (Rabs_right (a - y));[|intuition fourier].
    apply Rmult_lt_compat_r;[unfold M  |].
      now assert (t := Rabs_pos (f a)); fourier.
    now rewrite <- Rabs_Ropp, Ropp_minus_distr; tauto.
  simpl; field; unfold M; apply Rgt_not_eq; assert (t := Rabs_pos (f a)).
  now fourier.
replace (pos eps) with (pos_div_2 eps + pos_div_2 eps) by (simpl; field).
apply ball_triangle with (RInt f x a); cycle 1.
  change (Rabs (RInt f x y - RInt f x a) < pos_div_2 eps).
  replace (RInt f x a) with (RInt f x y + RInt f y a); cycle 1.
  apply (RInt_Chasles f).
      apply (ex_RInt_Chasles_1 f _ _ a).
      split;[ apply Rlt_le, Rlt_trans with m; try tauto| apply Rlt_le; tauto].
        now destruct (cmp x a); tauto.
      now exists fxa.
    now apply exrint_close; tauto.
  match goal with |- Rabs ?v < _ => replace v with (-RInt f y a) by ring end.
  now rewrite -> Rabs_Ropp.
now rewrite -> (is_RInt_unique f x a fxa).
Qed.

Lemma ex_RInt_gen_cut (a : R) (F G: (R -> Prop) -> Prop)
   {FF : ProperFilter F} {FG : ProperFilter G} (f : R -> R) :
   filter_Rlt F (at_point a) -> filter_Rlt (at_point a) G ->
   ex_RInt_gen f F G -> ex_RInt_gen f (at_point a) G.
Proof.
intros lFa laG [vfg Pvfg].
assert (lFG := filter_Rlt_trans _ _ _ lFa laG).
set (v := R_complete_lim (filtermap (fun x => RInt f a x) G)).
exists v; intros P PP2.
destruct laG as [m [S1 S2 p1 p2 laG]]; cbn in laG.
destruct lFa as [m' [S5 S6 p5 p6 lFa]]; cbn in lFa.
assert (S6 a) by apply p6.
assert (S1 a) by apply p1.
assert (t': forall eps : posreal, exists x,
         filtermap (fun x => RInt f a x) G (ball x eps)).
  intros eps.
  specialize (Pvfg (ball vfg (pos_div_2 eps)) (locally_ball _ _)).
  destruct Pvfg as [S7 S8 p7 p8 vfg'].
  destruct (filter_ex (F := G)
                (fun y => S8 y /\ S2 y)) as [y Py].
    repeat apply filter_and; tauto.
  exists (RInt f a y); destruct (filter_ex (F := F)
                        (fun x => S7 x /\ S5 x)) as [x Px].
    repeat apply filter_and; tauto.
  unfold filtermap; apply (filter_imp (fun y => S8 y /\ S2 y)).
  intros z PZ; change (Rabs (RInt f a z - RInt f a y) < eps).
  replace (RInt f a z - RInt f a y) with
          ((RInt f x a + RInt f a z) - (RInt f x a + RInt f a y)) by ring.
    destruct (vfg' x y) as [xy pxy]; try tauto.
    destruct (vfg' x z) as [xz pxz]; try tauto.
    assert (ex_RInt f x y) by (exists xy; tauto).
    assert (ex_RInt f x z) by (exists xz; tauto).
    assert (x < a) by (destruct (lFa x a); intuition fourier || tauto).
    assert (a < y) by (destruct (laG a y); intuition fourier || tauto).
    assert (a < z) by (destruct (laG a z); intuition fourier || tauto).
    assert (ex_RInt f x a).
      apply (ex_RInt_Chasles_1 f x a y);[intuition fourier | assumption].
    rewrite -> !(RInt_Chasles f); auto;
       try (apply (ex_RInt_Chasles_2 f x); auto; intuition fourier); cycle 1.
    change (ball (RInt f x y) eps (RInt f x z)).
    replace (pos eps) with (pos_div_2 eps + pos_div_2 eps) by (simpl; field).
    replace (RInt f x y) with xy by (symmetry; apply is_RInt_unique; tauto).
    replace (RInt f x z) with xz by (symmetry; apply is_RInt_unique; tauto).
    now apply (ball_triangle _ vfg); [apply ball_sym | ]; tauto.
  now repeat apply filter_and; tauto.
destruct PP2 as [eps Peps].
assert (t := (R_complete
            (filtermap (fun x => RInt f a x) G) _
            t' eps)).
unfold filtermap, filtermapi in t |- *.
assert (atpa : at_point a (eq a)) by reflexivity.
enough (H1 : exists S4, G S4 /\ forall x, S4 x -> is_RInt f a x (RInt f a x)).
  destruct H1 as [S4 [gs4 Ps4]].
  apply (Filter_prod (at_point a) G _ (eq a)
           (fun x => ball
             (R_complete_lim
                (fun P : R -> Prop => G (fun x0 => P (RInt f a x0)))) eps
           (RInt f a x) /\ S4 x) atpa (filter_and _ _ t gs4)).
  intros x y <- dist.
  now exists (RInt f a y);split;[apply Ps4; tauto| apply Peps; tauto].
destruct (Pvfg (ball vfg (mkposreal _ Rlt_0_1))) as [S3 S4 fs3 gs4 Ps4].
  now apply locally_ball.
assert (F (Rgt a)).
  apply (filter_imp S5); [intros x s5x | auto].
  assert (s6a : S6 a) by apply p6.
  destruct (lFa x a s5x s6a); fourier.
destruct (filter_ex (F := F) (fun x => a > x /\ S3 x)) as [w Pw];
  [apply filter_and; auto | ].
exists (fun x => S4 x /\ a < x); split;[ | intros x px; apply (RInt_correct f)].
  apply filter_and;[assumption | apply (filter_imp S2);[intros x s2x | easy]].
  assert (s1a : S1 a) by apply p1.
  destruct (laG a x s1a s2x); fourier.
apply ex_RInt_Chasles_2 with w;[split; apply Rlt_le; tauto | ].
destruct (Ps4 w x) as [wx [Pwx closewx]]; try tauto; exists wx; tauto.
Qed.


Require Import Lists.List.
Require Import Program.Basics.

Require Import Top.FinSet.FinMod.
Require Import Top.FinSet.FinModComp.
Require Import Top.FinSet.FinSet.
Require Import Top.FinSet.FPCard.
Require Import Top.FinSet.NatMap.
Require Import Top.FinSet.ProjSet.
Require Import Top.Terms.Term.
Require Import Top.Terms.Subst.

Set Implicit Arguments.

(** To represent a substitution that maps variables to variables, we
    define a [var_subst] to be a finite endomorphism on V. Composing
    on the left with [varTerm] gives the substitution itself. *)

Section var_subst.
  Definition is_var_subst {V} (s : V -> V) := fin_endo s.
  Definition var_subst V := sigT (is_var_subst (V := V)).

  Variable L : lType.
  Notation V := (Term.V L).

  Definition var_subst_subst (s : var_subst V) : V -> Term L :=
    let (s', _) := s in compose (varTerm L) s'.

  Hypothesis decV : forall x y : V, {x = y} + { ~ x = y }.
  Hypothesis decF : forall x y : Lmodule.F L, {x = y} + { ~ x = y }.

  (** Since we're generally interested in finite substitutions, we
      would hope that a [var_subst] induces one, and it does. *)

  Lemma var_subst_is_fin_subst (s : var_subst V)
    : is_fin_subst L (var_subst_subst s).
  Proof.
    destruct s as [ s finH ].
    unfold var_subst_subst; simpl.
    eapply (compose_fin_mod decV decV (decTerm decV decF) _ _
                            finH
                            (fin_mod_i (varTerm L))).
    Unshelve.
    - destruct 1 as [ x eltH ]; contradiction eltH; auto.
    - intro d; destruct d as [ x eltH ]; contradiction eltH; auto.
  Qed.

  Definition var_subst_to_fin_subst : var_subst V -> fin_subst L :=
    fun s => existT _ (var_subst_subst s) (var_subst_is_fin_subst s).

  Lemma var_subst_subst_fin_subst s
    : fin_subst_subst L (var_subst_to_fin_subst s) =
      var_subst_subst s.
  Proof.
    auto.
  Qed.

  Lemma is_var_subst_compose (t s : V -> V)
    : is_var_subst t -> is_var_subst s -> is_var_subst (compose t s).
  Proof.
    apply (compose_fin_endo decV).
  Qed.

  Definition compose_var_subst (t s : var_subst V) : var_subst V :=
    let (ft, tH) := t in
    let (fs, sH) := s in
    existT _ (compose ft fs) (is_var_subst_compose tH sH).

End var_subst.

(** We're particularly interested in permutations, defined to be
    bijective variable substitutions. Since "bijective" is a little
    bit difficult to pin down in Coq, we'll ask that there is an
    "extensionally inverse" map. That is, the maps should compose to a
    map that equals the identity on every input. *)

Definition ext_inverse {A B : Type} (f : A -> B) (g : B -> A) :=
  (forall a, g (f a) = a) /\ (forall b, f (g b) = b).

Lemma ext_inverse_sym (A B : Type) (f : A -> B) (g : B -> A)
  : ext_inverse f g -> ext_inverse g f.
Proof.
  unfold ext_inverse; destruct 1; auto.
Qed.

(** In a minute, we're going to construct an inverse to a finite
    endomorphism, using [inj_endo_is_invertible]. That takes a little
    bit of tidying up, though, because we'll only get the inverse on
    the domain of the original endomorphism.

    Here, we show that we can extend the inverse map in a finitary
    way, provided that [a <> f a] implies that [f a <> f (f a)] (a
    fact which is implied by injectivity of [f]). *)

Section extend_inverse.
  Variables A : Type.
  Variable f g : A -> A.

  Hypothesis fH : fin_mod id f.
  Hypothesis decA : forall a a' : A, {a = a'} + {a <> a'}.

  Hypothesis gfH :
    forall d : mod_dom id f, g (f (proj1_sig d)) = proj1_sig d.
  Hypothesis fgH :
    forall d : mod_dom id f, f (g (proj1_sig d)) = proj1_sig d.

  Hypothesis f_preserves_dom :
    forall a : A, f a <> a -> f (f a) <> f a.

  Local Definition clamp_g (a : A) : A := if decA (f a) a then a else g a.

  Local Lemma mod_f_imp_mod_clamp_g a (H : mod_elt id f a)
    : mod_elt id clamp_g a.
  Proof.
    specialize (fgH (exist _ a H)). simpl in fgH.
    unfold mod_elt, id, clamp_g in *.
    destruct (decA (f a) a); congruence.
  Qed.

  Local Definition cast_clamp_g (d : mod_dom id f) : mod_dom id clamp_g :=
    let (a, H) := d in exist _ a (mod_f_imp_mod_clamp_g H).

  Local Lemma fin_clamp_g : fin_mod id clamp_g.
  Proof.
    destruct fH as [ l fullH ].
    exists (map cast_clamp_g l).
    intro d; destruct d as [ a aH ]; simpl.
    unfold mod_elt in aH.
    assert (fneH : f a <> id a).
    - unfold clamp_g in aH; destruct (decA (f a) a); auto.
    - apply in_map_iff.
      specialize (fullH (exist _ a fneH));
        unfold InProj in fullH; simpl in fullH.
      rewrite in_map_iff in fullH.
      destruct fullH as [ d dH ]; destruct dH as [ adH inH ].
      exists (cast_clamp_g d).
      constructor.
      + destruct d; tauto.
      + apply in_map; auto.
  Qed.

  Local Lemma gf_id_eq a
    : a = f a -> clamp_g (f a) = a.
  Proof.
    unfold clamp_g.
    intro eqH; rewrite <- !eqH; destruct (decA a a); tauto.
  Qed.

  Local Lemma gf_id_ne a
    : a <> f a -> clamp_g (f a) = a.
  Proof.
    intro neH; unfold clamp_g.
    specialize (gfH (exist _ a (not_eq_sym neH))); simpl in gfH.
    specialize (f_preserves_dom (not_eq_sym neH)).
    case (decA (f (f a)) (f a)); congruence.
  Qed.

  Local Lemma fg_id_eq a
    : a = f a -> f (clamp_g a) = a.
  Proof.
    unfold clamp_g; intro eqH; rewrite <- eqH; destruct (decA a a); congruence.
  Qed.

  Local Lemma fg_id_ne a
    : a <> f a -> f (clamp_g a) = a.
  Proof.
    intro neH; unfold clamp_g.
    destruct (decA (f a) a); auto.
    specialize (fgH (exist _ a (not_eq_sym neH))); simpl in fgH.
    auto.
  Qed.

  Lemma ext_inverse_clamp_g : ext_inverse f clamp_g.
  Proof.
    constructor; intro a;
      destruct (decA (f a) a);
      auto using gf_id_eq, gf_id_ne, fg_id_eq, fg_id_ne.
  Qed.

End extend_inverse.

(** Now we try to prove Eder's Lemma 2.6, which says that every
    injective var substitution is a permutation.

    To do so, we follow his proof and lift the substitution to a map
    from its domain to itself. Most of the logic should be
    unsurprising. The work to extend the inverse from the domain [D]
    to [V] was basically done in the [extended_inverse] section above.

    The one not-so-obvious thing is the [maybe_id] hypothesis. The
    problem is that [inj_endo_is_invertible] needs some element of [D]
    to map uninteresting elements to. Of course, if [s] is the
    identity substitution then [D] is empty and this won't work! *)

Section inj_subst.
  Variable V : Type.
  Variable s : var_subst V.

  Definition var_subst_inj : Prop :=
    let (fs, _) := s in
    forall v w : V, fs v = fs w -> v = w.

  Hypothesis injH : var_subst_inj.

  Local Definition fs : V -> V := let (s', _) := s in s'.

  Local Lemma substH : is_var_subst fs.
  Proof.
    unfold fs; destruct s; auto.
  Qed.

  Local Lemma fs_inj : forall v w : V, fs v = fs w -> v = w.
  Proof.
    unfold var_subst_inj, fs in *; destruct s; auto.
  Qed.

  (** We'll define [D] to be the domain of [s] *)
  Local Definition D : Type := mod_dom id fs.

  (** The first part of the argument in the paper explains why a
      variable [v] in the domain must be mapped to another element of
      the domain. The point is that otherwise [f (f v) = f v] and
      injectivity would then imply that [f v = v], contradicting the
      fact that [v] was in the domain. *)

  Local Lemma f_maps_into_dom v : fs v <> v -> fs (fs v) <> fs v.
  Proof.
    unfold var_subst_inj, fs in *.
    destruct s as [ fs H ].
    intuition.
  Qed.

  Local Lemma maps_into_dom {v}
    : mod_elt id fs v -> mod_elt id fs (fs v).
  Proof.
    unfold mod_elt, id; apply f_maps_into_dom.
  Qed.

  (** Knowing this we can construct a natural map, where the top map
      is [D -> D] and the bottom map is [f : V -> V]. We'll name the
      vertical maps at either side as [proj] *)

  Local Definition proj : D -> V := md_elt.

  Local Definition finite_proj : FiniteProj proj := substH.

  Local Definition top_map : D -> D :=
    fun d => let (v, eltH) := d in exist _ (fs v) (maps_into_dom eltH).

  Local Lemma top_map_natural
    : is_nat_map proj proj (top_map, fs).
  Proof.
    intro d; destruct d as [ v H ]; auto.
  Qed.

  Local Definition nmap : nat_map proj proj :=
    exist _ (top_map, fs) top_map_natural.

  (** The injectivity lemma, [injH], then implies that [nmap] is an
      [inj_nat_map]. *)

  Local Lemma inj_nmap : inj_nat_map nmap.
  Proof.
    intros d0 d1; unfold nmap, proj; auto using fs_inj.
  Qed.

  (** With decidability on [V], we can strengthen [maps_into_dom]
      significantly. *)

  Hypothesis decV : forall x y : V, {x = y} + { ~ x = y }.

  Local Lemma idem_iff_ident {v}
    : fs (fs v) = fs v <-> fs v = v.
  Proof.
    split; try congruence.
    destruct (decV (fs v) v); auto using fs_inj.
  Qed.

  Local Definition lift_non_idem (v : V) (neH : fs (fs v) <> fs v) : D.
  refine (exist _ v _).
  unfold id.
  intro eqH.
  rewrite <- idem_iff_ident in eqH.
  auto.
  Defined.

  (** Because [s] is a [var_subst], in particular it is finite
      modification of the identity. But that means that we can use
      [decV] to find a value on which [s] isn't the identity. *)
  Definition dec_id : D + (forall v, fs v = v).
    destruct substH as [ ds fullH ].
    destruct ds as [ | d ds' ].
    - right; apply (empty_mod_elim decV id fs fullH).
    - left; exact d.
  Defined.

  (** If s happens to be the identity, this was all a bit pointless:
      we can't use [inj_endo_is_invertible] to produce the inverse
      map, because we have no element of [D]. But, of course, if [s]
      is the identity, it's pretty easy to find an inverse! *)
  Lemma ext_inverse_id
    : (forall v, fs v = v) -> ext_inverse fs fs.
  Proof.
    intro svH; split; intros; rewrite !svH; auto.
  Qed.

  (* If [s] isn't the identity, there's at least one [v] where [s v <>
     v], giving us an element of [D]. Give a name to the [nat_map]
     from whose base we can extract the inverse. *)
  Local Definition inv_nmap (d : D) : nat_map proj proj :=
    inj_endo_inv inj_nmap decV substH d (proj2_sig substH).

  Definition inj_subst_inv_fun : V -> V :=
    match dec_id with
    | inl d => clamp_g fs (nm_bot (inv_nmap d)) decV
    | inr idH => fs
    end.

  Lemma ext_inverse_inj_subst : ext_inverse fs inj_subst_inv_fun.
  Proof.
    unfold inj_subst_inv_fun; destruct dec_id as [ d | idH ].
    - apply ext_inverse_clamp_g.
      + apply (inj_endo_is_invertible inj_nmap _ _ d).
      + apply (inj_endo_is_invertible inj_nmap _ _ d).
      + intros v neH eqH. rewrite idem_iff_ident in eqH; auto.
    - apply (ext_inverse_id idH).
  Qed.

  Lemma is_var_subst_inj_subst_inv : is_var_subst inj_subst_inv_fun.
  Proof.
    unfold inj_subst_inv_fun; destruct dec_id as [ d | ]; auto.
    apply fin_clamp_g; auto.
    - unfold fs; destruct s; auto.
    - intro d'; apply (inj_endo_is_invertible inj_nmap _ _ d).
    - unfold fs; destruct s; auto.
  Qed.

  Definition inj_subst_inv : var_subst V :=
    existT _ inj_subst_inv_fun is_var_subst_inj_subst_inv.

End inj_subst.

Hint Rewrite var_subst_subst_fin_subst : var_subst.


Require Import Coq.Sets.Ensembles.
Require Import Coq.Classes.Morphisms.
Require Import Logic.lib.Ensembles_ext.
Require Import Coq.Lists.List.

Section Properties.

Context {A: Type}.

Definition finite_captured (P: Ensemble A -> Prop): Prop :=
  forall (Phi: Ensemble A),
    (forall xs: list A, Forall Phi xs -> P (fun x => In x xs)) ->
      P Phi.

Definition finite_witnessed (P: Ensemble A -> Prop): Prop :=
  forall (Phi: Ensemble A), P Phi ->
    exists xs: list A, Forall Phi xs /\ P (fun x => In x xs).

Definition subset_preserved (P: Ensemble A -> Prop): Prop :=
  forall (Phi Psi: Ensemble A),
    Included _ Phi Psi -> P Psi -> P Phi.

Definition superset_preserved (P: Ensemble A -> Prop): Prop :=
  forall (Phi Psi: Ensemble A),
    Included _ Phi Psi -> P Phi -> P Psi.

Lemma not_finite_witnessed_finite_captured: forall P,
  finite_witnessed P ->
  finite_captured (fun X => ~ P X).
Proof.
  intros.
  hnf in H |- *.
  intros.
  intro.
  specialize (H Phi H1).
  firstorder.
Qed.

Lemma not_superset_preserved_subset_preserved: forall P,
  superset_preserved P ->
  subset_preserved (fun X => ~ P X).
Proof.
  intros.
  hnf in H |- *.
  firstorder.
Qed.

Lemma superset_preserved_same_set_preserved: forall P,
  superset_preserved P ->
  Proper (Same_set _ ==> iff) P.
Proof.
  intros.
  hnf; intros.
  rewrite Same_set_spec in H0.
  split; apply H.
  + unfold Included, Ensembles.In.
    hnf in H0.
    firstorder.
  + unfold Included, Ensembles.In.
    hnf in H0.
    firstorder.
Qed.

Lemma subset_preserved_same_set_preserved: forall P,
  subset_preserved P ->
  Proper (Same_set _ ==> iff) P.
Proof.
  intros.
  hnf; intros.
  rewrite Same_set_spec in H0.
  split; apply H.
  + unfold Included, Ensembles.In.
    hnf in H0.
    firstorder.
  + unfold Included, Ensembles.In.
    hnf in H0.
    firstorder.
Qed.

End Properties.


Require Import RelationClasses Morphisms Setoid.

From mathcomp Require Import all_ssreflect.

From GraphTheory Require Import edone finite_quotient preliminaries.
From GraphTheory Require Import bij set_tac digraph sgraph minor checkpoint.
From GraphTheory Require Import setoid_bigop structures pttdom mgraph mgraph2.
From GraphTheory Require Import skeleton bounded equiv extraction_def.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

Section ExtractionIso.
Variable sym : Type.
Notation graph := (graph unit (flat sym)).
Notation graph2 := (graph2 unit (flat sym)).

Notation g2_top := (g2_top : graph2).
Notation g2_one := (g2_one : graph2).

(** ** Correctness of the Extraction Function *)

(** In this file we prove correctness of the extraction function. This
mainly amounts to establishing a variety of isomorphisms corresponding
to the way the extraction function decomposes graphs. *)

(* lemmas for recognizing [top] and [one] *)
Lemma iso_top (G : graph2) :
  input != output :> G ->
  (forall x : G, x \in IO) ->
  (forall e : edge G, False) -> G ≃2 top.
Proof.
  move => Dio A B.
  pose f (x : G) : g2_top :=
    if x == input then input else output.
  pose f' (x : g2_top) : G :=
    if x == input then input else output.
  pose g (e : edge G) : edge g2_top :=
    match (B e) with end.
  pose g' (e : edge g2_top) : edge G :=
    match e with inl e |inr e => vfun e end.
  unshelve Iso2 (@Iso _ _ _ _ (@Bij _ _ f f' _ _) (@Bij _ _ g g' _ _) xpred0 _)=>/=.
  - rewrite /f/f'/= => x.
    case: (boolP (x == input)) => [/eqP <-|/=]//.
    move: (A x). case/setUP => /set1P => -> //. by rewrite eqxx.
  - rewrite /f/f'/= => x.
    case: (boolP (x == inl tt)) => [/eqP <-|/=]//. by rewrite eqxx.
    case: x => // [[]] _. by rewrite eq_sym (negbTE Dio).
  - by [].
  - by case=>[[]|[]].
  - by split.
  - by rewrite /f  eqxx.
  - by rewrite /f eq_sym (negbTE Dio).
Qed.

Lemma iso_one (G : graph2) :
  input == output :> G ->
  (forall x : G, x \in IO) ->
  (forall e : edge G, False) -> G ≃2 1.
Proof.
  move => Dio A B.
  pose f (x : G) : g2_one := input.
  pose f' (x : g2_one) : G := input.
  pose g (e : edge G) : edge g2_one :=
    match (B e) with end.
  pose g' (e : edge g2_one) : edge G :=
    match e with end.
  unshelve Iso2 (@Iso _ _ _ _ (@Bij _ _ f f' _ _) (@Bij _ _ g g' _ _) xpred0 _)=>/=.
  - rewrite /f/f'/= => x.
    move: (A x). rewrite !inE -(eqP Dio) => /orP. by case => /eqP->.
  - by move => [].
  - by [].
  - by [].
  - by split.
Qed.

Lemma comp_exit (G : graph2) (C : {set G}) :
  connected [set: skeleton G] ->
  input == output :> G -> C \in @components G [set~ input] ->
  exists2 z : skeleton G, z \in C & z -- input.
Proof.
  move=> G_conn Eio C_comp.
  case/and3P: (@partition_components G [set~ input]) => /eqP compU compI comp0.
  have /card_gt0P[a a_C] : 0 < #|C|.
  { rewrite card_gt0. by apply: contraTneq C_comp =>->. }
  have aNi : a \in [set~ input]. { rewrite -compU. by apply/bigcupP; exists C. }
  rewrite -{C C_comp a_C}(def_pblock compI C_comp a_C).
  case/connect_irredP: (connectedTE G_conn a input) => p.
  move: (aNi); rewrite !inE. case/(splitR p) => [z][q][zi] {p}->.
  rewrite irred_cat. case/and3P=> _ _ /eqP/setP/(_ input).
  rewrite !inE eq_sym sg_edgeNeq // andbT => /negbT iNq.
  exists z => //.
  rewrite pblock_equivalence_partition // ?inE ?(sg_edgeNeq zi) //.
  + apply: (connectRI q) => x. rewrite !inE. by apply: contraTneq =>->.
  + exact: sedge_equiv_in.
Qed.

Lemma merge_subgraph_dot (G : graph) (V1 V2 : {set G}) (E1 E2 : {set edge G})
  (con1 : consistent V1 E1) (con2 : consistent V2 E2) i1 i2 o1 o2 :
  val o1 = val i2 -> [disjoint E1 & E2] -> (forall x, x \in V1 -> x \in V2 -> x = val o1) ->
  point (subgraph_for con1) i1 o1 · point (subgraph_for con2) i2 o2 ≃2
  point (subgraph_for (consistentU con1 con2))
        (Sub (val i1) (union_bij_proofL _ (valP i1)))
        (Sub (val o2) (union_bij_proofR _ (valP o2))).
Proof.
  move => Eoi disE12 cap12. rewrite /dot/=/g2_dot.
  set G12 := (point _ _ _ ⊎ point _ _ _)%G.
  have eqvI (x : G) (inV1 : x \in V1) (inV2 : x \in V2)  :
    inl (Sub x inV1) = inr (Sub x inV2) %[mod @eqv_clot G12 [:: (unl output, unr input)]].
  { move: (inV1) (inV2). rewrite (cap12 _ inV1 inV2) {2 4}Eoi /= =>  ? ?.
    rewrite !valK'. apply/eqquotP. exact: eqv_clot_hd. }
  set x0 := Sub (sval i1) (union_bij_proofL V2 (valP i1)).
  rewrite /x0 /G12.
  apply: iso2_comp. apply: (iso_iso2 (merge_subgraph_iso eqvI disE12)).
  rewrite !(merge_subgraph_isoE eqvI disE12 x0).
  rewrite -> merge_nothing. 2: repeat constructor; exact: val_inj.
  apply: (iso_iso2' (h := iso_id)); apply: val_inj => /=; by rewrite val_insubd inE ?(valP i1) ?(valP o2).
Qed.

Lemma merge_subgraph_par (G : graph) (V1 V2 : {set G}) (E1 E2 : {set edge G})
  (con1 : consistent V1 E1) (con2 : consistent V2 E2) (i1 o1 : subgraph_for con1) (i2 o2 : subgraph_for con2) :
  val i2 = val i1 -> val o2 = val o1 ->
  [disjoint E1 & E2] -> (forall x, x \in V1 -> x \in V2 -> x \in [set val i1; val o1]) ->
  point (subgraph_for con1) i1 o1 ∥ point (subgraph_for con2) i2 o2 ≃2
  point (subgraph_for (consistentU con1 con2))
        (Sub (val i1) (union_bij_proofL _ (valP i1)))
        (Sub (val o2) (union_bij_proofR _ (valP o2))).
Proof.
  move => Ei Eo disE12 cap12. rewrite /par/=/g2_par.
  set G12 := (point _ _ _ ⊎ point _ _ _)%G.
  have eqvI (x : G) (inV1 : x \in V1) (inV2 : x \in V2)  :
    inl (Sub x inV1) = inr (Sub x inV2)
      %[mod @eqv_clot G12 [:: (unl input, unr input); (unl output, unr output)]].
  { case/set2P : (cap12 _ inV1 inV2) => ?; subst x; rewrite !valK' !/input !/output.
    rewrite -Ei in inV1 inV2 *. rewrite valK'. apply/eqquotP. by eqv.
    rewrite -Eo in inV1 inV2 *. rewrite valK'. apply/eqquotP. by eqv. }
  set x0 := Sub (sval i1) (union_bij_proofL V2 (valP i1)).
  rewrite /x0 /G12.
  apply: iso2_comp. apply: (iso_iso2 (merge_subgraph_iso eqvI disE12)).
  rewrite !(merge_subgraph_isoE eqvI disE12 x0).
  rewrite -> merge_nothing. 2: repeat constructor; exact: val_inj.
  apply: (iso_iso2' (h := iso_id)); apply: val_inj => /=; by rewrite val_insubd inE ?(valP i1) ?(valP o2).
Qed.

(** These two lemmas make use of [merge_subgraph_dot], drastically
simplifying their proofs (compared to the proofs underlying the ITP
2018 paper) *)

Lemma split_pip (G : graph2) :
  connected [set: skeleton G] -> input != output :> G ->
  G ≃2 @bgraph _ _ G IO input · (@igraph _ _ G input output · @bgraph _ _ G IO output).
Proof.
  move => conn_G Dio. symmetry.
  have [Hi Ho] : input \in @CP (skeleton G) IO /\ output \in @CP (skeleton G) IO
    by split; apply: CP_extensive; rewrite !inE eqxx.
  rewrite-> dot2A. rewrite /= {1}/bgraph /igraph /induced.
  setoid_rewrite merge_subgraph_dot=>//=.
  2: exact: interval_bag_edges_disj.
  2: move => x; exact: (@bag_interval_cap G).
  rewrite /bgraph/induced.
  setoid_rewrite-> merge_subgraph_dot => //=.
  move: (union_bij_proofL _ _) => Pi.
  move: (union_bij_proofR _ _) => Po.
  move: (consistentU _ _) => con1.
  apply iso2_subgraph_forT => //=.
  move => x. move: (sinterval_bag_cover conn_G Dio).
    have: x \in [set: G] by []. rewrite /interval; set_tac.
  move => e. by rewrite -(interval_bag_edge_cover).
  apply: disjointsU. exact: bag_edges_disj.
  rewrite disjoint_sym interval_edges_sym. exact: interval_bag_edges_disj.
  move => x A B. rewrite inE (disjointFl (bag_disj conn_G _ _ Dio)) //= interval_sym in A.
    exact: (@bag_interval_cap G) B A.
Qed.

Lemma split_cp (G : graph2) (u : skeleton G) :
  connected [set: skeleton G] -> u \in @cp G input output :\: IO ->
  edge_set (@bag G IO input) == set0 ->
  edge_set (@bag G IO output) == set0 ->
  G ≃2 @igraph _ _ G input u · (@bgraph _ _ G IO u · @igraph _ _ G u output).
Proof.
  move => conn_G proper_u Ei0 Eo0. symmetry.
  have Dio: input != output :> G.
  { apply: contraTneq proper_u => <-. by rewrite setUid cpxx setDv inE. }
  have [? ? ?] : [/\ input \in @CP G IO, output \in @CP G IO & u \in @CP G IO].
  { split; rewrite CP_set2 ?(@mem_cpl G) //; by [rewrite cp_sym (@mem_cpl G)|set_tac]. }
  rewrite-> dot2A. rewrite /= {1}/igraph /bgraph /induced.
  setoid_rewrite-> merge_subgraph_dot=>//.
  2: by rewrite disjoint_sym interval_edges_sym interval_bag_edges_disj.
  2: move => x A B; rewrite interval_sym in A; exact: (@bag_interval_cap G) B A.
  move: (union_bij_proofL _ _) => Pi.
  move: (union_bij_proofR _ _) => Po.
  move: (consistentU _ _) => con1.
  rewrite /igraph. setoid_rewrite merge_subgraph_dot=>//.
  apply iso2_subgraph_forT=>//.
  - move => x.
    have: x \in @interval G input output.
    { move: (sinterval_bag_cover conn_G Dio).
      rewrite (eqP (edgeless_bag _ _ _)) // (eqP (edgeless_bag _ _ _)) //.
      rewrite setUC setUA [[set _;_]]setUC -/(@interval G _ _) => <- //. }
    rewrite (interval_cp_cover conn_G proper_u) /interval. by set_tac.
  - move => e.
    have: e \in interval_edges input output.
    { move: (interval_bag_edge_cover conn_G Dio).
      by rewrite (eqP Ei0) (eqP Eo0) set0U setU0 => <-. }
    by rewrite (interval_cp_edge_cover conn_G proper_u).
  - apply: disjointsU. apply: interval_edges_disj_cp. by set_tac.
    apply: interval_bag_edges_disj => //.
  - move => x. case/setUP. apply: (@interval_interval_cap G). by set_tac.
    exact: (@bag_interval_cap G).
Qed.

Lemma iso_split_par2 (G : graph2) (C D : {set G})
  (Ci : input \in C) (Co : output \in C) (Di : input \in D) (Do : output \in D) :
  C :&: D \subset IO -> C :|: D = setT ->
  edge_set C :&: edge_set D = set0 -> edge_set C :|: edge_set D = setT ->
  G ≃2 point (induced C) (Sub input Ci) (Sub output Co)
     ∥ point (induced D) (Sub input Di) (Sub output Do).
Proof.
  move => subIO fullCD disjE fullE. symmetry.
  apply: iso2_comp. apply: (merge_subgraph_par _ _ _ _) => //=.
    abstract by rewrite -setI_eq0 disjE //.
    abstract by move => x inC inD; apply: (subsetP subIO); exact/setIP.
  by apply: iso2_subgraph_forT => //=; rewrite ?fullCD ?fullE.
Qed.

Lemma comp_dom2_redirect (G : graph2) (C : {set G}) :
  connected [set: skeleton G] -> input == output :> G ->
  edge_set G IO == set0 -> C \in @components G [set~ input] ->
  component C ≃2 dom (redirect C).
Proof.
  move => G_conn Eio no_loops HC.
  rewrite /redirect. case: pickP => [x /andP [inC adj_x] |].
  have E :  input |: (output |: C) = input |: (x |: C).
  { by rewrite (eqP Eio) [x |: C]setU1_mem // setUA setUid. }
  - apply: subgraph_for_iso => //; by rewrite ?E //= (eqP Eio).
  - case: (sig2W (comp_exit G_conn Eio HC)) => z Z1.
    rewrite sg_sym /=/sk_rel => /andP[_ B] /(_ z). by rewrite Z1 B.
Qed.

Lemma componentless_one (G : graph2) :
  input == output :> G -> edge_set G IO == set0 ->
  @components G [set~ input] == set0 -> G ≃2 1.
Proof.
  move => Eio E com0.
  have A (x : G) : x = input.
  { set C := pblock (@components G [set~ input]) x.
    apply: contraTeq com0 => Hx. apply/set0Pn. exists C. apply: pblock_mem.
    by rewrite (cover_partition (partition_components _)) !inE. }
  apply: iso_one => // [x|e]; first by rewrite !inE [x]A eqxx.
  move/eqP/setP/(_ e) : E.
  by rewrite !inE [source e]A [target e]A !eqxx.
Qed.

Lemma split_component (G : graph2) (C : {set G}) :
  edge_set G IO == set0 -> C \in @components G (~: IO) ->
  G ≃2 component C ∥ induced2 (~: C).
Proof.
  move=> NEio C_comp.
  case/and3P: (@partition_components G (~: IO)) => /eqP compU compI comp0n.
  have : C \subset ~: IO by rewrite -compU; apply/subsetP => x; exact: mem_cover.
  rewrite subsetC subUset !sub1set => /andP[iNC oNC]. rewrite induced2_induced.
  apply: iso_split_par2.
  - rewrite setUA setIUl setICr setU0. exact: subsetIl.
  - by rewrite -!setUA setUCr !setUT.
  - rewrite -(eqP NEio). apply/setP=> e; rewrite !inE.
    rewrite andbACA !orbA andb_orl andbN orbF.
    rewrite [_ && (target e \notin C)]andb_orl andbN orbF andbACA.
    apply/idP/idP => [/andP[->]//|He]. rewrite He /=.
    rewrite !inE in iNC oNC.
    case/andP: He => /orP[]/eqP-> /orP[]/eqP->; by rewrite ?iNC ?oNC.
  - apply/eqP. rewrite eqEsubset subsetT /=. apply/subsetP=> e _.
    rewrite !inE. case: (altP (source e =P target e)) => [<-|He].
      by rewrite !andbb -!orbA orbN.
    rewrite -negb_or orbC -implybE. apply/implyP.
    have {He} : @sedge G (source e) (target e) by rewrite /=/sk_rel He adjacent_edge.
    move: {e} (source e) (target e).
    suff Hyp (x y : G) : @sedge G x y -> x \in C ->
                         [|| y == input, y == output | y \in C].
    { move=> x y xy /orP[]H; rewrite H !orbT /= ?andbT; first exact: Hyp xy H.
      move: H. have : @sedge G y x by rewrite sg_sym. exact: Hyp. }
    move=> xy Hx. have := component_exit xy C_comp Hx. by rewrite !inE negbK orbA.
Qed.

Lemma componentless_top (G : graph2) :
  input != output :> G -> @components G (~: IO) == set0 ->
  point (@remove_edges _ _ G (edge_set IO)) input output ≃2 top.
Proof.
  move => Dio com0.
  have A (x: G) : x \in IO.
  { set C := pblock (@components G (~: IO)) x.
    apply: contraTT com0 => Hx. apply/set0Pn. exists C. apply: pblock_mem.
    by rewrite (cover_partition (partition_components _)) inE. }
  apply: iso_top => //.
  move => [e He]. rewrite inE negb_and in He.
  case/orP: He; by rewrite A.
Qed.

Lemma split_io_edge_aux (G : graph2) (e : edge G) :
  e \in edges input output -> point (remove_edges [set e] ∔ [input, elabel e, output]) input output ≃2 G.
Proof.
  rewrite inE => /andP [/eqP Es /eqP Et]. rewrite -{1}Es -{1}Et.
  apply: iso2_comp. apply: iso_iso2. apply: remove_edge_add. by case: G e {Es Et}.
Qed.

Lemma split_io_edge (G : graph2) (e : edge G) :
  e \in edges input output ->
  G ≃2 edge_graph2 1%CM (elabel e) 1%CM ∥ point (remove_edges [set e]) input output.
Proof.
  move => e_io. symmetry.
  rewrite /par/=/g2_par/=.
  apply: iso2_comp. apply: merge_iso2. apply: union_add_edge_l. rewrite /=.
  apply: iso2_comp. apply: iso_iso2. apply: merge_add_edge. rewrite !merge_add_edgeE.
  apply: iso2_comp. apply: iso_iso2. apply: add_edge_iso. apply: merge_iso.
    apply: union_C. rewrite !merge_isoE /=.
  pose k (x : @two_graph _ (flat sym) tt tt) : remove_edges [set e] :=
    match x with inl tt => input | inr tt => output end.
  eapply iso2_comp. apply: iso_iso2. apply: add_edge_iso. apply (merge_union_K (k := k)).
  - done.
  - abstract (case => [[]|[]] /=; apply/eqquotP; eqv).
  - abstract (repeat case).
  - rewrite /= !merge_union_KE /= {}/k.
    apply: iso2_comp. apply: iso_iso2. apply: iso_sym. apply: merge_add_edge.
    Unshelve. (* why? *)
    rewrite !(@merge_add_edgeE _ _ _ _ input (elabel e) output _).
    apply: iso2_comp. apply: @merge_nothing.
    + abstract (repeat constructor).
    + exact: split_io_edge_aux.
Qed.

Lemma split_io_edge_lens (G : graph2) (e : edge G) :
  e \in edge_set IO -> lens G -> G ≃2 graph_of_term (tm_ e) ∥ point (remove_edges [set e]) input output.
Proof.
  move => e_io lens_G. rewrite lens_io_set // inE in e_io.
  rewrite /tm_. case: ifP e_io => //= [e_io _|eNio e_oi]; first exact: split_io_edge.
  rewrite <- cnv2I.
  have e_io : e \in @edges _ _ (g2_cnv G) input output by [].
  rewrite -> (split_io_edge e_io) at 1. by rewrite -> cnv2par.
Qed.

Lemma split_io_loop (G : graph2) (e : edge G) :
  e \in edge_set IO -> input == output :> G -> G ≃2 graph_of_term (tm_ e) ∥ point (remove_edges [set e]) input output.
Proof.
  move => e_io /eqP Eio. rewrite inE -Eio setUid !inE in e_io.
  rewrite /tm_ inE -Eio e_io {2}Eio /=. apply: split_io_edge. by rewrite inE -Eio.
Qed.

Theorem term_of_iso (G : graph2) :
  CK4F G -> G ≃2 graph_of_term (term_of G).
Proof.
  elim/(size_ind (@term_of_measure sym)) : G => G IH CK4F_G.
  rewrite term_of_eq // /term_of_rec.
  case: ifP => [C1|/negbT C1].
  - (* selfloops / io-redirect *)
    case: picksP => [e e_io|/eqP C2]; last first.
    + case: pickP => [C HC|/(_ _) HC] /=.
      * setoid_rewrite (@split_component _ C) at 1 =>//.
        rewrite -?(eqP C1) ?setUid.
        have G_conn : connected [set: skeleton G] by case: CK4F_G.
        setoid_rewrite <-IH=>//.
        setoid_rewrite comp_dom2_redirect=>//.
        -- exact: measure_redirect.
        -- exact: CK4F_redirect.
        -- move: HC. rewrite -[set1 input]setUid {2}(eqP C1).
           exact: measure_remove_component.
        -- exact: CK4F_remove_component.
        -- by rewrite -?(eqP C1) ?setUid.
      * have : @components G [set~ input] == set0.
        { rewrite -subset0. apply/subsetP => C. by rewrite HC. }
        exact: componentless_one.
    + rewrite -> (split_io_loop e_io C1) at 1. simpl. rewrite <- IH => //.
      * apply: measure_remove_edges. exact: set10.
      * apply: CK4F_remove_loops => //. by rewrite sub1set.
  - case: ifP => [C2|/negbT C2].
    + (* parallel split *)
      have EC := lens_sinterval (proj1 CK4F_G) C2.
      case: picksP => [e e_io|/eqP C3]; last first.
      * case: pickP => [C HC|].
        -- rewrite EC in HC. setoid_rewrite (split_component _ HC) at 1=> //=.
           apply: par_iso2.
           ++ apply IH; rewrite -EC in HC.
              exact: measure_lens. exact: CK4F_lens.
           ++ apply IH; rewrite -EC in HC.
              exact: measure_lens_rest. exact: CK4F_lens_rest.
        -- have := split_K4_nontrivial C1 C2 _ CK4F_G.
           rewrite edge_set_adj // => /(_ isT)/ltnW.
           move=>H H'. exfalso. move: H H'.
           case/card_gt0P => C HC /(_ C). by rewrite HC.
      * rewrite EC. case: (boolP (_ && _)) => C4 /=.
        -- case/andP : C4 => C4 E4.
           rewrite -> (split_io_edge_lens e_io C2) at 1.
           have -> : [set e] = edge_set IO.
           { apply/eqP. by rewrite eqEsubset sub1set e_io -setD_eq0. }
           by rewrite -> componentless_top, par2top.
        -- setoid_rewrite (split_io_edge_lens e_io C2) at 1. apply: par_iso2 => //.
           rewrite negb_and -EC in C4. move/orP in C4.
           apply: IH.
           ++ apply: measure_remove_edges. exact: set10.
           ++ apply: CK4F_remove_edges => //=. by rewrite sub1set.
    + (* bag/sequential split *)
      rewrite /simple_check_point_term.
      case: ifP => [A|/negbT A].
      * rewrite /=. (* TODO: clean this up *)
        setoid_rewrite <-IH; first last.
          apply rec_bag => //; apply: CP_extensive; by rewrite !inE eqxx.
          apply rec_bag => //; apply: CP_extensive; by rewrite !inE eqxx.
          apply: CK4F_igraph => //; last rewrite cp_sym; exact: mem_cpl.
          apply: measure_igraph => //; by case: CK4F_G.
          apply rec_bag => //; apply: CP_extensive; by rewrite !inE eqxx.
          apply rec_bag => //; apply: CP_extensive; by rewrite !inE eqxx.
        case: CK4F_G => G_conn _. setoid_rewrite <-dot2A. exact: split_pip.
      * move: A. rewrite negb_or !negbK. case/andP => A B.
        rewrite /lens !negb_and A B (negbTE C1) /= in C2.
        case: pickP => [z Hz|C]; last first.
        { case:notF. apply: contraNT C2 => _. rewrite -setD_eq0.
          apply/eqP. apply/setP => x. by rewrite C inE. }
        rewrite /=.
        setoid_rewrite (split_cp (proj1 CK4F_G) Hz) at 1 => //.
        setoid_rewrite dot2A. repeat apply: dot_iso2.
        -- apply IH=> //. exact: measure_split_cpL. exact: CK4F_split_cpL.
        -- suff ? : z \in @CP G IO. { apply IH => //; by apply rec_bag. }
           case/setDP : Hz => Hz _. apply/bigcupP; exists (input,output) => //.
           by rewrite !inE !eqxx.
        -- apply IH=> //. exact: measure_split_cpR. exact: CK4F_split_cpR.
Qed.
End ExtractionIso.


From Coq Require Import String List Arith Lia.
From minilog Require Import data utils substitutions set operators.
Import ListNotations.

(** * Verified Unification Algorithm *)

(** ** Finite substitutions and replacements *)

(** Replacement in a list of equations of the forme [term = term] *)
Definition replace_all_1 (l : list (pattern * pattern)) (x : nat) (p : pattern) :=
  map (fun '(p1, p2) => (p1.[x := p], p2.[x := p])) l.

(** Replacement in a list of equations of the form [var = term].
    Only the right hand sides are modified.
*)
Definition replace_all_2 (l : list (nat * pattern)) (x : nat) (p : pattern) :=
  map (fun '(y, py) => (y, py.[x := p])) l.

(** ** Unifiers *)

(** What it means that a substitution unifies 2 patterns *)
Definition unifier u p1 p2 : Prop :=
  p1.[u] = p2.[u].

(** What it means to be a solution to a set of equations *)
Definition satisfy (u : psubstitution) equs :=
  Forall (fun '(x, y) => unifier u x y) equs.

Lemma unifier_cons:
  forall u f1 pat1 pats1 f2 pat2 pats2,
    unifier u (Papp f1 (pat1::pats1)) (Papp f2 (pat2::pats2)) <->
    (unifier u pat1 pat2 /\ unifier u (Papp f1 pats1) (Papp f2 pats2)).
Proof.
  intros. split.
  - intros H. inversion H; subst.
    unfold unifier. split; simpl; auto.
    now rewrite H3.
  - intros [H1 H2].
    unfold unifier in *. simpl.
    rewrite H1. now injection H2 as -> ->.
Qed.

(** ** Algorithm *)

(** As for matching, a state of the algorithm is a list of equations to be solved and a current solution.
    The only difference is that unification equations are of the form [(pattern, pattern)]
    Solutions are represented as finite maps from variables to patterns ([pattern])
*)
Record state := {
  equations : list (pattern * pattern);
  solution  : @fin_map pattern;
}.

(** At every iteration, the algorithm either fails, update the current state,
    or terminates with a solution *)
Inductive status :=
  | Failure
  | Update (st : state)
  | Success (sub : @fin_map pattern).

(** What it means for to set of equations to be equivalent *)
Definition equiv (equs1 equs2 : list (pattern * pattern)) :=
  forall u, satisfy u equs1 <-> satisfy u equs2.

(** Intepreting a finite map as a set of equations *)
Definition map_as_equations (m : @fin_map pattern) :=
  map (fun '(x, y) => (Pvar x, y)) m.

(** Intepreting a state as set of equations *)
Definition state_as_equations (st : state) :=
  equations st ++ map_as_equations (solution st).

Definition state_equiv (st1 st2 : state) :=
  equiv (state_as_equations st1) (state_as_equations st2).

(** Decompose the problem of unifying two vectors
    into a list of equations.
    The generated equations are collected on top
    of a provided accumulator.
*)
Fixpoint decompose (l1 : list pattern) (l2 : list pattern) :=
  match l1, l2 with
  | [], [] => Some []
  | x::xs, y::ys =>
    do equs <- decompose xs ys;
    Some ((x, y)::equs)
  | _, _ => None
  end.

Definition unification_step (st : state) :=
  match equations st with
  | [] => Success (solution st)
  | (t1, t2)::xs =>
    match t1, t2 with
    | Papp f1 l1, Papp f2 l2 =>
      if (f1 =? f2)%string then
        match decompose l1 l2 with
        | Some equs => Update (Build_state (equs ++ xs) (solution st))
        | None => Failure
        end
      else Failure
    | Pvar n, t | t, Pvar n =>
      if is_free t n then
        Failure
      else
        Update (Build_state (replace_all_1 xs n t) ((n, t)::(replace_all_2 (solution st) n t)))
    end
  end.

Lemma decompose_equiv:
  forall s1 s2 l1 l2 l,
    (s1 =? s2)%string = true ->
    decompose l1 l2 = Some l ->
    equiv l [(Papp s1 l1, Papp s2 l2)].
Proof.
  intros * ->%String.eqb_eq Hdec sub.
  induction l2 in l, l1, Hdec, sub |-*.
  - destruct l1; try easy.
    inversion_clear Hdec.
    repeat econstructor.
  - destruct l1; simpl in *; try easy.
    destruct (decompose l1 l2) as [l'|] eqn:Heq; simpl in *; try easy.
    inversion Hdec; subst. clear Hdec.
    specialize (IHl2 _ _ Heq sub) as [H1 H2].
    split; intros.
    + inversion_clear H as [| ? ? H3 H4].
      specialize (H1 H4).
      inversion_clear H1 as [| ? ? H5 _].
      repeat econstructor.
      apply unifier_cons.
      now repeat econstructor.
    + inversion H as [| ? ? H3 _]; subst.
      apply unifier_cons in H3 as [H3 H4].
      econstructor; auto.
      apply H2. now repeat econstructor.
Qed.

Lemma replace_all_1_equiv':
  forall equs sub x px,
    sub x = px.[sub] ->
    satisfy sub equs <->
    satisfy sub (replace_all_1 equs x px).
Proof.
  intros.
  induction equs as [| [pat1 pat2] equs IH]; try easy.
  split; intros Hsat.
  - inversion Hsat as [| ? ? H1 H2]; subst.
    apply IH in H2.
    econstructor; auto. red.
    now do 2 rewrite <- subst_replace by auto.
  - inversion Hsat as [| ? ? H1 H2]; subst.
    apply IH in H2.
    red in H1. do 2 rewrite <- subst_replace in H1 by auto.
    now econstructor.
Qed.

Lemma replace_all_1_equiv:
  forall equs sub x y,
    sub x = sub y ->
    satisfy sub equs <->
    satisfy sub (replace_all_1 equs x (Pvar y)).
Proof.
  intros * H.
  induction equs as [| [pat1 pat2] equs IH]; try easy.
  split; intros Hsat.
  + inversion Hsat as [| ? ? H1 H2]; subst.
    apply IH in H2.
    econstructor; auto. red.
    now do 2 rewrite <- subst_replace_var by auto.
  + inversion Hsat as [| ? ? H1 H2]; subst.
    apply IH in H2.
    red in H1. do 2 rewrite <- subst_replace_var in H1 by auto.
    now econstructor.
Qed.

Lemma replace_all_2_equiv':
  forall equs sub x px,
    sub x = px.[sub] ->
    satisfy sub (map_as_equations equs) <->
    satisfy sub (map_as_equations (replace_all_2 equs x px)).
Proof.
  intros.
  induction equs as [| [y py] equs IH]; try easy.
  split; intros Hsat.
  - inversion Hsat as [| ? ? H1 H2]; subst.
    apply IH in H2.
    econstructor; auto. red.
    now rewrite <- subst_replace.
  - inversion Hsat as [| ? ? H1 H2]; subst.
    apply IH in H2.
    red in H1. rewrite <- subst_replace in H1 by auto.
    now econstructor.
Qed.

Lemma replace_all_2_equiv:
  forall equs sub x y,
    sub x = sub y ->
    satisfy sub (map_as_equations equs) <->
    satisfy sub (map_as_equations (replace_all_2 equs x (Pvar y))).
Proof.
  intros * H.
  induction equs as [| [z patz] equs IH]; try easy.
  split; intros Hsat.
  + inversion Hsat as [| ? ? H1 H2]; subst.
    apply IH in H2.
    econstructor; auto. red.
    now rewrite H1, <- subst_replace_var by auto.
  + inversion Hsat as [| ? ? H1 H2]; subst.
    apply IH in H2.
    red in H1. rewrite <- subst_replace_var in H1 by auto.
    now econstructor.
Qed.

Lemma unify_replace:
  forall sub x patx pat1 pat2,
    unifier sub (Pvar x) patx ->
    unifier sub pat1 pat2 <->
    unifier sub (pat1.[x := patx]) (pat2.[x := patx]).
Proof.
  intros. split; intros.
  - red. now do 2 rewrite <- subst_replace by auto.
  - red in H0. now do 2 rewrite <- subst_replace in H0 by auto.
Qed.

Theorem unification_step_equiv:
  forall st1 st2,
    unification_step st1 = Update st2 ->
    state_equiv st1 st2.
Proof.
  intros [equs1 sol1] [equs2 sol2] Hstep sub.
  induction equs1 as [| [dat1 pat1] equs1 _] in equs2, sol2, Hstep |-*; try easy.
  destruct dat1, pat1; cbn in Hstep.
  - destruct (n0 =? n)%nat eqn:Heq1; try easy.
    inversion Hstep; subst. clear Hstep.
    apply Nat.eqb_neq in Heq1.
    unfold state_as_equations. simpl.
    split.
    + intros H. inversion H as [| ? ? H1 H2]; subst.
      apply Forall_app in H2 as [H2 H3].
      apply Forall_app. repeat econstructor; auto.
      now apply replace_all_1_equiv.
      now apply replace_all_2_equiv.
    + intros [H1 H2]%Forall_app.
      inversion H2 as [| ? ? H3 H4]; subst.
      econstructor; auto.
      apply replace_all_1_equiv in H1; auto.
      apply replace_all_2_equiv in H4; auto.
      now apply Forall_app; split.
  - destruct (existsb)%nat eqn:Heq1; try easy.
    inversion Hstep; subst. clear Hstep.
    unfold state_as_equations. simpl.
    split.
    + simpl. intros H. inversion H as [| ? ? H1 H2]; subst.
      apply Forall_app in H2 as [H2 H3]. clear H.
      apply Forall_app. repeat econstructor; auto.
      now apply replace_all_1_equiv'.
      now apply replace_all_2_equiv'.
    + intros [H1 H2]%Forall_app. inversion H2 as [| ? ? H3 H4]; subst. clear H2.
      econstructor; auto.
      apply Forall_app. split.
      pose proof (replace_all_1_equiv' equs1 _ _ _ H3).
      now apply H in H1.
      fold (replace_all_2 sol1 n (Papp s l)) in H4.
      now apply replace_all_2_equiv' in H4.
  - destruct (existsb)%nat eqn:Heq1; try easy.
    inversion Hstep; subst. clear Hstep.
    unfold state_as_equations. simpl.
    fold (replace_all_2 sol1 n (Papp s l)).
    split.
    + simpl. intros H. inversion H as [| ? ? H1 H2]; subst.
      red in H1. symmetry in H1. clear H.
      apply Forall_app in H2 as [H2 H3].
      apply Forall_app. repeat econstructor; auto.
      now apply replace_all_1_equiv'.
      now apply replace_all_2_equiv'.
    + simpl. intros [H1 H2]%Forall_app.
      inversion H2 as [| ? ? H3 H4]; subst. clear H2.
      red in H3. symmetry in H3.
      econstructor; auto.
      apply Forall_app. split.
      now apply replace_all_1_equiv' in H1.
      now apply replace_all_2_equiv' in H4.
  - destruct (s =? s0)%string eqn:Heq1; try easy.
    destruct (decompose l l0) eqn:Heq2; try easy.
    apply String.eqb_eq in Heq1; subst.
    inversion Hstep; subst. clear Hstep.
    apply (decompose_equiv s0 s0 _ _ _ (String.eqb_refl s0)) in Heq2.
    specialize (Heq2 sub).
    unfold state_as_equations. simpl. split.
    + intros H. inversion H as [|? ? H2 H3]; subst.
      clear H. apply Forall_app in H3 as [H3 H4].
      do 2 (apply Forall_app; split; auto).
      apply Heq2. now econstructor.
    + intros [[H1 H2]%Forall_app H3]%Forall_app.
      apply Forall_cons.
      apply Heq2 in H1. now inversion H1.
      apply Forall_app; split; auto.
Qed.

(** ** INVARIAAAAAANT !!!! *)

(** A valid substitution is a finite map
    with only one binding for each variable
*)
Inductive valid_subst : fin_psubst -> Prop :=
  | valid_nil : valid_subst []
  | valid_cons x vx m :
    valid_subst m ->
    get m x = None ->
    valid_subst ((x, vx)::m).

Lemma in_valid_subst:
  forall sub x vx,
    valid_subst sub -> In (x, vx) sub -> (Pvar x).[sub] = vx.
Proof.
  induction sub as [|[x vx] sub IH]; try easy.
  intros y vy Hval [[=->->] | Hin].
  - inversion Hval; subst.
    unfold pinterp. simpl.
    now rewrite Nat.eqb_refl.
  - inversion Hval; subst.
    unfold pinterp. simpl.
    destruct (x =? y)%nat eqn:Heq.
    + apply Nat.eqb_eq in Heq; subst.
      inversion Hval; subst.
      now apply in_get in Hin.
    + specialize (IH y vy H1 Hin).
      simpl in IH. unfold pinterp in IH.
      now destruct (get sub y).
Qed.

Definition solution_invariant (sol : fin_psubst) :=
  valid_subst sol /\
  forall x vx, In (x, vx) sol ->
    ((free_var vx ∩ fin_dom sol) ⊆ ∅)%ops.

(** For all binding [x = vx] in the current solution,
    [x] does not occur in [vx] and in the remaning
    equations.
*)
Definition equations_invariant (st : state) :=
  forall x vx, In (x, vx) (solution st) ->
    ~(free_var vx x) /\
    forall pat1 pat2, In (pat1, pat2) (equations st) ->
      ~free_var pat1 x /\ ~free_var pat2 x.

Definition invariant (st : state) :=
  solution_invariant (solution st) /\
  equations_invariant st.

Lemma in_decompose:
  forall l1 l2 l3,
    decompose l1 l2 = Some l3 ->
    forall pat1 pat2,
      In (pat1, pat2) l3 -> In pat1 l1 /\ In pat2 l2.
Proof.
  induction l1.
  - intros * H1 * H2. destruct l2; try easy.
    now injection H1 as <-.
  - intros * H1 * H2. destruct l2; try easy.
    simpl in H1. destruct (decompose l1 l2) eqn:Heq; try easy.
    injection H1 as <-. specialize (IHl1 _ _ Heq).
    destruct H2 as [[=->->] | H2].
    repeat econstructor. specialize (IHl1 _ _ H2).
    split; now right.
Qed.

Lemma unification_step_invariant:
  forall st1 st2,
    equations_invariant st1 ->
    unification_step st1 = Update st2 ->
    equations_invariant st2.
Proof.
  intros [equs1 sol1] [equs2 sol2] H1 H2.
  unfold unification_step in H2. simpl in *.
  destruct equs1 as [| [pat1 pat2] equs1 ]; try easy.
  destruct pat1.
  - destruct is_free eqn:Heq1; try easy.
    injection H2 as <- <-.
    intros x vx. simpl.
    intros [[=->->] | Hin].
    + split. now apply is_free_false.
      intros pat1 pat2 Hin.
      apply map_in in Hin as [[pat1' pat2'] [Hin [=->->]]].
      apply is_free_false in Heq1.
      split; now apply free_subst_1.
    + apply map_in in Hin as [[y vy] [Hin [=->->]]].
      specialize (H1 _ _ Hin) as [H1 H2]. simpl in H2.
      pose proof (H2 _ _ (or_introl eq_refl)) as [H3 H4].
      apply is_free_false in Heq1.
      split. now apply free_subst_2.
      intros pat3' pat4' Hin'.
      apply map_in in Hin' as [[pat3 pat4] [Hin' [=->->]]].
      pose proof (H2 _ _ (or_intror Hin')) as [H5 H6].
      split; now apply free_subst_2.
  - destruct pat2.
    + destruct is_free eqn:Heq1; try easy.
      injection H2 as <- <-.
      intros x vx [[=<-<-] | Hin]; simpl.
      * split. now apply is_free_false.
        intros pat1 pat2 Hin.
        apply map_in in Hin as [[pat1' pat2'] [Hin [=->->]]].
        apply is_free_false in Heq1.
        split; now apply free_subst_1.
      * apply map_in in Hin as [[y vy] [Hin [=->->]]].
        specialize (H1 _ _ Hin) as [H1 H2]. simpl in H2.
        pose proof (H2 _ _ (or_introl eq_refl)) as [H3 H4].
        apply is_free_false in Heq1.
        split. now apply free_subst_2.
        intros pat3' pat4' Hin'.
        apply map_in in Hin' as [[pat3 pat4] [Hin' [=->->]]].
        pose proof (H2 _ _ (or_intror Hin')) as [H5 H6].
        split; now apply free_subst_2.
    + destruct (s =? s0)%string eqn:Heq; try easy.
      apply String.eqb_eq in Heq as <-.
      destruct decompose eqn:Heq; try easy.
      injection H2 as <- <-.
      intros x vx Hin. simpl in *.
      specialize (H1 _ _ Hin) as [H1 H2].
      split; auto. intros pat1 pat2 [H | H]%in_app_iff.
      * apply in_decompose with (pat1 := pat1) (pat2 := pat2) in Heq as [Hin1 Hin2]; auto.
        specialize (H2 _ _ (or_introl eq_refl)) as [Hfree1 Hfree2].
        split.
        intros Hcontr. apply Hfree1.
        constructor. apply Exists_exists. eexists; eauto.
        intros Hcontr. apply Hfree2.
        constructor. apply Exists_exists. eexists; eauto.
      * now specialize (H2 _ _ (or_intror H)).
Qed.

Lemma get_replace_all_2:
  forall sol x vx y,
    get sol y = None ->
    get (replace_all_2 sol x vx) y = None.
Proof.
  induction sol as [|[x vx] sol IH]; try easy.
  intros y vy z Hz. simpl in *.
  destruct (x =? z)%nat eqn:Heq; try easy.
  now apply IH.
Qed.

Lemma valid_subst_replace_all_2:
  forall sol x vx,
    valid_subst sol ->
    valid_subst (replace_all_2 sol x vx).
Proof.
  induction sol as [|[y vy] sol IH]; try easy.
  intros x vx H. inversion H; subst. simpl.
  econstructor; auto.
  now apply get_replace_all_2.
Qed.

Lemma fin_dom_replace_all_2:
  forall sol x vx,
    (fin_dom (replace_all_2 sol x vx) ⊆ fin_dom sol)%ops.
Proof.
  intros. induction sol as [| [y vy] sol IH]; try easy.
  intros z Hz. unfold fin_dom in *. simpl in *.
  destruct (y =? z)%nat; try easy.
  intros Hcontr. now specialize (IH z Hz).
Qed.

Lemma unification_step_strong_invariant:
  forall st1 st2,
    invariant st1 ->
    unification_step st1 = Update st2 ->
    invariant st2.
Proof.
  intros [equs1 sol1] [equs2 sol2] [[Hinv1 Hinv2] Hinv3] H.
  split; cycle 1. now apply unification_step_invariant in H.
  unfold unification_step in H. simpl in *.
  destruct equs1 as [| [pat1 pat2] equs1 ]; try easy.
  destruct pat1.
  - destruct is_free eqn:Heq1; try easy.
    injection H as <- <-. split.
    + econstructor.
      now apply valid_subst_replace_all_2.
      apply get_replace_all_2.
      destruct (get sol1 n) as [vn|] eqn:Heq; auto.
      apply get_in in Heq. specialize (Hinv3 _ _ Heq) as [_ H2].
      specialize (H2 _ _ (or_introl eq_refl)) as [H2 _].
      exfalso. apply H2. econstructor.
    + intros x vx [[=->->] | Hin].
      apply is_free_false in Heq1.
      intros y [Hy1 [->|Hy2]%fin_dom_cons]; try easy.
      apply fin_dom_replace_all_2 in Hy2.
      pose proof (fin_dom_in _ _ Hy2) as [vy Hvy%get_in].
      specialize (Hinv3 _ _ Hvy) as [_ H2].
      now specialize (H2 _ _ (or_introl eq_refl)).
      apply is_free_false in Heq1.
      intros y [Hy1 [->|Hy2]%fin_dom_cons]; try easy.
      apply map_in in Hin as [[z vz] [H [=->->]]].
      specialize (Hinv3 _ _ H) as [H1 H2]. simpl in H2.
      specialize (H2 _ _ (or_introl eq_refl)) as [H2 H3].
      eapply free_subst_1; cycle 1; eauto.
      apply fin_dom_replace_all_2 in Hy2.
      pose proof (fin_dom_in _ _ Hy2) as [vy Hvy%get_in].
      specialize (Hinv3 _ _ Hvy) as [H1 H2].
      specialize (H2 _ _ (or_introl eq_refl)) as [H2 H3].
      apply map_in in Hin as [[z vz] [H [=->->]]].
      apply (Hinv2 _ _ H). split; auto.
      now apply free_subst_3 in Hy1.
  - destruct pat2.
    + destruct is_free eqn:Heq1; try easy.
      injection H as <- <-. split.
      * econstructor.
        now apply valid_subst_replace_all_2.
        apply get_replace_all_2.
        destruct (get sol1 n) as [vn|] eqn:Heq; auto.
        apply get_in in Heq. specialize (Hinv3 _ _ Heq) as [_ H2].
        specialize (H2 _ _ (or_introl eq_refl)) as [_ H2].
        exfalso. apply H2. econstructor.
      * apply is_free_false in Heq1.
        intros x vx [[=<-<-] | Hin].
        intros y [Hy1 [->|Hy2]%fin_dom_cons]; try easy.
        apply fin_dom_replace_all_2 in Hy2.
        pose proof (fin_dom_in _ _ Hy2) as [vy Hvy%get_in].
        specialize (Hinv3 _ _ Hvy) as [_ H2].
        now specialize (H2 _ _ (or_introl eq_refl)).
        apply map_in in Hin as [[z vz] [H [=->->]]].
        intros y [Hy1 [->|Hy2]%fin_dom_cons]; try easy.
        eapply free_subst_1; cycle 1; eauto.
        apply fin_dom_replace_all_2 in Hy2.
        pose proof (fin_dom_in _ _ Hy2) as [vy Hvy%get_in].
        specialize (Hinv3 _ _ Hvy) as [H1 H2].
        specialize (H2 _ _ (or_introl eq_refl)) as [H2 H3].
        apply (Hinv2 _ _ H). split; auto.
        now apply free_subst_3 in Hy1.
    + destruct (s =? s0)%string eqn:Heq; try easy.
      apply String.eqb_eq in Heq as <-.
      destruct decompose eqn:Heq; try easy.
      injection H as <- <-. split; auto.
Qed.

Lemma satisfy_self:
  forall st,
    solution_invariant (solution st) ->
    satisfy (pinterp (solution st)) (map_as_equations (solution st)).
Proof.
  intros [equs sol] [Hinv1 Hinv2]. simpl in *. clear equs.
  apply Forall_forall. intros [pat1 pat2] Hin.
  apply map_in in Hin as [[x vx] [Hin [=->->]]].
  specialize (Hinv2 _ _ Hin).
  red. rewrite in_valid_subst with (vx := vx) by auto.
  rewrite free_dom_subst; auto.
  intros y [Hy1 Hy2]. apply Hinv2.
  split; auto.
  now apply dom_fin_dom.
Qed.

Lemma unification_step_success:
  forall st sol,
    unification_step st = Success sol -> sol = solution st.
Proof.
  intros [equs sol] sol' H.
  unfold unification_step in H. simpl in *.
  destruct equs as [| [pat1 pat2]]. now injection H as ->.
  now destruct pat1, pat2, is_free, String.eqb, decompose.
Qed.


(* 第12回課題
 * 先週の群論に関する問題を rewrite を用いて解く。
 * 実行例 : rewriter (rightId, (rightInv, tt)) 3
 *)

Require Import Bool List.
Require Import Cpdt.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.

Section group.
  Variable G : Set.
  Variable f : G -> G -> G.
  Infix "*" := f.

  Variable e : G.
  Variable i : G -> G.

  Variable assoc : forall a b c, (a * b) * c = a * (b * c).
  Variable rightId : forall a, a * e = a.
  Variable rightInv : forall a, a * i a = e.
  (* Set Ltac Debug.*)

  Ltac rewriter tacs n :=
    intros;
    let rec search lst :=
        match lst with
        | (?lemma, ?more) => try rewrite lemma; try search more
        | tt => fail 1
        end
    in
    match n with
    | O => try reflexivity
    | S ?n' => try search tacs; rewriter tacs n'
    end.

  Lemma test1 : forall a b, a * b * i b = a.
    rewriter (assoc, (rightInv, (rightId, tt))) 1.
  Qed.

  Lemma test2 : forall a, a * e * i a * i e = e.
    rewriter (rightInv, (rightId, tt)) 3.
  Qed.

End group.