(** BingShrinkingCriterion.v by Ken'ichi Kuga **************)
(** Simplified using SSReflect by Mitsuharu Yamamoto  ******)

(***********************************************************)
(*   Bing Shrinking Criterion                              *)
(*          and                                            *)
(*     Bing Shrinking Theorem for compact spaces           *)
(* *********************************************************)

(*

Definition approximable_by_homeos (f:X->Y): Prop:=
  forall eps:R, eps>0 ->
    exists h:point_set Xt -> point_set Yt,
    homeomorphism h /\
    (forall x:X, d' (f x) (h x) < eps).

Definition Bing_shrinkable (f:X->Y): Prop:=
  forall eps:R, eps>0 ->
    exists h : point_set Xt -> point_set Xt,
    homeomorphism h /\
    (forall x:X, d' (f x) (f (h x)) < eps) /\
    (forall x1 x2:X,  (f x1) = (f x2) -> d (h x1) (h x2)  < eps).

Theorem Bing_Shrinking_Theorem:
 forall f: point_set Xt -> point_set Yt,
continuous f -> surjective f ->
 (Bing_shrinkable f -> approximable_by_homeos f).

************************************************************)
Require Import ProofIrrelevance.
Require Import ClassicalChoice.
Require Import Classical.
Require Import Fourier.
Require Import FunctionalExtensionality.
From mathcomp
Require Import ssreflect ssrbool.
From ZornsLemma
Require Import Proj1SigInjective.
From Topology
Require Import MetricSpaces RTopology ContinuousFactorization.
From Topology
Require Import Completeness Compactness WeakTopology Homeomorphisms.
From Topology
Require Import RationalsInReals Continuity.

(*******************************)
Require Import BaireSpaces.
Require Import LemmasForBSC.
(*******************************)
Open Scope R_scope.

Section Topological_Lemmas.
(*** Some frequently used inequqlities ***)

(*
(* This can be proved with "auto with *". *)
Lemma pos_INR_Sn: forall n:nat, 0 < INR (S n).
Proof.
by move=> n; apply: lt_0_INR; apply: lt_0_Sn.
Qed.

(* This can be proved with "auto with *". *)
Lemma pos_inv_INR_Sn: forall n:nat, 0 < /INR (S n).
Proof.
by move=> n0; apply: Rinv_0_lt_compat; apply: pos_INR_Sn.
Qed.
*)

Lemma Rlt_inv_INR_S_contravar:
forall n m:nat, (n < m)%nat -> /INR (S m) < /INR (S n).
Proof.
move=> n m nltm.
apply: Rinv_lt_contravar; first by apply: Rmult_lt_0_compat; auto with *.
by apply: lt_INR; apply: lt_n_S.
Qed.

Lemma Rle_inv_INR_S_contravar:
forall n m:nat, (n <= m)%nat -> /INR (S m) <= /INR (S n).
Proof.
move=> n m nlem.
apply: Rinv_le_contravar; first by auto with *.
by apply: le_INR; apply: le_n_S.
Qed.

(******)

Definition id_map (XT:TopologicalSpace): point_set XT -> point_set XT:=
  fun x:point_set XT => x.

Lemma id_map_continuous :
  forall XT:TopologicalSpace, continuous (id_map XT).
Proof.
move=> XT V V_open.
suff ->: inverse_image (id_map XT) V = V by [].
apply: Extensionality_Ensembles; split => x //.
by case.
Qed.

Lemma id_map_homeomorphism :
  forall XT:TopologicalSpace, homeomorphism (id_map XT).
Proof.
move=>XT.
by exists (id_map XT) => //; apply: id_map_continuous.
Qed.

Variable T:Type.
Variable dt:T->T->R.
Hypothesis dt_metric: metric dt.

Let Tt := MetricTopology dt dt_metric.

Lemma open_ball_open:
  forall (x: T) (r: R),
    r > 0 -> open (open_ball T dt x r : Ensemble (point_set Tt)).
Proof.
move=> x r H_r_pos.
apply: open_ball_is_open => //.
by apply: MetricTopology_metrizable.
Qed.

Lemma MetricTopology_Hausdorff: Hausdorff (MetricTopology dt dt_metric).
Proof.
apply: T3_sep_impl_Hausdorff.
apply: normal_sep_impl_T3_sep.
apply: metrizable_impl_normal_sep.
exists dt => //.
exact: MetricTopology_metrizable.
Qed.

Lemma lim_range:
  forall (x: T) (xn:Net nat_DS Tt) (r:R) (n0:nat),
   (forall n:nat,
          (n0 <= n)%nat  -> dt (xn n0) (xn n) <= r)
      -> net_limit xn x
         -> dt (xn n0) x <= r.
Proof.
move=> x xn r n0 dtxn0n lim_x.
apply: Rnot_gt_le => H.
pose eps := dt (xn n0) x - r.
have eps_pos: eps > 0 by apply: Rgt_minus.
case: (lim_x (open_ball T dt x eps)).
- exact: open_ball_open.
- constructor; by rewrite metric_zero.
- rewrite /= => x0 H0.
  suff: dt (xn n0) x < r + eps
    by apply: Rge_not_lt; rewrite /eps; fourier.
  pose m0 := max x0 n0.
  apply: Rle_lt_trans (_ : (dt (xn n0) (xn m0) + dt (xn m0) x) < _);
    first by apply: triangle_inequality.
  apply: Rplus_le_lt_compat (dtxn0n _ _) _; first by apply: Max.le_max_r.
  case: (H0 m0); first by apply: Max.le_max_l.
  by rewrite metric_sym.
Qed.

End Topological_Lemmas.

Section BingShrinkingTheorem.

Variables X Y:Type.
Variables (d:X->X->R) (d':Y->Y->R).
Variable (y0:X->Y) (Y0:Y).
Hypotheses (d_metric: metric d)
           (d'_metric: metric d').
Hypothesis X_inhabited: inhabited X.

Let Xt := MetricTopology d d_metric.
Let Yt := MetricTopology d' d'_metric.

Let CMap :=
  { f:X->Y | bound (Im Full_set
             (fun x:X=> d' (y0 x) (f x)))/\
             @continuous Xt Yt f }.

Let um (f g:CMap):R.
refine (match f, g with exist f0 Hf, exist g0 Hg
  => proj1_sig (sup (Im Full_set
    (fun x:X => d' (f0 x) (g0 x))) _ _) end).
destruct Hf as [hf _].
destruct hf as [mf].
destruct Hg as [hg _].
destruct hg as [mg].
exists (mf + mg).
red; intros.
destruct H1.
rewrite H2.
apply Rle_trans with
  (d' (y0 x) (f0 x) + d' (y0 x) (g0 x)).
rewrite (metric_sym _ d' d'_metric (y0 x) (f0 x)); apply triangle_inequality; trivial.
assert (d' (y0 x) (f0 x) <= mf)
  by (apply H; exists x; trivial).
assert (d' (y0 x) (g0 x) <= mg)
  by (apply H0; exists x; trivial).
auto with real.
destruct X_inhabited as [x0].
exists (d' (f0 x0) (g0 x0)); exists x0. constructor.
reflexivity.
(* Ssreflect-style proof.  But this makes the term bigger.
- case: Hf => [[mf Hf] _]; case: Hg => [[mg Hg] _].
  exists (mf + mg) => _ [x _ _ ->].
  apply: Rle_trans (_ : d' (f0 x) (y0 x)  + d' (y0 x) (g0 x) <= _);
    first by apply: triangle_inequality.
  rewrite (metric_sym _ _ d'_metric).
  apply: Rplus_le_compat.
  + by apply: Hf; exists x.
  + by apply: Hg; exists x.
- case: X_inhabited => [x0].
  by exists (d' (f0 x0) (g0 x0)); exists x0.
*)
Defined.

Lemma um_metric: metric um.
Proof.
constructor.
- move=> [f0 Hf] [g0 Hg] /=.
  case: X_inhabited => [x0] /=.
  case: sup => /= x [Hxub Hxleast].
  apply: Rge_trans (_ : d' (f0 x0) (g0 x0) >= _); last by case: d'_metric.
  apply: Rle_ge.
  apply: Hxub.
  by exists x0.
- move=> [f0 Hf] [g0 Hg] /=.
  case: sup => /= x [Hxub Hxleast].
  case: sup => /= y [Hyub Hyleast].
  have j: Im Full_set (fun x:X => d'(f0 x) (g0 x))
          = Im Full_set (fun x:X => d'(g0 x) (f0 x))
    by apply: Extensionality_Ensembles; split => /=;
       move => _ [x1 _ _ ->]; exists x1 => //; rewrite metric_sym.
  apply: Rle_antisym.
  + by apply: Hxleast; rewrite j; apply: Hyub.
  + by apply: Hyleast; rewrite -j; apply: Hxub.
- move=> [f0 Hf] [g0 Hg] [h0 Hh] /=.
  case: sup => /= x [Hxub Hxleast].
  case: sup => /= y [Hyub Hyleast].
  case: sup => /= z [Hzub Hzleast].
  apply: Hxleast => _ [x2 _ _ ->].
  apply: Rle_trans (_ : d' (f0 x2) (g0 x2) + d' (g0 x2) (h0 x2) <= _);
    first by case: d'_metric.
  apply: Rplus_le_compat.
  + by apply: Hyub; exists x2.
  + by apply: Hzub; exists x2.
- move=> [f0 [Bf Cf]] /=.
  case: sup => /= x [Hxub Hxleast].
  apply: Rle_antisym.
  + apply: Hxleast => _ [x0 _ _ ->].
    rewrite metric_zero //.
    by auto with real.
  + apply: Hxub.
    case: X_inhabited => [x0].
    exists x0 => //.
    by rewrite metric_zero.
- move=> [f0 [Bf Cf]] [g0 [Bg Cg]] /=.
  case: sup => /= x0 [Hx0ub Hx0least] Hx0.
(* Require Import Proj1SigInjective.*)
  apply: subset_eq_compatT.
(* Require Import FunctionalExtensionality.*)
  extensionality x.
  apply: (metric_strict _ _ d'_metric).
  rewrite Hx0 in Hx0ub.
  rewrite Hx0 in Hx0least.
  apply: Rle_antisym.
  + apply: Hx0ub.
    by exists x.
  + apply: Rge_le.
    by case: d'_metric.
Qed.

Lemma Rle_d'_um: forall (f g:CMap) (x:X),
  d' (proj1_sig f x) (proj1_sig g x) <=  um f g.
Proof.
move=> [f0 [Bf Cf]] [g0 [Bg Cg]] /= x.
case sup => /= x0 [Hx0ub Hx0least].
apply: Hx0ub.
by exists x.
Qed.

Lemma Rle_um_all_d': forall (f g:CMap) (r:R), r > 0 ->
(forall x:X, d' (proj1_sig f x) (proj1_sig g x) <=r) ->
  um f g <= r.
Proof.
move=> [f0 [Bf Cf]] [g0 [Bg Cg]] /= r r_pos Hd'r.
case sup => /= x0 [Hx0ub Hx0least].
apply: Hx0least.
move=> _ [x _ _ ->].
exact: Hd'r.
Qed.

Let CMapt := MetricTopology um um_metric.

Lemma um_complete: complete d' d'_metric -> complete um um_metric.
Proof.
move=> cpl_d' fn cauchy_fn.
pose yn (x:X): Net nat_DS Yt:= fun n:nat => (proj1_sig (fn n%nat)) x.
have cauchy_yn: forall x:X, cauchy d' (yn x).
{ move=> x eps pos_eps.
  case: (cauchy_fn _ pos_eps) => [N cau_fn].
  exists N.
  move=> m n hm hn.
  apply: Rle_lt_trans (_ : um (fn m) (fn n) < _); first by apply: Rle_d'_um.
  by apply: cau_fn.
}
pose choice_R (x:X) (y:Y): Prop := net_limit (yn x) y.
have choice_f0: forall x:X, exists y:Y, (choice_R x y)
  by move=> x; apply: cpl_d'; apply: cauchy_yn.
have [f0 Hf0]: exists f0: X->Y,
  (forall x:X, choice_R x (f0 x)) by apply: choice.
have Bf0: bound (Im Full_set (fun x:X=> d' (y0 x) (f0 x))).
{ case: (cauchy_fn 1); first by apply: Rlt_0_1.
  move=> n0 Bd1.
  case: (proj2_sig (fn n0)) => [[ub Bfn0] _].
  exists (ub+1) => _ [x _ _ ->].
  apply: Rle_trans (_ : d' (y0 x) (proj1_sig (fn n0) x)
                        + d' (proj1_sig (fn n0) x) (f0 x) <= _);
    first by apply: triangle_inequality.
  apply: Rplus_le_compat.
  - apply: (Bfn0 (d' (y0 x) (proj1_sig (fn n0) x))).
    by exists x.
  - have d'um1: forall n:nat, (n >= n0)%nat ->
      d' (proj1_sig (fn n0) x) (proj1_sig (fn n) x) < 1.
    { move=> n hn.
      apply: Rle_lt_trans (_ : um (fn n0) (fn n) < _);
        first by apply: Rle_d'_um.
      by apply: Bd1.
    }
    apply: Rnot_lt_le => Fh.
    pose ep := d' (proj1_sig (fn n0) x) (f0 x) - 1.
    have hpos_ep: ep > 0 by apply: Rgt_minus.
    case: (Hf0 x (open_ball Y d' (f0 x) ep)).
    + exact: open_ball_open.
    + constructor.
      by rewrite metric_zero.
    + rewrite /= => x0 H1.
      pose m0 := max n0 x0.
      case: (H1 m0); first by apply: Max.le_max_r.
      have H3: d' (proj1_sig (fn n0) x) (yn x m0) < 1
        by apply: d'um1; apply: Max.le_max_l.
      apply: Rle_not_gt.
      rewrite metric_sym //.
      apply: Rle_move_pr2ml.
      apply: Rle_trans (_ : d' (proj1_sig (fn n0) x) (yn x m0)
                            + d' (yn x m0) (f0 x) <= _);
        first by apply: triangle_inequality.
      apply: Rlt_le.
      rewrite Rplus_comm.
      exact: Rplus_lt_compat_l.
}
have Cf0: @continuous Xt Yt f0.
{ apply: pointwise_continuity => /= x.
  apply: (metric_space_fun_continuity Xt Yt _ _ d d').
  - exact: MetricTopology_metrizable.
  - exact: MetricTopology_metrizable.
  - move=> eps eps_pos /=.
    case: (cauchy_fn (/4 * eps)); first by fourier.
    move=> N H.
    have f0fN: forall x:X,
      d' (f0 x) (proj1_sig (fn N) x) <= /4 * eps.
    { move=> x0.
      apply: Rnot_gt_le => H0.
      pose de := d' (f0 x0) (proj1_sig (fn N) x0) - /4 * eps.
      have de_pos: de > 0 by apply: Rgt_minus.
      case (Hf0 x0 (open_ball Y d' (f0 x0) de)).
      - exact: open_ball_open.
      - constructor.
        by rewrite metric_zero.
      - rewrite /= => x1 H1.
        pose N1 := max N x1.
        have f0ynx1 : d' (f0 x0) (yn x0 N1) < de
          by case: (H1 N1) => //; by apply: Max.le_max_r.
        have ynNynN1 : d' (yn x0 N1) (yn x0 N) < /4 * eps
          by apply: Rle_lt_trans (_ : um (fn N1) (fn N) < _);
             [apply: Rle_d'_um | apply: H => //; apply: Max.le_max_l].
        have: d' (f0 x0) (yn x0 N) < de + /4 * eps.
        + apply: Rle_lt_trans (_ : d' (f0 x0) (yn x0 N1)
                                   + d' (yn x0 N1) (yn x0 N) < _);
            first by apply: triangle_inequality.
          exact: Rplus_lt_compat.
        apply: Rge_not_lt.
        rewrite /de /yn.
        by fourier.
    }
    case: (proj2_sig (fn N)) => _.
    move/continuous_func_continuous_everywhere/(_ x).
    move/metric_space_fun_continuity_converse.
    case/(_ d d')/(_ _ _ (/2 * eps));
      [exact: MetricTopology_metrizable | exact: MetricTopology_metrizable |
       by fourier |].
    move=> delta [delta_pos HC].
    exists delta; split => // x' dxx'_le_delta.
    rewrite [x in _ < x](_ : eps = /4*eps + /2*eps + /4*eps); last by field.
    apply: Rle_lt_trans (_ : d' (f0 x) (proj1_sig (fn N) x')
                             + d'(proj1_sig (fn N) x') (f0 x') < _);
      first by apply: triangle_inequality.
    rewrite [d' _ (f0 x')]metric_sym //.
    apply: Rplus_lt_le_compat => //.
    apply: Rle_lt_trans
             (_ : d' (f0 x) (proj1_sig (fn N) x)
                  + d' (proj1_sig (fn N) x) (proj1_sig (fn N) x') < _);
      first by apply: triangle_inequality.
    apply: Rplus_le_lt_compat => //.
    by apply: HC.
}
exists (exist (fun g:X->Y => bound (Im Full_set
              (fun x:X=> d' (y0 x) (g x))) /\
              @continuous Xt Yt g) f0 (conj Bf0 Cf0)).
apply: (metric_space_net_limit CMapt um).
apply: MetricTopology_metrizable.
move=> eps eps_pos.
case: (cauchy_fn (/2*eps)); first by fourier.
move=> i0 H.
exists i0 => j i0j.
apply: Rle_lt_trans (_ : /2*eps < _).
- apply: Rle_um_all_d'; first by fourier.
  move=> x /=.
  rewrite -[proj1_sig (fn j) x]/((yn x) j).
  rewrite metric_sym //.
  rewrite /= in i0j.
  apply: (lim_range Y d' d'_metric (f0 x) (yn x) (/2*eps) j) => n le_j_n.
  + apply: Rle_trans (_ : um (fn j) (fn n) <= _); first by apply: Rle_d'_um.
    apply: Rlt_le.
    apply: H.
    by auto.
  + exact: le_trans le_j_n.
- exact: Hf0.
- by fourier.
Qed.

Hypothesis X_compact: compact Xt.
Hypothesis Y_compact: compact Yt.

Hypothesis y0Y0: forall x:X, y0 x = Y0.

Lemma continuous_bounded: forall f : point_set Xt -> point_set Yt,
  continuous f ->
  bound (Im Full_set (fun x:X=> d' (y0 x) (f x))).
Proof.
move=> f f_conti.
pose g (y : point_set Yt) : point_set RTop := d' Y0 y.
pose ft (x : point_set Xt) : point_set RTop := g (f x).
have ft_conti: continuous ft.
{ apply: continuous_composition => //.
  apply: pointwise_continuity => y.
  apply: (metric_space_fun_continuity Yt RTop _ _ d' R_metric).
  - exact: MetricTopology_metrizable.
  - exact: RTop_metrization.
  - move=> eps eps_pos.
    exists eps; split => //.
    move=> y' d'yy'_eps.
    rewrite /R_metric /g.
    apply: Rabs_def1.
    + apply: Rlt_move_pr2ml.
      apply: Rle_lt_trans (_ : d' Y0 y + d' y y' < _);
        first by apply: triangle_inequality.
      rewrite Rplus_comm.
      exact: Rplus_lt_compat_r.
    + apply: Rlt_move_pl2mr.
      rewrite Rplus_comm.
      apply: Rlt_move_mr2pl.
      apply: Rle_lt_trans (_ : d' Y0 y' + d' y' y < _);
        first by apply: triangle_inequality.
      apply: Rplus_lt_compat_l.
      by rewrite metric_sym // Ropp_involutive.
}
apply: R_compact_subset_bounded.
have ->: Im Full_set (fun x : X => d' (y0 x) (f x)) = Im Full_set ft
  by apply: Extensionality_Ensembles; split;
     move=> _ [x _ _ ->]; exists x => //; rewrite y0Y0.
(* Require Import ContinuousFactorization. *)
(*have ft_img:
  forall x:point_set Xt, In (Im Full_set ft) (ft x).
move=>x.
by apply Im_intro with x.*)
pose ftr := continuous_surj_factorization ft.
apply: (compact_image ftr) => //.
- exact: continuous_surj_factorization_is_continuous.
- exact: continuous_surj_factorization_is_surjective.
Qed. (* continuous_bounded *)

Let W (eps:R):
 Ensemble (point_set CMapt) :=
 fun g:CMap =>  forall (x1 x2:X),
  (proj1_sig g x1) = (proj1_sig g x2) -> d x1 x2 < eps.

Lemma W_is_open: forall (eps:R),
                       eps > 0 -> open (W eps).
Proof.
move=> r rpos.
suff ->: W r = interior (W r) by apply: interior_open.
apply: Extensionality_Ensembles; split; last by apply: interior_deflationary.
move=> fr fr_in_W.
rewrite -[W r]Complement_Complement interior_complement => fr_in_clcoW.
(********* fr found ***************)
pose RR (n:nat) (g:CMap):Prop :=
  In (Complement (W r)) g /\ um fr g < (/ INR (S n)).
have [gn Hgn]: exists gn : nat -> CMap,
  forall n:nat, RR n (gn n).
{ apply: choice => n.
  have [gn Hgn]:
    Inhabited (Intersection (Complement (W r))
                            (open_ball CMap um fr (/ INR (S n)))).
  { apply: (closure_impl_meets_every_open_neighborhood _ _ fr) => //.
    - apply: open_ball_open.
      auto with *.
    - constructor.
      rewrite metric_zero; last by apply: um_metric.
      auto with *.
  }
  case: Hgn => {gn} gn CWgn [frgn].
  exists gn; split => //.
}
pose RA (k:nat) (Ak: X * X * Y * CMap): Prop :=
    (proj1_sig (snd Ak)) (fst (fst (fst Ak))) = (snd (fst Ak)) /\
    (proj1_sig (snd Ak)) (snd (fst (fst Ak))) = (snd (fst Ak)) /\
     d (fst (fst (fst Ak))) (snd (fst (fst Ak))) >= r /\
    um fr (snd Ak) < / INR (S k).
have [abcgn Habcgn]: exists Ak: nat -> X * X * Y * CMap,
   forall k:nat, (RA k (Ak k)).
{ apply: choice => k.
(********)
  pose nr := S O.
(********)
  have [ak [bk [Ck dakbk_r]]]: exists (ak bk:X),
      (proj1_sig (gn (max nr k)) ak) = (proj1_sig (gn (max nr k)) bk) /\
      d ak bk >= r.
  { apply: NNPP => Hnex.
    case: (Hgn (max nr k)).
    case=> ak bk Ck.
    apply: Rnot_ge_lt => dakbk_r.
    apply: Hnex.
    by exists ak, bk.
  }
  exists (ak, bk, (proj1_sig (gn (max nr k)) ak), (gn (max nr k))).
  repeat split=> //.
  case: (Hgn (max nr k)) => _ H0.
  apply: Rlt_le_trans (_ : / INR (S (Init.Nat.max nr k)) <= _) => //.
  apply: Rle_inv_INR_S_contravar.
  exact: Max.le_max_r.
}
pose a_net:Net nat_DS Xt:= (fun (n:nat) => fst (fst (fst (abcgn n)))).
have [lim_a H_lim_a]: exists a: point_set Xt, net_cluster_point a_net a
  by apply: compact_impl_net_cluster_point => //; apply: (inhabits O).
pose a_cond (n N:nat):=
  (n <= N)%nat /\ d lim_a (a_net N) < / INR (S n).
have [Na H_Na]: exists Na : nat -> nat, forall n, a_cond n (Na n).
{ apply: choice => n.
  case: (H_lim_a (open_ball X d lim_a (/INR (S n))) _ _ n).
  - apply: open_ball_open.
  - auto with *.
  - constructor.
    rewrite metric_zero => //.
    auto with *.
  - move=> x [H [H0]].
    by exists x.
}
pose b_net:Net nat_DS Xt := (fun (n:nat) => snd (fst (fst (abcgn (Na n))))).
have [lim_b H_lim_b]: exists b: point_set Xt, net_cluster_point b_net b
  by apply: compact_impl_net_cluster_point => //; apply: (inhabits O).
pose ab_cond (n N:nat) := (n <= N)%nat
  /\ (d lim_a (a_net (Na N)) < / INR (S n))
  /\ (d lim_b (b_net N) < / INR (S n)).
have [Nab H_Nab]: exists Nab : nat -> nat, forall n, ab_cond n (Nab n).
{ apply: choice => n.
  case: (H_lim_b (open_ball X d lim_b (/INR (S n))) _ _ n).
  - apply: open_ball_open.
  - auto with *.
  - constructor.
    rewrite metric_zero => //.
    auto with *.
  - move=> x [H [H0]].
    exists x; repeat split => //.
    apply: Rlt_le_trans (_ : /INR (S x) <= _); first by case: (H_Na x).
    exact: Rle_inv_INR_S_contravar.
}
(*******************)
pose aN (n:nat) : X :=  a_net (Na (Nab n)).
pose bN (n:nat) : X :=  b_net (Nab n).
pose cN (n:nat) : Y :=  snd (fst (abcgn (Na (Nab n)))).
pose gN (n:nat) : CMap := snd (abcgn (Na (Nab n))).
(********************)
have gNaN_cN : forall n:nat, proj1_sig (gN n) (aN n) = (cN n)
  by move=> n; case: (Habcgn (Na (Nab n))).
have gNbN_cN : forall n:nat, proj1_sig (gN n) (bN n) = (cN n)
  by move=> n; case: (Habcgn (Na (Nab n))) => _ [].
have daNbN_r : forall n:nat, d (aN n) (bN n) >= r
  by move=> n; case: (Habcgn (Na (Nab n))) => _ [_ []].
have umfrgN : forall n:nat, um fr (gN n) < / INR (S n).
{ move=> n.
  apply: Rlt_le_trans (_ : / INR (S (Na (Nab n))) <= _);
    first by case: (Habcgn (Na (Nab n))) => _ [_ []].
  apply: Rle_inv_INR_S_contravar.
  apply: le_trans (_ : (Nab n <= _)%nat); first by case: (H_Nab n).
  by case: (H_Na (Nab n)).
}
have dlimaaN: forall n:nat, d lim_a (aN n) < / INR (S n).
{ move=> n.
  apply: Rlt_le_trans (_ : / INR (S (Nab n)) <= _);
    first by case: (H_Na (Nab n)).
  apply: Rle_inv_INR_S_contravar.
  by case: (H_Nab n).
}
have dlimbbN: forall n:nat, d lim_b (bN n) < / INR (S n)
  by move=> n; case: (H_Nab n) => _ [].
have d_metrizes: metrizes Xt d
  by apply: MetricTopology_metrizable.
have d'_metrizes: metrizes Yt d'
  by apply: MetricTopology_metrizable.
have frab: (proj1_sig fr lim_a) = (proj1_sig fr lim_b).
{ apply: (metric_strict _ d') => //.
  apply: Rle_antisym; last by apply: Rge_le; apply: metric_nonneg.
  apply: Rnot_gt_le.
  set eps := d' (proj1_sig fr lim_a) (proj1_sig fr lim_b).
  move=> eps_pos.
  case: (proj2_sig fr) => _ fr_conti.
  have fr_conti_at_a: forall epsa : R, epsa > 0 ->
    exists deltaa:R, deltaa > 0 /\
    forall a': X, d lim_a a' < deltaa ->
      d' (proj1_sig fr lim_a) (proj1_sig fr a') < epsa.
    by apply: (metric_space_fun_continuity_converse Xt Yt _ _ d d') => //;
       apply: continuous_func_continuous_everywhere.
  have fr_conti_at_b: forall epsb : R, epsb > 0 ->
    exists deltab:R, deltab > 0 /\
    forall b': X, d lim_b b' < deltab ->
      d' (proj1_sig fr lim_b) (proj1_sig fr b') < epsb.
    by apply: (metric_space_fun_continuity_converse Xt Yt _ _ d d') => //;
       apply: continuous_func_continuous_everywhere.
  case: (fr_conti_at_a (/4*eps)); first by fourier.
  move=> dela [dela_pos fr_conti_a] {fr_conti_at_a}.
  case: (fr_conti_at_b (/4*eps)); first by fourier.
  move=> delb [delb_pos fr_conti_b] {fr_conti_at_b}.
  pose del := Rmin dela delb.
  have [N [N_pos N_large]]:
    exists N:nat, (N > 0)%nat /\ /INR N < Rmin (/4*eps) del
    by apply: RationalsInReals.inverses_of_nats_approach_0;
       do !apply: Rmin_pos => //; fourier.
  have HinvN: / INR (S N) < / INR N.
  { apply: Rinv_lt_contravar.
    apply: Rmult_lt_0_compat; auto with *.
    exact: lt_INR.
  }
  suff: d' (proj1_sig fr lim_a) (proj1_sig fr lim_b) < eps
    by apply: Rlt_irrefl.
  rewrite (_ : eps = /4*eps + /4*eps + /4*eps + /4*eps); last by field.
  apply: Rle_lt_trans
           (_ : d' (proj1_sig fr lim_a) (proj1_sig fr (bN N))
                + d' (proj1_sig fr (bN N)) (proj1_sig fr lim_b) < _);
    first by apply: triangle_inequality.
  apply: Rplus_lt_compat; last first.
  - rewrite metric_sym //.
    apply: fr_conti_b.
    apply: Rlt_le_trans (_ : del <= _); last by apply: Rmin_r.
    apply: Rlt_le_trans (_ : Rmin (/4*eps) del <= _ ); last by apply: Rmin_r.
    apply: Rlt_trans (_ : / INR N < _) => //.
    exact: Rlt_trans (_ : / INR (S N) < _).
  apply: Rle_lt_trans
           (_ : d' (proj1_sig fr lim_a) (proj1_sig (gN N) (bN N))
                + d' (proj1_sig (gN N) (bN N)) (proj1_sig fr (bN N)) < _);
    first by apply: triangle_inequality.
  apply: Rplus_lt_compat; last first.
  - rewrite metric_sym //.
    apply: Rle_lt_trans (_ : um fr (gN N) < _); first by apply: Rle_d'_um.
    apply: Rlt_trans (_ : / INR (S N) < _) => //.
    apply: Rlt_trans (_ : / INR N < _) => //.
    apply: Rlt_le_trans (_ : Rmin (/ 4 * eps) del <= _) => //.
    exact: Rmin_l.
  apply: Rle_lt_trans
           (_ : d' (proj1_sig fr lim_a) (proj1_sig (gN N) (aN N))
                + d' (proj1_sig (gN N) (aN N)) (proj1_sig (gN N) (bN N)) < _);
    first by apply: triangle_inequality.
  rewrite gNaN_cN gNbN_cN metric_zero // Rplus_0_r.
  apply: Rle_lt_trans (_ : d' (proj1_sig fr lim_a) (proj1_sig fr (aN N))
                           + d' (proj1_sig fr (aN N)) (cN N) < _);
    first by apply: triangle_inequality.
  apply: Rplus_lt_compat.
  - apply: fr_conti_a.
    apply: Rlt_le_trans (_ : del <= _); last by apply: Rmin_l.
    apply: Rlt_le_trans (_ : Rmin (/4*eps) del <= _ ); last by apply: Rmin_r.
    apply: Rlt_trans (_ : / INR N < _) => //.
    exact: Rlt_trans (_ : / INR (S N) < _).
  - rewrite -gNaN_cN.
    apply: Rle_lt_trans (_ : um fr (gN N) < _); first by apply: Rle_d'_um.
    apply: Rlt_trans (_ : / INR (S N) < _) => //.
    apply: Rlt_trans (_ : / INR N < _) => //.
    apply: Rlt_le_trans (_ : Rmin (/ 4 * eps) del <= _) => //.
    exact: Rmin_l.
}
have dlimalimb_r: d lim_a lim_b < r
  by apply: fr_in_W.
pose eps2 := r - d lim_a lim_b.
have eps2_pos: eps2 > 0.
  by apply: Rgt_minus.
have [N [N_pos INR_e2]]: exists N:nat, (N > 0)%nat /\ / INR N < /2 * eps2.
  by apply: RationalsInReals.inverses_of_nats_approach_0; fourier.
apply: Rlt_not_ge (daNbN_r N).
have HinvSN: / INR (S N) < /2 * eps2.
{ apply: Rlt_trans (_ : / INR N < _) => //.
  apply: Rinv_lt_contravar.
  apply: Rmult_lt_0_compat; auto with *.
  exact: lt_INR.
}
rewrite (_ : r = /2 * eps2 + ((r - eps2) + /2 * eps2)); last by field.
apply: Rle_lt_trans (_ : d (aN N) lim_a + d lim_a (bN N) < _);
  first by apply: triangle_inequality.
apply: Rplus_lt_compat;
  first by rewrite (metric_sym _ d) //; apply: Rlt_trans (_ : / INR (S N) < _).
apply: Rle_lt_trans (_ : d lim_a lim_b + d lim_b (bN N) < _);
  first by apply: triangle_inequality.
apply: Rplus_le_lt_compat; last by apply: Rlt_trans (_ : / INR (S N) < _).
by rewrite /eps2; fourier.
Qed. (*** W_is_open is defined ***)

Lemma bijection_complement:
forall (Xt Yt:TopologicalSpace)
(f: (point_set Xt) -> (point_set Yt)) (U: Ensemble (point_set Xt)),
 bijective f ->
 Complement (Im U f) = Im (Complement U) f.
Proof.
move=> XT YT f U [inj_f surj_f].
apply: Extensionality_Ensembles; split => y H_y.
- case: (surj_f y) => x H.
  exists x => // In_U_x.
  apply: H_y.
  by exists x.
- case Ey0: _ / H_y => [x Hx y1 Hy1].
  case Ey1: _ / => [x0 Hx0 y2 Hy2].
  apply: Hx.
  move: Ey1.
  rewrite Hy1 Hy2.
  by move/inj_f => ->.
Qed.

Lemma bij_conti_is_homeo_for_compact_Hausdorff_spaces:
compact Xt -> compact Yt -> Hausdorff Xt -> Hausdorff Yt ->
forall f: point_set Xt -> point_set Yt,
 bijective f -> continuous f -> homeomorphism f.
Proof.
move=> Xt_compact Yt_compact Xt_Hdf Yt_Hdf f f_bijective f_continuous.
apply: invertible_open_map_is_homeomorphism => //;
  first by apply: bijective_impl_invertible.
move=> U U_open.
apply: closed_complement_open => //.
apply: compact_closed => //.
have CImUf: forall xP : {x: point_set Xt | In (Complement U) x},
    Complement (Im U f) (f (proj1_sig xP)).
{ move=> [x Hx].
  rewrite bijection_complement //.
  by exists x.
}
pose fP (xP: {x:point_set Xt | In (Complement U) x}) :=
  exist (Complement (Im U f)) (f (proj1_sig xP)) (CImUf xP).
apply: (@compact_image
          (SubspaceTopology (Complement U))
          (SubspaceTopology (Complement (Im U f)))
          fP).
- apply: closed_compact; first by apply: Xt_compact.
  by rewrite /= Complement_Complement.
- move=> V V_open.
  have [W' [W'_open V_inv_W']]: exists W:Ensemble (point_set Yt),
      open W /\ V = inverse_image (@subspace_inc Yt (Complement (Im U f))) W
    by apply: subspace_topology_topology.
  have ->: inverse_image fP V =
           inverse_image (@subspace_inc Xt (Complement U))
                         (inverse_image f W')
    by apply: Extensionality_Ensembles; split; rewrite V_inv_W' => [? [[]]].
  apply: subspace_inc_continuous.
  exact: f_continuous.
- case: f_bijective => f_inj f_surj.
  move=> [y0' Hy0'].
  case: (f_surj y0') => x0 H.
  rewrite/fP.
  have InCUx0: In (Complement U) x0
    by move=> InUx0; apply: Hy0'; exists x0.
  exists (exist _  _ InCUx0).
  exact: subset_eq_compatT.
Qed. (*** bij_cont_is_homeo_for_compact_Hausdorff_spaces is defined ***)

Definition approximable_by_homeos (f:X->Y): Prop:=
  forall eps:R, eps>0 ->
    exists h:point_set Xt -> point_set Yt,
    homeomorphism h /\
    (forall x:X, d' (f x) (h x) < eps).

Definition Bing_shrinkable (f:X->Y): Prop:=
  forall eps:R, eps>0 ->
    exists h : point_set Xt -> point_set Xt,
    homeomorphism h /\
    (forall x:X, d' (f x) (f (h x)) < eps) /\
    (forall x1 x2:X,  (f x1) = (f x2) -> d (h x1) (h x2)  < eps).

Theorem Bing_Shrinking_Theorem:
 forall f: point_set Xt -> point_set Yt,
continuous f -> surjective f ->
 (Bing_shrinkable f -> approximable_by_homeos f).
Proof.
move=> f f_conti f_surj f_BS eps eps_pos.
have f_bdd_conti: bound (Im Full_set (fun x:X=> d' (y0 x) (f x)))/\
                           @continuous Xt Yt f
  by split =>//; apply: continuous_bounded.
pose fP := exist (fun f: X->Y => bound (Im Full_set (fun x:X=> d' (y0 x) (f x)))
                                 /\ @continuous Xt Yt f) f f_bdd_conti.
pose fH : Ensemble (point_set CMapt) :=
  fun gP: CMap => exists hx: point_set Xt -> point_set Xt,
                  homeomorphism hx /\
                  forall x: point_set Xt, (proj1_sig gP) x = f (hx x).
have InfHfP: In fH fP
  by exists (id_map Xt); split=>//; apply: id_map_homeomorphism.
pose CfH := closure fH.
pose CfHt := SubspaceTopology CfH.
(* Caution: point_set CfHt = { gP:CfH | In CfH gP } *)
pose um_restriction (f1PP f2PP: point_set CfHt) :=
  um (proj1_sig f1PP) (proj1_sig f2PP).
have um_restriction_metric: metric um_restriction
  by apply: d_restriction_metric; apply: um_metric.
have CfHt_baire: baire_space CfHt.
{ apply: (BaireCategoryTheorem _ um_restriction) => //;
    first by exact: d_restriction_metrizes.
  have um_is_metric: metric um by apply: um_metric.
  have um_is_complete: complete um um_metric
    by apply: um_complete; apply: compact_complete; exact: Y_compact.
  apply: closed_subset_of_complete_is_complete => //.
  exact: closure_closed.
}
pose Wn: IndexedFamily nat (point_set CfHt) :=
  fun n:nat => inverse_image (subspace_inc CfH)  (W (/INR (S n))).
have WnOD: forall n:nat, open (Wn n) /\ dense (Wn n).
{ move=>n; split;
    first by apply: subspace_inc_continuous; apply: W_is_open; auto with *.
(********************************************)
  apply: meets_every_nonempty_open_impl_dense.
  move=> U U_open [gPP InUgPP].
  case: (subspace_topology_topology _ _ U) => // V [V_open U_iV].
  have [r [r_pos IcOB_V]]: exists r:R, r>0 /\
    Included (open_ball (point_set CMapt) um (proj1_sig gPP) r) V
    by apply: open_ball_in_open; move: InUgPP; by rewrite U_iV => -[].
  have [fh0 h1_fh0]: Inhabited (Intersection fH (open_ball (point_set CMapt) um (proj1_sig gPP) (r*/2))).
  { apply: (closure_impl_meets_every_open_neighborhood _ _ (proj1_sig gPP)).
    - by case: (gPP).
    - by apply: open_ball_open; fourier.
    - constructor.
      have ->: um (proj1_sig gPP) (proj1_sig gPP) = 0
        by apply: metric_zero; apply: um_metric.
      by fourier.
  }
  case: h1_fh0 => {fh0} fh0 [h0 [[h' h0_conti h'_conti h_h'h0 h_h0h'] h_fh0]] [umgPfh0].
  pose eps1 := Rmin (r*/2) (/ INR (S n)).
  have [delta [pos_delta h_delta]]: exists delta:R, delta > 0 /\
    forall x1 x2 : X, d x1 x2 < delta -> d (h' x1) (h' x2) < eps1.
  { apply: dist_uniform_on_compact => //.
    apply: Rmin_pos; by [fourier | auto with *].
  }
  case: (f_BS (Rmin delta (r*/2))); first by apply: Rmin_pos => //; fourier.
  move=> k [[k' k_conti k'_conti h_k'k h_kk'] [h1_k h2_k]].
  pose k'h (x: point_set Xt) := k' (h0 x).
  pose h'k (x: point_set Xt) := h' (k x).
  pose fk'h (x: point_set Xt) := f (k'h x).
  have k'h_homeo: homeomorphism k'h.
  { exists h'k.
    - exact: continuous_composition.
    - exact: continuous_composition.
    - by move=> x; rewrite /h'k /k'h h_kk' h_h'h0.
    - by move=> x; rewrite /k'h /h'k h_h0h' h_k'k.
  }
  have fk'h_conti: continuous fk'h
    by apply: continuous_composition => //; exact: continuous_composition.
  have fk'h_bdd_conti:
    bound (Im Full_set (fun x:X => d' (y0 x) (fk'h x))) /\
    continuous fk'h
  by split=> //; exact: continuous_bounded.
  pose fk'hP := exist
        (fun f: X->Y => bound (Im Full_set (fun x:X=> d' (y0 x) (f x)))/\
                        @continuous Xt Yt f) fk'h fk'h_bdd_conti.
  have InCfHfk'hP: In CfH fk'hP
    by apply: closure_inflationary; exists k'h; split.
  pose fk'hPP := exist (fun f0P: point_set CMapt => In CfH f0P) fk'hP InCfHfk'hP.
  exists fk'hPP; split.
  - constructor => x1 x2 fk'hx1_fk'hx2.
    rewrite /= /fk'h in fk'hx1_fk'hx2.
    have: d (k (k'h x1)) (k (k'h x2)) < delta
      by apply: Rlt_le_trans (_ : Rmin delta (r * / 2) <= _);
         [apply: h2_k | apply: Rmin_l].
    rewrite /k'h !h_kk' => /h_delta.
    rewrite !h_h'h0 => /Rlt_le_trans.
    apply.
    apply: Rmin_r.
  - rewrite U_iV.
    constructor.
    rewrite /fk'hPP /=.
    apply: IcOB_V.
    constructor.
    apply: Rle_lt_trans (_ : um (proj1_sig gPP) fh0 + um fh0 fk'hP < _);
      first by apply: triangle_inequality; by apply: um_metric.
    rewrite (_ : r = r * /2 + r* /2); last by field.
    apply: Rplus_lt_le_compat => //.
    apply: Rle_um_all_d'; first by fourier.
    move=> x.
    rewrite h_fh0 /= /fk'h /k'h -[X in d' (f X)]h_kk' metric_sym //.
    apply: Rlt_le.
    apply: Rlt_le_trans (_ : Rmin delta (r * / 2) <= _); first by apply: h1_k.
    exact: Rmin_r.
}
have IWn_dense: dense (IndexedIntersection Wn)
  by apply: CfHt_baire; apply: WnOD.
have InCfHfP: In CfH fP.
  by apply: closure_inflationary.
pose fPP := exist (fun gP : CMap => In CfH gP) fP InCfHfP.
pose OBeps := open_ball CMap um fP eps.
have [hPP H_h]: Inhabited (Intersection (IndexedIntersection Wn) (inverse_image (subspace_inc CfH) OBeps)).
{ apply: dense_meets_every_nonempty_open.
  - exact: IWn_dense.
  - apply: subspace_inc_continuous.
    exact: open_ball_open.
  - exists fPP.
    constructor.
    constructor.
    rewrite metric_zero //.
    exact: um_metric.
}
case: H_h => {hPP} _ [hPP Wn_h] [OB_h].
(***)
pose hP := proj1_sig hPP.
pose h := proj1_sig hP.
case: (proj2_sig hP) => _.
rewrite -/h => c_h.
move: OB_h.
rewrite /subspace_inc -/hP => -[umfh].
exists h.
split.
apply: bij_conti_is_homeo_for_compact_Hausdorff_spaces => //.
- exact: MetricTopology_Hausdorff.
- exact: MetricTopology_Hausdorff.
- split.
  + move=> x1 x2 hx1_hx2.
    apply: (metric_strict _ d) => //.
    apply: Rle_antisym; last by apply: Rge_le; apply: metric_nonneg.
    apply: Rnot_gt_le => H.
    case: (inverses_of_nats_approach_0 (d x1 x2)) => // n [n_pos].
    apply: Rle_not_gt.
    case: (Wn_h n).
    rewrite /W /In /subspace_inc -/hP -/h => h_Wn.
    apply: Rlt_le.
    apply: Rlt_trans (_ : / INR (S n) < _); first by apply: h_Wn.
    apply: Rinv_lt_contravar.
    apply: Rmult_lt_0_compat; auto with *.
    exact: lt_INR.
  + move=> y.
    apply: NNPP => h_nx.
    have InCImhy: In (Complement (Im Full_set h)) y.
    { case E: _ / => [x InXx y' y_hx].
      apply: h_nx.
      exists x.
      by rewrite E y_hx.
    }
    have CImh_open: open (@Complement (point_set Yt) (Im Full_set h)).
    { apply: closed_complement_open.
      rewrite Complement_Complement.
      apply: compact_closed; first by apply: MetricTopology_Hausdorff.
      have h_img: forall x:point_set Xt, In (Im Full_set h) (h x)
        by move=>x; exists x.
      pose hf := @continuous_factorization Xt Yt h (Im Full_set h) h_img.
      apply: (compact_image hf) => //;
        first by apply: factorization_is_continuous.
      case=> _ [x1 InF_x y1 y1_hx1].
      exists x1.
      exact: subset_eq_compatT.
    }
(*******************************)
    have [r [r_pos IncObCImh]]: exists r:R, r > 0 /\
      Included (open_ball (point_set Yt) d' y r) (Complement (Im Full_set h))
      by apply: open_ball_in_open.
    have fH_hP_r: Inhabited (
                    Intersection fH (open_ball (point_set CMapt) um hP r)).
    { apply: (closure_impl_meets_every_open_neighborhood _ _ hP).
      - rewrite /hP.
        by case: (proj2_sig hPP).
      - exact: open_ball_open.
      - constructor.
        rewrite metric_zero //.
        by apply: um_metric.
    }
    case: fH_hP_r => _ [fh1 [h1 [h1_homeo fh1_f_h1]] [umhPfh1_r]].
    have [x1 y_fh1x1]: exists x1:point_set Xt, y = f (h1 x1).
    { case: h1_homeo => h1' h1_cont h1'_cont h1'h1 h1h1'.
      case: (f_surj y) => x2 fx2_y.
      exists (h1' x2).
      by rewrite h1h1'.
    }
    have InObyr_hx1: In (open_ball (point_set Yt) d' y r) (h x1).
    { constructor.
      rewrite /h y_fh1x1 -fh1_f_h1 metric_sym //.
      apply: Rle_lt_trans (_ : um hP fh1 < _) => //.
      exact: Rle_d'_um.
    }
    have: In (Complement (Im Full_set h)) (h x1)
      by apply: IncObCImh.
    apply.
    by exists x1.
- move=> x.
  rewrite -[f]/(proj1_sig fP) /h.
  apply: Rle_lt_trans (_ : um fP hP < _) => //.
  exact: Rle_d'_um.
Qed. (*  Bing_Shrinking_Theorem *)

End BingShrinkingTheorem.


Require Export UniMath.MoreFoundations.Notations.

(** ** An alternative proof of [total2_paths_equiv] *)

Theorem total2_paths_equiv' {A : UU} (B : A -> UU) (x y : ∑ x, B x) :
  x = y  ≃  x ╝ y.
Proof.
  simple refine (weqtotaltofib _ _ _ _ _).
  - intros z p. exists (maponpaths pr1 p). induction p. reflexivity.
  - apply isweqcontrcontr.
    + apply iscontrcoconusfromt.
    + exists (x ,, idpath _ ,, idpath _).
      intro w. induction w as [w p], w as [a b], p as [p q], x as [a' b'], (p:a' = a), (q:b' = b).
      reflexivity.
Defined.

Lemma total2_paths_equiv'_compute {A : UU} (B : A -> UU) (x y : ∑ x, B x) :
  pr1weq (total2_paths_equiv' B x y) = (λ (r : x = y), base_paths _ _ r ,, fiber_paths r).
Proof.
  reflexivity.
Defined.


Require Import Classical.

Theorem Ex027 (A : Prop): A \/ ~A.
Proof.
  apply NNPP.
  intro.
  apply H.
  right.
  intro.
  apply H.
  left.
  exact H0.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Max Omega List Permutation.

Require Import tacs rel_utils list_utils finite relevant_contract.
Require Import tree proof rules.
Require Import formula.

Set Implicit Arguments.

Definition Seq := (list Form * Form)%type.

Fact Seq_eq_dec (s1 s2 : Seq) : { s1 = s2 } + { s1 <> s2 }.
Proof.
  decide equality.
  apply Form_eq_dec.
  apply list_eq_dec.
  intros; apply Form_eq_dec.
Qed.

Local Hint Resolve Seq_eq_dec : core.

Local Notation " g '|--' a " := ((g,a):Seq) (at level 70, no associativity).

Implicit Type (c : Seq) (ll : list Seq).

Definition sf_Seq c :=
  match c with
    (g, a) => fun y => (exists x, In x g /\ sf_Form x y) \/ sf_Form a y
  end.

Fact sf_Seq_finite_t c : finite_t (sf_Seq c).
Proof.
  destruct c as (s,a); simpl.
  apply finite_t_cup.
  apply finite_t_relmap.
  exists s; tauto.
  intros; apply sf_Form_finite_t.
  apply sf_Form_finite_t.
Qed.

Definition LR_sf c d := sf_Seq d inc1 sf_Seq c.

Local Notation sf := LR_sf.

Fact LR_sf_refl c : sf c c.
Proof. red; auto. Qed.

Fact LR_sf_trans c d e : sf c d -> sf d e -> sf c e.
Proof. unfold LR_sf; auto. Qed.

(** All the following rules are permutation absorbing meaning
   that they are stable under permutation on the LHS of |- *)

Section Identity_rule.

  (** Identity rule for R sequent systems

               ---------- [id]
                 A |- A
  *)

  Inductive rule_id : Seq -> list Seq -> Prop :=
    | in_rule_id : forall a, rule_id (a::nil |-- a) nil.

  Fact rule_id_inv c ll :
    rule_id c ll -> ll = nil /\ exists a, c = (a::nil |-- a).
  Proof. induction 1 as [ a ]; split; auto; exists a; auto. Qed.

  Fact sf_rule_id c ll : rule_id c ll -> Forall (sf c) ll.
  Proof. induction 1 as [ ? ]; constructor. Qed.

  Definition rule_id_inst := Form.
  Definition rule_id_map : rule_id_inst -> Seq * list Seq.
  Proof. intros a; exact ( a :: nil |-- a , nil ). Defined.

  Fact rule_id_map_prop : soundly_represents rule_id rule_id_map.
  Proof. simpl; constructor. Qed.

  Fact rule_id_finite : finitely_represents rule_id rule_id_map.
  Proof.
    intros ( [ | y [ | z ll ] ], a).

    exists nil.
    intros h; split.
    intros H.
    apply rule_id_inv in H.
    destruct H as (_ & ? & ?); discriminate.
    intros (? & ? & []).

    destruct (Form_eq_dec a y) as [ | C ].
    subst y.
    exists (a :: nil).
    intros h; split.
    intros H.
    apply rule_id_inv in H.
    destruct H as (G & u & H).
    inversion H.
    subst u h.
    exists a; simpl; auto.
    intros (i & H1 & H2).
    inversion H1; subst i h.
    constructor.

    exists nil.
    intros h; split.
    intros H.
    apply rule_id_inv in H.
    destruct H as (_ & u & Hu).
    inversion Hu.
    subst y u.
    destruct C; trivial.
    intros (? & _ & []).

    exists nil.
    intros h; split.
    intros H.
    apply rule_id_inv in H.
    destruct H as (_ & u & Hu).
    discriminate.
    intros (? & _ & []).
  Qed.

  Hint Resolve rule_id_map_prop rule_id_finite : core.

  Fact rule_id_reif c hs : rule_id c hs -> { i | rule_id_map i = (c,hs) }.
  Proof. intros ?; apply rule_reif with (r := rule_id); auto. Qed.

  Fact rule_id_dec c hs : { rule_id c hs } + { ~ rule_id c hs }.
  Proof. apply rule_dec with (f := rule_id_map); auto. Qed.

  Fact rule_id_finite_t c : finite_t (rule_id c).
  Proof. apply rule_finite_t with (f := rule_id_map); auto. Qed.

End Identity_rule.

Section Axiom_rule.

  (** Identity rule for R sequent systems

               ------------- [ax]
                 A,ga |- A
  *)

  Inductive rule_ax : Seq -> list Seq -> Prop :=
    | in_rule_ax : forall l a r, rule_ax (l++a::r |-- a) nil.

  Fact rule_ax_inv c ll :
    rule_ax c ll -> ll = nil /\ exists l a r, c = (l++a::r |-- a).
  Proof. induction 1 as [ l a r ]; split; auto; exists l, a, r; auto. Qed.

  Fact sf_rule_ax c ll : rule_ax c ll -> Forall (sf c) ll.
  Proof. induction 1 as [ ? ]; constructor. Qed.

  Definition rule_ax_inst := (list Form * Form * list Form)%type.
  Definition rule_ax_map : rule_ax_inst -> Seq * list Seq.
  Proof. intros ((l,a),r); exact ( l++a :: r |-- a , nil ). Defined.

  Fact rule_ax_map_prop : soundly_represents rule_ax rule_ax_map.
  Proof. intros ((?,?),?); simpl; constructor. Qed.

  Fact rule_ax_finite : finitely_represents rule_ax rule_ax_map.
  Proof.
    intros (ll, a).

    destruct (In_dec Form_eq_dec a ll) as [ H | H ].
    destruct (In_split_dec Form_eq_dec a ll H) as (l & r & ?); subst ll.

    clear H.
    exists (((l,a),r) :: nil).
    intros hs; split.

    intros H.
    apply rule_ax_inv, proj1 in H; subst.
    exists ((l,a),r); simpl; tauto.

    intros (((l',a'),r') & H1 & [ H2 | [] ]).
    inversion H2; subst l' a' r'; clear H2.
    simpl in H1.
    inversion H1; subst hs; constructor.

    exists nil.
    intros hs; split.

    intros H1.
    apply rule_ax_inv, proj2 in H1.
    exfalso; destruct H1 as (l & a' & r & H1).
    inversion H1; subst ll a'.
    apply H, in_or_app; right; left; auto.

    intros (? & _ & []).
  Qed.

  Hint Resolve rule_ax_map_prop rule_ax_finite : core.

  Fact rule_ax_reif c hs : rule_ax c hs -> { i | rule_ax_map i = (c,hs) }.
  Proof. intros ?; apply rule_reif with (r := rule_ax); auto. Qed.

  Fact rule_ax_dec c hs : { rule_ax c hs } + { ~ rule_ax c hs }.
  Proof. apply rule_dec with (f := rule_ax_map); auto. Qed.

  Fact rule_ax_finite_t c : finite_t (rule_ax c).
  Proof. apply rule_finite_t with (f := rule_ax_map); auto. Qed.

End Axiom_rule.

Section Right_implication_rule.

  (** Right implication rule for R sequent systems

            A,ga |- B
          -------------- [r]
            ga |- A%>B

  *)

  Inductive LR_rule_r : Seq -> list Seq -> Prop :=
    | in_LR_r : forall th a b, LR_rule_r (th    |-- a %> b)
                                        ((a::th |-- b)
                                        :: nil ).

  Fact LR_rule_r_inv c ll : LR_rule_r c ll -> exists ga a b,
                                        c  = (ga |-- a %> b)
                                     /\ ll = ((a::ga |-- b) :: nil).
  Proof. induction 1 as [ ga a b ]; exists ga, a, b; auto. Qed.

  Fact sf_LR_rule_r c ll : LR_rule_r c ll -> Forall (sf c) ll.
  Proof.
    induction 1 as [ ga a b ]; constructor.
    2: constructor.
    intros x [ (y & H1 & H2) | Hx ].
    destruct H1 as [ H1 | H1 ].
    subst.
    right; right; tauto.
    left; exists y; auto.
    right; right; tauto.
  Qed.

  Definition LR_rule_r_inst := (list Form * Form * Form)%type.

  Definition LR_rule_r_map : LR_rule_r_inst -> Seq * list Seq.
  Proof.
    intros ((ga,a),b).
    exact ((ga |-- a %> b), ((a::ga |-- b) :: nil) ).
  Defined.

  Fact LR_rule_r_map_prop : soundly_represents LR_rule_r LR_rule_r_map.
  Proof. intros ((ga,a),b); simpl; constructor. Qed.

  Fact LR_rule_r_finite : finitely_represents LR_rule_r LR_rule_r_map.
  Proof.
    intros (ga,[ v | a b ]).

    exists nil.
    intros h; split.
    intros H.
    apply LR_rule_r_inv in H.
    destruct H as (? & ? & ? & ? & _); discriminate.
    intros ( ? & _ & [] ).

    exists ( ((ga,a),b) :: nil ).
    intros h; split.
    intros H.
    apply LR_rule_r_inv in H.
    destruct H as (th & u & v & H1 & H2).
    inversion H1; subst th u v h.
    exists ((ga,a),b); simpl; auto.
    intros ( ((th,u),v) & H1 & [ H2 | [] ] ).
    inversion H1.
    inversion H2.
    subst th u v h.
    constructor.
  Qed.

  Hint Resolve LR_rule_r_map_prop LR_rule_r_finite : core.

  Fact LR_rule_r_reif c hs : LR_rule_r c hs -> { i | LR_rule_r_map i = (c,hs) }.
  Proof. intros ?; apply rule_reif with (r := LR_rule_r); auto. Qed.

  Fact LR_rule_r_dec c hs : { LR_rule_r c hs } + { ~ LR_rule_r c hs }.
  Proof. apply rule_dec with (f := LR_rule_r_map); auto. Qed.

  Fact LR_rule_r_finite_t c : finite_t (LR_rule_r c).
  Proof. apply rule_finite_t with (f := LR_rule_r_map); auto. Qed.

End Right_implication_rule.

Section Left_implication_rule_LR1.

  (** Left implication rule for R sequent systems
      This is the "usual" rule that does not absorb contraction

             ga |- A     B,de |- C
           ------------------------- [l]
                 A%>B,ga,de |- C

  *)

  Inductive LR_rule_l : Seq -> list Seq -> Prop :=
    | in_LR_l : forall ga de th a b x,
                                 th ~p (a %> b) :: ga ++ de
                              -> LR_rule_l (th   |-- x)
                                        ( (ga    |-- a)
                                       :: (b::de |-- x)
                                       :: nil ).

  Fact LR_rule_l_inv c ll : LR_rule_l c ll -> exists ga de th a b x,
                                        c = (th |-- x)
                                     /\ ll = ( (ga |-- a) :: (b :: de |-- x) :: nil )
                                     /\ th ~p (a %> b) :: ga ++ de.
  Proof. induction 1 as [ ga de th a b x ]; exists ga, de, th, a, b, x; auto. Qed.

  Definition LR_rule_l_inst := { c : list Form * list Form * list Form * Form * Form * Form
                                   | match c with (((((ga,de),th),a),b),x) => th ~p (a %> b) :: ga ++ de end }%type.

  Definition LR_rule_l_map : LR_rule_l_inst -> Seq * list Seq.
  Proof.
    intros ( (((((ga,de),th),a),b),x) & _ ).
    exact (th |-- x , ( (ga |-- a) :: (b :: de |-- x) :: nil ) ).
  Defined.

  Fact LR_rule_l_map_prop : soundly_represents LR_rule_l LR_rule_l_map.
  Proof. intros ((((((ga,de),th),a),b),x) & H); simpl; constructor; auto. Qed.

  Fact LR_rule_l_finite : finitely_represents LR_rule_l LR_rule_l_map.
  Proof.
    intros (th,x).
    generalize (pick_split_finite_t th); intros (l1 & Hl1).
    set (ll := flat_map (fun u => match u with
                          | (£ _,_) => nil
                          | (a %> b,(ga,de)) => (((((ga,de),th),a),b),x) :: nil
                        end) l1).
    assert (forall u, In u ll -> match u with (((((ga,de),th),a),b),x) => th ~p (a %> b) :: ga ++ de end) as Hll.
      intros (((((ga,de),th'),a),b),x'); unfold ll; rewrite in_flat_map.
      intros (([ | a' b' ],(p,q)) & H1 & H2).
      destruct H2.
      destruct H2 as [ E | [] ].
      inversion E; subst p q th' a' b' x'.
      apply Hl1 in H1; auto.

    exists (list_Forall_sig _ _ Hll).
    intros h; split.

    intros H.
    apply LR_rule_l_inv in H.
    destruct H as (ga & de & th' & a & b & x' & E & H1 & H2).
    inversion E; subst th' x' h.
    assert (In (((((ga,de),th),a),b),x) ll) as H3.
      unfold ll; apply in_flat_map.
      exists (a %> b, (ga,de)); split; simpl; auto.
      apply Hl1; auto.
    generalize (list_Forall_sig_In_refl _ _ Hll _ H3).
    intros H4.
    match goal with [ H : In ?x _ |- _ ] => exists x end; split; auto.

    intros (((((((ga,de),th'),a),b),x') & H) & H1 & _).
    simpl in H1.
    inversion H1; subst th' x' h.
    constructor; auto.
  Qed.

  Hint Resolve LR_rule_l_map_prop LR_rule_l_finite : core.

  Fact LR_rule_l_reif c hs : LR_rule_l c hs -> { i | LR_rule_l_map i = (c,hs) }.
  Proof. intros ?; apply rule_reif with (r := LR_rule_l); auto. Qed.

  Fact LR_rule_l_dec c hs : { LR_rule_l c hs } + { ~ LR_rule_l c hs }.
  Proof. apply rule_dec with (f := LR_rule_l_map); auto. Qed.

  Fact LR_rule_l_finite_t c : finite_t (LR_rule_l c).
  Proof. apply rule_finite_t with (f := LR_rule_l_map); auto. Qed.

End Left_implication_rule_LR1.

Section Left_implication_rule_LI2.

  (** Left implication rule for IL sequent systems
      This is the contraction absorbing rule

             A%>B,ga |- A     A%>B,B,ga |- C
           ----------------------------------- [l]
                      A%>B,ga |- C

  *)

  Inductive LI2_rule_l : Seq -> list Seq -> Prop :=
    | in_LI2_l : forall ga th a b x,
                                 th ~p (a %> b) :: ga
                              -> LI2_rule_l (th   |-- x)
                                        ( (a %> b :: ga  |-- a)
                                       :: (a %> b :: b::ga |-- x)
                                       :: nil ).

  Fact LI2_rule_l_inv c ll : LI2_rule_l c ll -> exists ga th a b x,
                                        c = (th |-- x)
                                     /\ ll = ( (a %> b :: ga |-- a) :: (a %> b :: b :: ga |-- x) :: nil )
                                     /\ th ~p (a %> b) :: ga.
  Proof. induction 1 as [ ga th a b x ]; exists ga, th, a, b, x; auto. Qed.

  Fact sf_LI2_rule_l c ll : LI2_rule_l c ll -> Forall (sf c) ll.
  Proof.
    induction 1 as [ ga th a b x ].

    constructor.
    intros c [ (d & [ Hd1 | Hd1 ] & Hd2) | Hc ].

    subst; left; exists (a %> b); split; auto.
    apply Permutation_in with (1 := Permutation_sym H); left; auto.

    left; exists d; split; auto.
    apply Permutation_in with (1 := Permutation_sym H); right; auto.

    left; exists (a %> b); split.
    apply Permutation_in with (1 := Permutation_sym H); left; auto.
    right; left; auto.

    constructor.
    intros c [ (d & [ Hd1 | [ Hd1 | Hd1 ] ] & Hd2) | Hc ].

    subst d; left; exists (a %> b); split; auto.
    apply Permutation_in with (1 := Permutation_sym H); left; auto.

    subst d; left; exists (a %> b); split; auto.
    apply Permutation_in with (1 := Permutation_sym H); left; auto.

    right; auto.

    left; exists d; split; auto.
    apply Permutation_in with (1 := Permutation_sym H); right; auto.

    right; auto.

    constructor.
  Qed.

  Definition LI2_rule_l_inst := { c : list Form * list Form * Form * Form * Form
                                   | match c with ((((ga,th),a),b),x) => th ~p (a %> b) :: ga end }%type.

  Definition LI2_rule_l_map : LI2_rule_l_inst -> Seq * list Seq.
  Proof.
    intros ( ((((ga,th),a),b),x) & _ ).
    exact (th |-- x , ( (a %> b :: ga |-- a) :: (a %> b :: b :: ga |-- x) :: nil ) ).
  Defined.

  Fact LI2_rule_l_map_prop : soundly_represents LI2_rule_l LI2_rule_l_map.
  Proof. intros (((((ga,th),a),b),x) & H); simpl; constructor; auto. Qed.

  Fact LI2_rule_l_finite : finitely_represents LI2_rule_l LI2_rule_l_map.
  Proof.
    intros (th,x).
    generalize (pick_finite_t th); intros (l1 & Hl1).
    set (ll := flat_map (fun u => match u with
                          | (£ _,_) => nil
                          | (a %> b,ga) => ((((ga,th),a),b),x) :: nil
                        end) l1).
    assert (forall u, In u ll -> match u with ((((ga,th),a),b),x) => th ~p (a %> b) :: ga end) as Hll.
      intros ((((ga,th'),a),b),x'); unfold ll; rewrite in_flat_map.
      intros (([ | a' b' ],p) & H1 & H2).
      destruct H2.
      destruct H2 as [ E | [] ].
      inversion E; subst p th' a' b' x'.
      apply Hl1 in H1; auto.

    exists (list_Forall_sig _ _ Hll).
    intros h; split.

    intros H.
    apply LI2_rule_l_inv in H.
    destruct H as (ga & th' & a & b & x' & E & H1 & H2).
    inversion E; subst th' x' h.
    assert (In ((((ga,th),a),b),x) ll) as H3.
      unfold ll; apply in_flat_map.
      exists (a %> b, ga); split; simpl; auto.
      apply Hl1; auto.
    generalize (list_Forall_sig_In_refl _ _ Hll _ H3).
    intros H4.
    match goal with [ H : In ?x _ |- _ ] => exists x end; split; auto.

    intros ((((((ga,th'),a),b),x') & H) & H1 & _).
    simpl in H1.
    inversion H1; subst th' x' h.
    constructor; auto.
  Qed.

  Hint Resolve LI2_rule_l_map_prop LI2_rule_l_finite : core.

  Fact LI2_rule_l_reif c hs : LI2_rule_l c hs -> { i | LI2_rule_l_map i = (c,hs) }.
  Proof. intros ?; apply rule_reif with (r := LI2_rule_l); auto. Qed.

  Fact LI2_rule_l_dec c hs : { LI2_rule_l c hs } + { ~ LI2_rule_l c hs }.
  Proof. apply rule_dec with (f := LI2_rule_l_map); auto. Qed.

  Fact LI2_rule_l_finite_t c : finite_t (LI2_rule_l c).
  Proof. apply rule_finite_t with (f := LI2_rule_l_map); auto. Qed.

End Left_implication_rule_LI2.

Section Contraction_rule.

  (** Contraction rule for R sequent systems

             A,A,ga |- B
           -------------- [c]
              A,ga |- B

  *)

  Inductive rule_cntr : Seq -> list Seq -> Prop :=
    | in_rule_cntr : forall ga th a b, ga ~p a :: th
                                  -> rule_cntr (ga |-- b) ( (a :: a :: th |-- b) :: nil ).

  Fact rule_cntr_inv c ll : rule_cntr c ll -> exists ga th a b,
                                        ga ~p a :: th
                                     /\ c = (ga |-- b)
                                     /\ ll = ( (a :: a :: th |-- b) :: nil ).
  Proof.
    induction 1 as [ ga th a b H1 ].
    exists ga, th, a, b; auto.
  Qed.

  Definition rule_cntr_inst := { c : list Form * list Form * Form * Form
                                   | match c with (((ga,th),a),_) => ga ~p a::th end }%type.

  Definition rule_cntr_map : rule_cntr_inst -> Seq * list Seq.
  Proof.
    intros ( (((ga,th),a),b) & _ ).
    exact (ga |-- b, (a :: a :: th |-- b) :: nil ).
  Defined.

  Fact rule_cntr_map_prop : soundly_represents rule_cntr rule_cntr_map.
  Proof. intros ( (((ga,th),a),b) & ? ); simpl; constructor; auto. Qed.

  (* We do not need the finiteness of the contraction rule but it is
     used to show reification and decidability *)

  Fact rule_cntr_finite : finitely_represents rule_cntr rule_cntr_map.
  Proof.
    intros (ga,b).
    generalize (pick_finite_t ga); intros (l1 & Hl1).
    set (ll := map (fun d : Form * list Form => let (a,th) := d in (((ga,th),a),b)) l1).
    assert (forall u, In u ll -> match u with (((ga,th),a),b) => ga ~p a::th end) as Hll.
      intros (((ga',th),a),b'); unfold ll; rewrite in_map_iff.
      intros ((a',th') & H1 & H2).
      inversion H1; subst ga' th' a' b'.
      apply Hl1 in H2; auto.

    exists (list_Forall_sig _ _ Hll).
    intros h; split.

    intros H.
    apply rule_cntr_inv in H.
    destruct H as (ga' & th & a & b' & H1 & E & H2).
    inversion E; subst ga' b' h.
    assert (In (((ga,th),a),b) ll) as H3.
      unfold ll; apply in_map_iff.
      exists (a, th); split; simpl; auto.
      apply Hl1; auto.
    generalize (list_Forall_sig_In_refl _ _ Hll _ H3).
    intros H4.
    match goal with [ H : In ?x (list_Forall_sig _ _ _) |- _ ] => exists x end; split; auto.

    intros (((((ga',th),a),b') & H) & H1 & _).
    simpl in H1.
    inversion H1; subst ga' b' h.
    constructor; auto.
  Qed.

  Hint Resolve rule_cntr_map_prop rule_cntr_finite : core.

  Fact rule_cntr_reif c hs : rule_cntr c hs -> { i | rule_cntr_map i = (c,hs) }.
  Proof. intros ?; apply rule_reif with (r := rule_cntr); auto. Qed.

  Fact rule_cntr_dec c hs : { rule_cntr c hs } + { ~ rule_cntr c hs }.
  Proof. apply rule_dec with (f := rule_cntr_map); auto. Qed.

  Fact rule_cntr_finite_t c : finite_t (rule_cntr c).
  Proof. apply rule_finite_t with (f := rule_cntr_map); auto. Qed.

End Contraction_rule.

Section Weakening_rule.

  (** Contraction rule for R sequent systems

                ga |- B
           -------------- [w]
              A,ga |- B

  *)

  Inductive rule_weak : Seq -> list Seq -> Prop :=
    | in_rule_weak : forall ga th a b, ga ~p a :: th
                                  -> rule_weak (ga |-- b) ( (th |-- b) :: nil ).

  Fact rule_weak_inv c ll : rule_weak c ll -> exists ga th a b,
                                        ga ~p a :: th
                                     /\ c = (ga |-- b)
                                     /\ ll = ( (th |-- b) :: nil ).
  Proof.
    induction 1 as [ ga th a b H1 ].
    exists ga, th, a, b; auto.
  Qed.

  Definition rule_weak_inst := { c : list Form * list Form * Form * Form
                                   | match c with (((ga,th),a),_) => ga ~p a::th end }%type.

  Definition rule_weak_map : rule_weak_inst -> Seq * list Seq.
  Proof.
    intros ( (((ga,th),a),b) & _ ).
    exact (ga |-- b, (th |-- b) :: nil ).
  Defined.

  Fact rule_weak_map_prop : soundly_represents rule_weak rule_weak_map.
  Proof. intros ( (((ga,th),a),b) & ? ); simpl; constructor 1 with a; auto. Qed.

  Fact rule_weak_finite : finitely_represents rule_weak rule_weak_map.
  Proof.
    intros (ga,b).
    generalize (pick_finite_t ga); intros (l1 & Hl1).
    set (ll := map (fun d : Form * list Form => let (a,th) := d in (((ga,th),a),b)) l1).
    assert (forall u, In u ll -> match u with (((ga,th),a),b) => ga ~p a::th end) as Hll.
      intros (((ga',th),a),b'); unfold ll; rewrite in_map_iff.
      intros ((a',th') & H1 & H2).
      inversion H1; subst ga' th' a' b'.
      apply Hl1 in H2; auto.

    exists (list_Forall_sig _ _ Hll).
    intros h; split.

    intros H.
    apply rule_weak_inv in H.
    destruct H as (ga' & th & a & b' & H1 & E & H2).
    inversion E; subst ga' b' h.
    assert (In (((ga,th),a),b) ll) as H3.
      unfold ll; apply in_map_iff.
      exists (a, th); split; simpl; auto.
      apply Hl1; auto.
    generalize (list_Forall_sig_In_refl _ _ Hll _ H3).
    intros H4.
    match goal with [ H : In ?x (list_Forall_sig _ _ _) |- _ ] => exists x end; split; auto.

    intros (((((ga',th),a),b') & H) & H1 & _).
    simpl in H1.
    inversion H1; subst ga' b' h.
    constructor 1 with a; auto.
  Qed.

  Hint Resolve rule_weak_map_prop rule_weak_finite : core.

  Fact rule_weak_reif c hs : rule_weak c hs -> { i | rule_weak_map i = (c,hs) }.
  Proof. intros ?; apply rule_reif with (r := rule_weak); auto. Qed.

  Fact rule_weak_dec c hs : { rule_weak c hs } + { ~ rule_weak c hs }.
  Proof. apply rule_dec with (f := rule_weak_map); auto. Qed.

  Fact rule_weak_finite_t c : finite_t (rule_weak c).
  Proof. apply rule_finite_t with (f := rule_weak_map); auto. Qed.

End Weakening_rule.

Section Cut_rule.

  (** Cut rule for R sequent systems

           ga |- A   A,de |- B
         ----------------------- [cut]
                ga,de |- B

  *)

  Inductive rule_cut : Seq -> list Seq -> Prop :=
    | in_rule_cut : forall ga de th a b,    th ~p ga ++ de
                                       -> rule_cut (th |-- b)
                                            ( (ga |-- a) :: (a::de |-- b) :: nil ).

  Fact rule_cut_inv c ll : rule_cut c ll -> exists ga de th a b,
                                            th ~p ga ++ de
                                         /\ c = (th |-- b)
                                         /\ ll = (ga |-- a) :: (a::de |-- b) :: nil.
  Proof.
    induction 1 as [ ga de th a b ].
    exists ga, de, th, a, b; auto.
  Qed.

  (** There is no finiteness result for the cut rule because
     it has an infinite number of instance for a given conclusion
     (there is *free* choice for A)

  *)

  Definition rule_cut_inst := { c : list Form * list Form * list Form * Form * Form
                                   | match c with ((((ga,de),th),a),_) => th ~p ga++de end }%type.

  Definition rule_cut_map : rule_cut_inst -> Seq * list Seq.
  Proof.
    intros (((((ga,de),th),a),b) & _).
    split.
    exact (th |-- b).
    exact ((ga |-- a) :: (a::de |-- b) :: nil).
  Defined.

  Fact rule_cut_map_prop : soundly_represents rule_cut rule_cut_map.
  Proof. intros (((((ga,de),th),a),b) & H); simpl; constructor; auto. Qed.

  Fact rule_cut_reif c hs : rule_cut c hs -> { i | rule_cut_map i = (c,hs) }.
  Proof.
    intros H.
    destruct c as (th,b).
    destruct hs as [ | (ga,a) [ | ([ | a' de ],c) [ | y hs ] ]]; try (exfalso; inversion H; fail).
    assert (th ~p ga ++ de /\ a = a' /\ b = c) as E.
      apply rule_cut_inv in H.
      destruct H as (ga' & de' & th' & a'' & b' & ? & E1 & E2).
      inversion E1; inversion E2; subst; auto.
    destruct E as (E & ? & ?); subst a' c.
    exists (exist _ ((((ga,de),th),a),b) E); simpl; auto.
  Qed.

  Fact rule_cut_dec c hs : { rule_cut c hs } + { ~ rule_cut c hs }.
  Proof.
    destruct c as (th,b).
    destruct hs as [ | (ga,a) [ | ([ | a' de ],c) [ | y hs ] ]];
      try (right; inversion 1; fail).
    destruct (Form_eq_dec a a') as [ | C ].
    2: right; contradict C; inversion C; auto.
    subst a'.
    destruct (Form_eq_dec b c) as  [ | C ].
    2: right; contradict C; inversion C; auto.
    subst c.
    destruct (Permutation_dec Form_eq_dec th (ga++de)) as [ H | C ].
    2: right; contradict C; inversion C; auto.
    left; constructor 1 with (1 := H).
  Qed.

End Cut_rule.

Local Notation LR2c := (@LR2c _ Form_eq_dec).

Section Left_implication_rule_LR2.

  (** Left implication rule for LR2 with implicit but strictly
      controlled contraction

             ga |- A     B,de |- C
           ------------------------- [l]
                     th |- C

      where th is a contraction of A%>B,ga,de but not ANY
      contraction. Contractions are tightly controlled in
      this rule.

  *)

  Inductive LR2_rule_l : Seq -> list Seq -> Prop :=
    | in_LR2_l : forall ga de th th' a b x,
                                 th ~p (a %> b) :: th'
                              -> LR2c (a %> b) ga de th'
                              -> LR2_rule_l (th |-- x)
                                        ( (ga |-- a) :: (b::de |-- x) :: nil ).

  Fact LR2_rule_l_inv c ll : LR2_rule_l c ll -> exists ga de th th' a b x,
                                                th ~p (a %> b) :: th'
                                             /\ LR2c (a %> b) ga de th'
                                             /\ c = (th |-- x)
                                             /\ ll = (ga |-- a) :: (b::de |-- x) :: nil.
  Proof.
    induction 1 as [ ga de th th' a b x H1 H2 ].
    exists ga, de, th, th', a, b, x; auto.
  Qed.

  Fact sf_LR2_rule_l c ll : LR2_rule_l c ll -> Forall (sf c) ll.
  Proof.
    induction 1 as [ ga de th th' a b x H2 H3 ].
    constructor; [ | constructor; [ | constructor ] ].
    + intros u [ (y & H4 & H5) | Hy ].
      apply LR2c_prop1 with (1 := H3) in H4.
      destruct H4 as [ H4 | H4 ].
      subst y.
      left; exists (a %> b); split; auto.
      apply Permutation_in with (1 := Permutation_sym H2).
      left; auto.
      left; exists y; split; auto.
      apply Permutation_in with (1 := Permutation_sym H2).
      simpl; auto.
      left; exists (a %> b); split.
      apply Permutation_in with (1 := Permutation_sym H2).
      left; auto.
      right; tauto.
    + intros u [ (y & H4 & H5) | Hy ].
      destruct H4 as [ ? | H4 ].
      subst y.
      left; exists (a %> b); split.
      apply Permutation_in with (1 := Permutation_sym H2).
      left; auto.
      right; tauto.
      apply LR2c_prop2 with (1 := H3) in H4.
      destruct H4 as [ H4 | H4 ].
      subst y.
      left; exists (a %> b); split; auto.
      apply Permutation_in with (1 := Permutation_sym H2).
      left; auto.
      left; exists y; split; auto.
      apply Permutation_in with (1 := Permutation_sym H2).
      simpl; auto.
      right; auto.
  Qed.

  Definition LR2_rule_l_inst := { c : list Form * list Form * list Form * list Form * Form * Form * Form
                                    | match c with ((((((ga,de),th), th'),a),b),x)
                                                 => th ~p (a %> b) :: th'
                                                 /\ LR2c (a %> b) ga de th'
                                      end }%type.

  Definition LR2_rule_l_map : LR2_rule_l_inst -> Seq * list Seq.
  Proof.
    intros ( ((((((ga,de),th),th'),a),b),x) & _ ).
    exact (th |-- x , ( (ga |-- a) :: (b :: de |-- x) :: nil ) ).
  Defined.

  Fact LR2_rule_l_map_prop : soundly_represents LR2_rule_l LR2_rule_l_map.
  Proof.
    intros ( ((((((ga,de),th),th'),a),b),x) & H1 & H2 ); simpl.
    constructor 1 with th'; auto.
  Qed.

  Fact LR2_rule_l_finite : finitely_represents LR2_rule_l LR2_rule_l_map.
  Proof.
    intros (th,x).
    generalize (pick_finite_t th); intros (l1 & Hl1).
    set (ll := flat_map (fun u => match u with
                          | (£ _,_) => nil
                          | (a %> b,th') => let mm := proj1_sig (LR2c_finite_t Form_eq_dec (a %> b) th')
                                            in map (fun d : _ * _=> let (ga,de) := d in ((((((ga,de),th),th'),a),b),x)) mm
                        end) l1).
    assert (forall u, In u ll -> match u with ((((((ga,de),th),th'),a),b),x)
                                           => th ~p (a %> b) :: th'
                                           /\ LR2c (a %> b) ga de th'
                                 end) as Hll.
    { intros ((((((ga,de),th'),th''),a),b),x'); unfold ll; rewrite in_flat_map.
      intros (([ | a' b' ],p) & H1 & H2).
      + destruct H2.
      + apply in_map_iff in H2.
        destruct H2 as ((ga',de') & E & H3).
        inversion E; subst ga' de' th' th'' a' b' x'.
        apply (proj2_sig (LR2c_finite_t Form_eq_dec (a %> b) p)) in H3.
        apply Hl1 in H1.
        split; auto. }
    exists (list_Forall_sig _ _ Hll).
    intros h; split.
    + intros H.
      apply LR2_rule_l_inv in H.
      destruct H as (ga & de & th' & th'' & a & b & x' & H0 & H1 & E & H2).
      inversion E; subst th' x' h.
      assert (In ((((((ga,de),th),th''),a),b),x) ll) as H3.
        unfold ll; apply in_flat_map.
      exists (a %> b, th''); split; simpl; auto.
      apply Hl1; auto.
      apply in_map_iff.
      exists (ga, de); split; auto.
      apply (proj2_sig (LR2c_finite_t Form_eq_dec (a %> b) th'')).
      revert H1; apply LR2c_perm_3; auto.
      generalize (list_Forall_sig_In_refl _ _ Hll _ H3).
      intros H4.
      match goal with [ H : In ?x _ |- _ ] => exists x end; split; auto.
    + intros ((((((((ga,de),th'),th''),a),b),x') & H2 & H3) & H1 & _).
      simpl in H1.
      inversion H1; subst th' x' h.
      constructor 1 with th''; auto.
  Qed.

  Hint Resolve LR2_rule_l_map_prop LR2_rule_l_finite : core.

  Fact LR2_rule_l_reif c hs : LR2_rule_l c hs -> { i | LR2_rule_l_map i = (c,hs) }.
  Proof. intros ?; apply rule_reif with (r := LR2_rule_l); auto. Qed.

  Fact LR2_rule_l_dec c hs : { LR2_rule_l c hs } + { ~ LR2_rule_l c hs }.
  Proof. apply rule_dec with (f := LR2_rule_l_map); auto. Qed.

  Fact LR2_rule_l_finite_t c : finite_t (LR2_rule_l c).
  Proof. apply rule_finite_t with (f := LR2_rule_l_map); auto. Qed.

End Left_implication_rule_LR2.

Section Usable_rules.

  (* Now some more usable forms of LR{1,2} rules *)

  Implicit Type rules : Seq -> list Seq -> Prop.

  Fact rules_id rules :
         rule_id inc2 rules
      -> forall a n, bproof rules (S n) (a::nil |-- a) (in_tree (a::nil |-- a) nil).
  Proof.
    intros H a n.
    rewrite bproof_S; repeat split.
    apply H.
    constructor.
    constructor.
  Qed.

  Fact rules_ax rules :
         rule_ax inc2 rules
      -> forall l a r n, bproof rules (S n) (l++a::r |-- a) (in_tree (l++a::r |-- a) nil).
  Proof.
    intros H l a r n.
    rewrite bproof_S; repeat split.
    apply H.
    constructor.
    constructor.
  Qed.

  Fact LR_rules_imp_r rules :
         LR_rule_r inc2 rules
      -> forall n ga a b t,
               bproof rules n (a::ga |-- b) t
            -> bproof rules (S n) (ga |-- a %> b) (in_tree (ga |-- a %> b) (t::nil)).
  Proof.
    intros H n ga a b t H2.
    rewrite bproof_S; repeat split.
    apply H.
    unfold proof_sub; simpl.
    destruct H2 as ((H2 & H3) & H4).
    rewrite H3.
    constructor; auto.
    constructor.
    revert H2; apply bproof_root.
    constructor.
  Qed.

  Fact LR_rules_imp_l rules :
         LR_rule_l inc2 rules
      -> forall n ga de th a b x ta tx,
                                 th ~p (a %> b) :: ga ++ de
                              -> bproof rules n (ga     |-- a) ta
                              -> bproof rules n (b::de  |-- x) tx
                              -> bproof rules (S n) (th |-- x) (in_tree (th |-- x) (ta::tx::nil)).
  Proof.
    intros H0 n ga de th a b x ta tx H1 H3 H4.
    rewrite bproof_S; repeat split.
    unfold proof_sub; simpl.
    apply H0.
    destruct H3 as ((_ & H3) & _); rewrite H3.
    destruct H4 as ((_ & H4) & _); rewrite H4.
    apply in_LR_l with (1 := H1); auto.
    constructor.
    revert H3; apply bproof_root.
    constructor.
    revert H4; apply bproof_root.
    constructor.
  Qed.

  Fact LI2_rules_imp_l rules :
         LI2_rule_l inc2 rules
      -> forall n ga th a b x ta tx,
                                 th ~p (a %> b) :: ga
                              -> bproof rules n (a %> b :: ga |-- a) ta
                              -> bproof rules n (a %> b :: b::ga  |-- x) tx
                              -> bproof rules (S n) (th |-- x) (in_tree (th |-- x) (ta::tx::nil)).
  Proof.
    intros H0 n ga th a b x ta tx H1 H3 H4.
    rewrite bproof_S; repeat split.
    unfold proof_sub; simpl.
    apply H0.
    destruct H3 as ((_ & H3) & _); rewrite H3.
    destruct H4 as ((_ & H4) & _); rewrite H4.
    apply in_LI2_l with (1 := H1); auto.
    constructor.
    revert H3; apply bproof_root.
    constructor.
    revert H4; apply bproof_root.
    constructor.
  Qed.

  Fact LR2_rules_imp_l rules :
       LR2_rule_l inc2 rules
    -> forall n ga de th th' a b x tg td,
                                 th ~p (a %> b) :: th'
                              -> LR2c (a %> b) ga de th'
                              -> bproof rules n (ga     |-- a) tg
                              -> bproof rules n (b::de  |-- x) td
                              -> bproof rules (S n) (th |-- x) (in_tree (th |-- x) (tg::td::nil)).
  Proof.
    intros H0 n ga de th th' a b x ta td H1 H2 H3 H4.
    rewrite bproof_S; repeat split.
    unfold proof_sub; simpl.
    apply H0.
    destruct H3 as ((_ & H3) & _); rewrite H3.
    destruct H4 as ((_ & H4) & _); rewrite H4.
    apply in_LR2_l with (1 := H1); auto.
    constructor.
    revert H3; apply bproof_root.
    constructor.
    revert H4; apply bproof_root.
    constructor.
  Qed.

  Fact rules_cntr rules :
         rule_cntr inc2 rules
      -> forall n ga th x a t,
         ga ~p x :: th
      -> bproof rules n (x::x::th |-- a) t
      -> bproof rules (S n) (ga |-- a) (in_tree (ga |-- a) (t::nil)).
  Proof.
    intros H0 n ga th x a t H2 H3.
    rewrite bproof_S; repeat split.
    unfold proof_sub; simpl.
    apply H0.
    destruct H3 as ((_ & H3) & _); rewrite H3.
    apply in_rule_cntr; auto.
    constructor.
    revert H3; apply bproof_root.
    constructor.
  Qed.

  Fact rules_weak rules :
         rule_weak inc2 rules
      -> forall n ga th x a t,
         ga ~p x :: th
      -> bproof rules n (th |-- a) t
      -> bproof rules (S n) (ga |-- a) (in_tree (ga |-- a) (t::nil)).
  Proof.
    intros H0 n ga th x a t H2 H3.
    rewrite bproof_S; repeat split.
    unfold proof_sub; simpl.
    apply H0.
    destruct H3 as ((_ & H3) & _); rewrite H3.
    apply in_rule_weak with x; auto.
    constructor.
    revert H3; apply bproof_root.
    constructor.
  Qed.

  Fact rules_cut rules :
         rule_cut inc2 rules
      -> forall n ga de th a b ta tb,
         th ~p ga ++ de
      -> bproof rules n (ga |-- a) ta
      -> bproof rules n (a::de |-- b) tb
      -> bproof rules (S n) (th |-- b) (in_tree (th |-- b) (ta::tb::nil)).
  Proof.
    intros H0 n ga de th a b ta tb H1 H2 H3.
    rewrite bproof_S; repeat split.
    unfold proof_sub; simpl.
    apply H0.
    destruct H2 as ((_ & H2) & _); rewrite H2.
    destruct H3 as ((_ & H3) & _); rewrite H3.
    apply in_rule_cut; auto.
    constructor.
    revert H2; apply bproof_root.
    constructor.
    revert H3; apply bproof_root.
    constructor.
  Qed.

End Usable_rules.


Require Import
  Coq.Unicode.Utf8
  Coq.Lists.List.

From Equations Require Export Equations.

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

Set Equations With UIP.

Generalizable All Variables.
Set Primitive Projections.

Import ListNotations.

Section ilist.

Context {A : Type}.

Variable B : A → Type.

Fixpoint ilist (l : list A) : Type :=
  match l with
  | []      => unit
  | x :: xs => B x * ilist xs
  end.

Equations iapp `(xs : ilist l) `(ys : ilist l') : ilist (l ++ l') :=
  iapp (l:=[]) tt ys := ys;
  iapp (x, xs) ys := (x, iapp xs ys).

Equations isplit `(xs : ilist (l ++ l')) : ilist l * ilist l'  :=
  isplit (l:=[]) xs := (tt, xs);
  isplit (x, xs) with isplit xs := {
    | (xs', ys) => ((x, xs'), ys)
  }.

Equations ilist_ind (P : ∀ (l : list A), ilist l → Prop)
          (Pinil : P [] tt)
          (Picons : ∀ (a : A) (b : B a) (l : list A) (il : ilist l),
              P l il → P (a :: l) (b, il))
          (l : list A) (il : ilist l) : P l il :=
  ilist_ind Pinil Picons (l:=[]) tt := Pinil;
  ilist_ind Pinil Picons (l:=a :: l) (b, il) :=
    Picons a b l il (ilist_ind Pinil Picons il).

Equations ilist_rect (P : ∀ (l : list A), ilist l → Type)
          (Pinil : P [] tt)
          (Picons : ∀ (a : A) (b : B a) (l : list A) (il : ilist l),
              P l il → P (a :: l) (b, il))
          (l : list A) (il : ilist l) : P l il :=
  ilist_rect Pinil Picons (l:=[]) tt := Pinil;
  ilist_rect Pinil Picons (l:=a :: l) (b, il) :=
    Picons a b l il (ilist_rect Pinil Picons il).

End ilist.


(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice.
From mathcomp Require Import fintype div bigop finset ssralg finalg binomial.
From mathcomp Require Import poly polydiv cyclic perm finfun matrix mxpoly.
Require Import ssr_ext ssralg_ext cyclic_code dft.

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

Import GRing.Theory.
Local Open Scope ring_scope.

(** * Error-locator, error-evaluator, and syndrome polynomials *)

(** OUTLINE:
- Section error_locator_polynomial.
- Section error_evaluator_polynomial_def.
- Section error_evaluator_polynomial_prop.
- Section characterization_of_error_vector.
- Section syndrome_polynomial.
- Section twisted_error_pattern.
- Section syndromep_prop.
*)

(* TODO: move to poly_ext? *)
Lemma modp_Xn (R : idomainType) j (p : {poly R}) i :
  i <= j -> size (p %% 'X^j) <= i -> p %% 'X^i = p %% 'X^j.
Proof.
move=> ij H0.
have H : forall n, lead_coef 'X^n \is a GRing.unit
  by move=> ??; rewrite lead_coefXn GRing.unitr1.
rewrite (Pdiv.IdomainUnit.divp_eq (H R j) p).
rewrite (Pdiv.IdomainUnit.modp_add (H R i)).
rewrite modp_eq0; last by rewrite dvdp_mull // dvdp_exp2l.
by rewrite add0r -(Pdiv.IdomainUnit.divp_eq (H R j) p) modp_small // size_polyXn.
Qed.

(* TODO: useful? *)
Lemma size_one_minus_X (R : idomainType) (a : R) (a0 : a != 0) :
  size (1 - a *: 'X) = 2.
Proof.
rewrite addrC size_addl.
  by rewrite size_opp size_scale ?size_polyX // expf_neq0.
by rewrite size_opp size_scale ?expf_neq0 // size_polyX size_polyC oner_eq0.
Qed.

Lemma one_minus_X_neq0 (R : idomainType) (a : R) : 1 - a *: 'X != 0.
Proof.
rewrite subr_eq0; apply/eqP => /(congr1 (fun x => x.[0])).
rewrite !hornerE; apply/eqP; by rewrite oner_eq0.
Qed.

(* NB: not used *)
Section error_locator_polynomial_alt.

Variables (F : fieldType) (n : nat) (a : {ffun 'I_n -> F}).

Definition errloc_alt (E : {set 'I_n}) : {poly F} :=
  \prod_(i in E) ('X - (a i)%:P).

End error_locator_polynomial_alt.

Local Open Scope vec_ext_scope.

Section distinct_non_zero.

Variables (F : fieldType) (n : nat).

Definition distinct_non_zero (a : 'rV[F]_n) :=
  injective [ffun i => a ``_i] /\ (forall i, a ``_ i != 0).

Lemma distinct_non_zero_rVexp (a : F) (a0 : a != 0) (H : not_uroot_on a n) :
  distinct_non_zero (rVexp a n).
Proof.
rewrite /distinct_non_zero; split; first by apply rVexp_inj.
move=> ?; by rewrite mxE expf_neq0.
Qed.

End distinct_non_zero.

Section error_locator_polynomial.

Variables (F : fieldType) (n : nat).

Definition errloc (a : 'rV[F]_n) (E : {set 'I_n}) : {poly F} :=
  \prod_(i in E) (1 - a ``_ i *: 'X).

Lemma errloc0 (a : 'rV[F]_n) : errloc a set0 = 1.
Proof. by rewrite /errloc big_set0. Qed.

Lemma horner_errloc_0 (a : 'rV[F]_n) E : (errloc a E).[0] = 1.
Proof.
rewrite /errloc horner_prod (eq_bigr (fun=> 1)) ?big1_eq //.
by move=> /= j _; rewrite !hornerE subr0.
Qed.

Lemma derive_errloc (a : 'rV[F]_n) E : (errloc a E)^`() =
  \sum_(j in E) - a ``_ j *: \prod_(k in E :\ j) (1 - a ``_ k *: 'X).
Proof.
move Hm : (#| E |) => m.
elim: m E Hm => [E /eqP| m IH E Em].
  rewrite cards_eq0 => /eqP ->; by rewrite /errloc 2!big_set0 derivC.
have [/= f Hf] : exists f, f \in E by apply/set0Pn; rewrite -cards_eq0 Em.
rewrite /errloc (big_setD1 f) //= derivM IH; last first.
  move: (cardsD1 f E); rewrite Hf /= add1n Em; by case.
rewrite derivB derivC sub0r linearZ /= derivX.
rewrite [in RHS](big_setD1 f) //=; congr (_ + _).
  by rewrite alg_polyC -mul_polyC polyC_opp.
rewrite big_distrr /=; apply eq_bigr => i Hi.
rewrite mulrC -!mul_polyC -mulrA; congr (_ * _).
rewrite [in RHS](big_setD1 f) //=; last first.
  rewrite in_setD1; by move: Hi; rewrite in_setD1 eq_sym => /andP [] ->.
rewrite mulrC mul_polyC; congr (_ * _).
apply eq_bigl => ?; rewrite !in_setD1; bool_congr.
Qed.

Lemma decomp_errloc (a :'rV[F]_n) E : (forall i, a ``_ i != 0) ->
  errloc a E = (\prod_(i in E) (- a ``_ i)%:P) * \prod_(i in E) ('X - (a ``_ i)^-1%:P).
Proof.
move=> a0.
rewrite /errloc (eq_bigr (fun i : 'I_n => (- a ``_ i)%:P * ('X - (a ``_ i)^-1%:P))).
  by rewrite big_split.
move=> i Hi.
rewrite -polyC_opp mulrDr -polyC_mul mulrNN divff //.
by rewrite polyC1 -(addrC 1) polyC_opp mulNr mul_polyC.
Qed.

Lemma errloc_neq0 a E : errloc a E != 0.
Proof. apply/prodf_neq0 => /= i _; by rewrite one_minus_X_neq0. Qed.

Lemma size_errloc a E : size (errloc a E) <= #| E |.+1.
Proof.
apply: (leq_trans (size_prod_leq (fun x => x \in E) (fun i => 1 - a ``_ i *: 'X))).
apply (@leq_trans (#|E|.*2.+1 - #|E|)); last first.
  by rewrite subSn -addnn ?leq_addr // addnK.
rewrite leq_sub // ltnS.
apply (@leq_trans (\sum_(i in E) 2)); last by rewrite big_const iter_addn_0 mul2n.
apply leq_sum => /= i iE.
case/boolP : (a ``_ i == 0) => [/eqP ->|ai0].
  by rewrite scale0r subr0 size_poly1.
by rewrite size_one_minus_X.
Qed.

Lemma errloc_zero (a : 'rV[F]_n) E (i : 'I_n) : distinct_non_zero a ->
  ((errloc a E).[(a ``_ i)^-1] == 0) = (i \in E).
Proof.
move=> Ha; apply/idP/idP => H.
- apply/negPn/negP => abs; move/eqP: H.
  apply/rootP.
  rewrite (decomp_errloc _ (proj2 Ha)) ?unitfE //= rootM negb_or.
  apply/andP; split.
    rewrite -(@big_morph _ _ _ _ _ 1 _ (@polyC_mul F)) // rootC prodf_seq_neq0 /=.
    apply/allP => n0 _.
    apply/implyP => _; by rewrite oppr_eq0 (proj2 Ha).
  move: (root_prod_XsubC [seq (a ``_ x)^-1 | x : 'I_n <- enum E] (a ``_ i)^-1).
  rewrite big_map -[in X in _ -> X]big_filter => ->.
  apply: contra abs.
  case/mapP => /= j Hj /invr_inj aij.
  move: (proj1 Ha) => /(_ i j); rewrite 2!ffunE => /(_ aij) ->.
  by rewrite -mem_enum.
- rewrite /errloc horner_prod prodf_seq_eq0.
  apply/hasP; exists i => //.
  rewrite H /= !hornerE divff ?(proj2 Ha) ?subrr // expf_neq0.
Qed.

Lemma size_errloc_eq a E : distinct_non_zero a -> size (errloc a E) = #| E |.+1.
Proof.
move=> Ha.
rewrite /errloc.
rewrite (eq_bigr (fun i : 'I_n => (- a ``_ i *: ('X - (a ``_ i)^-1%:P)))); last first.
  move=> i iE.
  rewrite scalerDr addrC !scaleNr scalerN opprK; congr (_ + _).
  rewrite -mul_polyC -!alg_polyC mulr_algl scalerA.
  rewrite divrr // ?alg_polyC // unitfE.
  by case: Ha => _; apply.
rewrite scaler_prod size_scale; last first.
  apply/prodf_neq0 => i iE; by rewrite oppr_eq0 (proj2 Ha).
rewrite (_ : \prod_(i in E) ('X - (a ``_ i)^-1%:P) =
  \prod_(i <- enum E) ('X - (a ``_ i)^-1%:P)); last by rewrite big_filter.
by rewrite size_prod_XsubC cardE.
Qed.

End error_locator_polynomial.

(** the locator polynomial for e *)
Notation "'\sigma_(' a , e )" := (errloc a (supp e)) (at level 3).

(** the ith punctured locator polynomial for e *)
Notation "'\sigma_(' a , e , i )" := (errloc a (supp e :\ i)) (at level 3).

Lemma errloc_puncture (F : fieldType) n (f : 'rV[F]_n) (y : 'rV[F]_n) i :
  i \in supp y -> \sigma_(f, y) = (1 - f ``_ i *: 'X ) * \sigma_(f, y, i).
Proof.
move=> ?; rewrite {1}/errloc (bigD1 i) //=; congr (_ * _).
by apply eq_bigl => j; rewrite in_setD1 andbC.
Qed.

Record errvec n (F : fieldType) t := Errvec {
  errvect :> 'rV[F]_n ;
  errsupp : #| supp errvect | <= t }.

Notation "t '.-'rV[' R ]_ n" := (@errvec n R t) (only parsing, at level 2).

Lemma supp_neq0 n (F : fieldType) t (e : t.-'rV[F]_n) : supp e != set0 -> t != O.
Proof.
apply: contra => /eqP t0; case: e => /= e; by rewrite t0 leqn0 -cards_eq0.
Qed.

Section error_evaluator_polynomial_def.

Variables (F : fieldType) (n : nat).

Definition erreval (b a : 'rV[F]_n) e :=
  \sum_(i in supp e) e ``_ i * b ``_ i *: \sigma_(a, e, i).

End error_evaluator_polynomial_def.

Notation "'\omega_(' f , a , e )" := (erreval f a e) (at level 3).

Section error_evaluator_polynomial_prop.

Variables (F : fieldType) (n : nat) (a : 'rV[F]_n).
Variables (t : nat) (e : t.-'rV[F]_n).
Variables (f : 'rV[F]_n).

Lemma size_erreval : size \omega_(f, a, e) <= t.
Proof.
eapply leq_trans; first by apply size_sum.
apply/bigmax_leqP => i; rewrite inE => /= iE.
eapply leq_trans; first by rewrite -mul_polyC; apply size_mul_leq.
rewrite size_polyC.
apply (@leq_trans (1 + size \sigma_( a, e, i)).-1).
  rewrite add1n /= addnC; case: (_ != _) => //=.
  by rewrite addn1.
  by rewrite addn0 leq_pred.
rewrite add1n /= (leq_trans (size_errloc _ _)) //.
rewrite (_ : #|_| = #|supp e|.-1); last by rewrite (cardsD1 i (supp e)) inE /= iE.
rewrite -insupp in iE.
rewrite prednK // ?(errsupp e) // lt0n cards_eq0; by apply/set0Pn; exists i.
Qed.

Hypothesis Ha : distinct_non_zero a.
Hypothesis Hf : forall i, f ``_ i != 0.

Lemma coprime_errloc_erreval E : coprimep \sigma_(a, E) \omega_(f, a, E).
Proof.
apply/coprimepP => p p_sigma p_eta.
suff no_root_p : forall x, root p x -> False.
  move : p_sigma; rewrite (decomp_errloc _ (proj2 Ha)) //.
  move/(dvdp_mull (\prod_(i in supp E) (- a ``_ i)^-1%:P)).
  rewrite mulrA -big_split /= (eq_bigr (fun=> 1%:P)); last first.
    move=> i _; by rewrite -polyC_mul mulVr // unitrN unitfE (proj2 Ha).
  rewrite big1 // mul1r -big_filter; case/dvdp_prod_XsubC => bs.
  set mask_bs := mask bs _.
  case size_bsE : (size mask_bs).
    move: size_bsE => /size0nil ->; by rewrite big_nil.
  have : 0 < size mask_bs by rewrite size_bsE.
  rewrite -has_predT => /hasP [/= i i_mask_bs] _ => p_prod.
  suff : root (\prod_(j <- mask_bs) ('X - (a ``_ j)^-1%:P)) (a ``_ i)^-1.
    rewrite -(eqp_root p_prod); by move/no_root_p.
  rewrite (@big_morph _ _ (fun p => root p (a ``_ i)^-1) false orb); last 2 first.
    move=> ? ?; by rewrite rootM.
    by apply/negP/negP/root1.
  rewrite big_has /=; apply/hasP; exists i => //; by rewrite root_XsubC.
move=> x px.
have [n0 [n0e xan0]] : exists n0, n0 \in supp E /\ x = (a ``_ n0)^-1.
  have : root \sigma_(a, E) x.
    rewrite -dvdp_XsubCl; apply: dvdp_trans p_sigma; by rewrite dvdp_XsubCl.
  rewrite /root (decomp_errloc _ (proj2 Ha)) hornerM mulf_eq0; case/orP.
  - rewrite horner_prod; case/prodf_eq0 => n0 n0e.
    by rewrite !hornerE oppr_eq0 (negPf (proj2 Ha n0)).
  - rewrite horner_prod; case/prodf_eq0 => n0 n0e.
    rewrite !hornerE subr_eq0 => /eqP ->; by exists n0.
rewrite {x}xan0 in px.
have {px} : root \omega_(f, a, E) (a ``_ n0)^-1.
  rewrite -dvdp_XsubCl; apply: dvdp_trans p_eta; by rewrite dvdp_XsubCl.
rewrite /root horner_sum (bigD1 _ n0e) /=.
set q := (X in _ + X == 0 -> _).
have {q}-> : q = 0.
  rewrite {}/q (eq_bigr (fun=> 0)); first by rewrite big_const /= iter_addr0.
  move=> i /andP[ie in0].
  rewrite !hornerE /= horner_prod (bigD1 n0) /=; last first.
    by rewrite in_setD1 n0e eq_sym andbT.
  by rewrite !hornerE /= divrr ?unitfE ?(proj2 Ha) // subrr mulr0 mul0r.
rewrite addr0 !hornerE /= mulf_eq0; case/orP.
- rewrite mulf_eq0 (negbTE (Hf _)) orbF.
  by move: n0e; rewrite inE /= => /negbTE ->.
- by rewrite errloc_zero // in_setD1 eqxx.
Qed.

Lemma erreval0 : \omega_(f, a, (0 : 'rV_n)) = 0.
Proof. by rewrite /erreval supp0 big_set0. Qed.

End error_evaluator_polynomial_prop.

Section characterization_of_error_vector.

Variables (F : fieldType) (n : nat) (e : 'rV[F]_n).
Variable a : 'rV[F]_n.
Hypothesis Ha : distinct_non_zero a.
Variable f : 'rV[F]_n.

Lemma erreval_vecE i : i \in supp e ->
  e ``_ i * f ``_ i = - a ``_ i *
    \omega_(f, a, e).[(a ``_ i)^-1] / \sigma_(a, e)^`().[(a ``_ i)^-1].
Proof.
move=> iE.
have morph_horner_add : {morph (fun x => x.[(a ``_ i)^-1]) : x y / x + y >-> x + y}.
  move=> x y; exact: hornerD.
have morph_horner_mul : {morph (fun x => x.[(a ``_ i)^-1]) : x y / x * y >-> x * y}.
  move=> x y; exact: hornerM.
have -> : \omega_(f, a, e).[(a ``_ i)^-1] =
    e ``_ i * f ``_ i * \prod_(j in supp e :\ i) (1 - a ``_ j * (a ``_ i)^-1).
  rewrite (@big_morph _ _ _ 0 _ _ _ morph_horner_add); last by rewrite horner0.
  rewrite [in LHS](big_setD1 i) //= [X in _ + X = _](_ :_  = 0); last first.
    rewrite (eq_bigr (fun=> 0)); first by rewrite big_const iter_addr0.
    move=> j Hj.
    rewrite !hornerE /= (@big_morph _ _ _ 1 _ _ _ morph_horner_mul); last by rewrite hornerE.
    rewrite (big_setD1 i) /=; last first.
      rewrite !inE eq_sym in Hj.
      rewrite !inE.
      case/andP : Hj => /= ->.
      by rewrite insupp in iE.
    by rewrite !hornerE /= divrr ?unitfE ?(proj2 Ha) // ?Ht' // subrr mulr0 mul0r.
  rewrite addr0 !hornerE /=; congr (_ * _).
  rewrite (@big_morph _ _ _ 1 _ _ _ morph_horner_mul); last by rewrite hornerE.
  apply eq_bigr => ? ?; by rewrite !hornerE.
have -> : (\sigma_(a, e)^`()).[(a ``_ i)^-1] = - a ``_ i *
  \prod_(j in supp e :\ i) (1 - a ``_ j * (a ``_ i)^-1).
  rewrite derive_errloc (@big_morph _ _ _ 0 _ _ _ morph_horner_add); last by rewrite horner0.
  rewrite [in LHS](big_setD1 i) //= [X in _ + X = _](_ :_  = 0); last first.
    rewrite (eq_bigr (fun=> 0)); first by rewrite big_const iter_addr0.
    move=> j Hj.
    rewrite !hornerE /= (@big_morph _ _ _ 1 _ _ _ morph_horner_mul); last by rewrite hornerE.
    rewrite (big_setD1 i) /=; last first.
      rewrite !inE; move: Hj.
      rewrite !inE eq_sym => /andP[-> /=].
      by rewrite insupp in iE.
    by rewrite !hornerE /= divrr ?unitfE ?(proj2 Ha) // ?Ht' // subrr mulr0 mul0r.
  rewrite addr0 !hornerE /=; congr (_ * _).
  rewrite (@big_morph _ _ _ 1 _ _ _ morph_horner_mul); last by rewrite hornerE.
  apply eq_bigr => ? ?; by rewrite !hornerE.
rewrite mulrCA mulrK // unitrM unitrN unitfE (proj2 Ha) /=.
apply big_ind.
- by rewrite unitr1.
- by move=> x y; rewrite unitrM => -> ->.
- move=> j Hj; rewrite GRing.unitfE.
  suff : a ``_ j / a ``_ i != 1.
    by apply: contra => /eqP /(congr1 (fun x => x + a ``_ j / a ``_ i)); rewrite subrK add0r => <-.
  apply/eqP => /(congr1 (fun x => x * a ``_ i)).
  rewrite -mulrA mulVr ?unitfE ?(proj2 Ha) ?expf_neq0 // mulr1 mul1r.
  move: (proj1 Ha) => /(_ j i); rewrite 2!ffunE => aij.
  move/aij => ij; subst j.
  move: Hj; by rewrite in_setD1 eqxx.
Qed.

End characterization_of_error_vector.

Require Import linearcode.

Local Open Scope dft_scope.

Section syndrome_polynomial.

Variables (F : fieldType) (n' : nat).
Let n := n'.+1.
Implicit Types a : 'rV[F]_n.

(* polynomial of degree <= t.-1 *)
Definition syndromep a y t := \poly_(k < t) y ^`_(a, inord k.+1).

Variable a :'rV[F]_n.
Variable t : nat.

Lemma syndromepE y : syndromep a y t =
  \sum_(j in supp y) \sum_(i < t) (y ``_ j * a ``_ (inord i.+1) ^+ j) *: 'X^i.
Proof.
rewrite /syndromep exchange_big /= poly_def; apply/eq_bigr => i _; rewrite /fdcoor horner_poly.
rewrite (bigID (fun i => i \in supp y)) /= -[RHS]addr0 scalerDl; congr (_ + _).
  rewrite scaler_suml; apply/eq_bigr => j Hj.
  rewrite insubT // => H; congr ((y ord0 _ * _) *: _); by apply val_inj.
apply/eqP; rewrite scaler_eq0 (eq_bigr (fun=> 0)) ?big_const ?iter_addr0 ?eqxx //.
move=> j Hj; rewrite insubT // => H; rewrite (_ : Sub _ _ = j); last by apply/val_inj.
move: Hj; rewrite inE negbK => /eqP ->; by rewrite mul0r.
Qed.

Lemma size_syndromep y : size (syndromep a y t) <= t.
Proof.
rewrite /syndromep poly_def (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP => i _.
case/boolP : (fdcoor a y (inord i.+1) == 0) => [/eqP -> | ?].
- by rewrite scale0r size_poly0.
- by rewrite size_scale // size_polyXn.
Qed.

Lemma syndromepD x y : syndromep a (x + y) t = syndromep a x t + syndromep a y t.
Proof.
rewrite /syndromep !poly_def -big_split /=; apply/eq_bigr => i _.
by rewrite fdcoorD scalerDl.
Qed.

Lemma syndromepB x y : syndromep a (x - y) t = syndromep a x t - syndromep a y t.
Proof.
rewrite /syndromep !poly_def -sumrB /=; apply/eq_bigr => i _; by rewrite fdcoorB scalerBl.
Qed.

Lemma syndromep0 : syndromep a 0 t = 0.
Proof.
rewrite /syndromep !poly_def big1 // => /= i _; by rewrite fdcoor0 scale0r.
Qed.

End syndrome_polynomial.

Section twisted_error_pattern.

Variables (F : fieldType) (a : F) (n : nat).

(* twisted error pattern; see [McEliece 2002] p. 243 (def 9.36), p. 259 *)
Definition twisted (y : 'rV[F]_n) := \row_(i < n) (y ``_ i * a ^+ i).

Hypothesis a_neq0 : a != 0.

Lemma supp_twisted y : supp (twisted y) = supp y.
Proof.
apply/setP => i; by rewrite inE mxE mulf_eq0 negb_or expf_neq0 // andbT inE.
Qed.

End twisted_error_pattern.

Section syndromep_prop.

Variables (F : fieldType) (n' : nat).
Let n := n'.+1.
Variable a : F.
Hypothesis a_neq0 : a != 0.
Variable (y : 'rV[F]_n).
Variable (t : nat).
Hypothesis tn : t < n.

Lemma dft_syndromep (v : 'rV[F]_n) :
  rVpoly (dft (rVexp a n) t (twisted a v)) = syndromep (rVexp a n) v t.
Proof.
case/boolP : (a == 0) => [/eqP -> | a0].
  apply/polyP => i.
  rewrite !coef_poly.
  case: ifPn => // it.
  rewrite insubT !mxE.
  rewrite /fdcoor !horner_poly.
  apply eq_bigr => j _.
  rewrite insubT // => jt.
  rewrite !mxE (_ : Sub _ _ = j); last by apply val_inj.
  rewrite (_ : Sub _ _ = Ordinal it) //=.
  rewrite inordK //; last by rewrite (leq_trans it) // ltnW.
  rewrite inordK; last by rewrite ltnS // (leq_trans it).
  rewrite !expr0n.
  set x := (i == _).
  case/boolP : (x) => //= Hx; first by rewrite expr1n mulr1.
  rewrite expr0n.
  set z := (_ == _).
  case/boolP : (z) => //= Hz; by [rewrite !mulr1 | rewrite !mulr0].
rewrite dftE /syndromep /fdcoor.
transitivity (\sum_(i in supp v) (\sum_(j < t) (twisted a v) ``_ i * (rVexp a n) ``_ (inord j) ^+ i *: 'X^j)).
  rewrite supp_twisted //.
  apply eq_bigr => /= i _.
  rewrite scaler_sumr; apply eq_bigr => j _.
  by rewrite scalerA.
rewrite exchange_big /= poly_def; apply eq_bigr => /= i _.
rewrite horner_poly scaler_suml.
transitivity (\sum_(i0 in 'I_n) ((twisted a v) ``_ i0 * (rVexp a n) ``_ (inord i) ^+ i0) *: 'X^i).
  apply/esym.
  rewrite (bigID (fun i => (twisted a v) ``_ i != 0)) /=.
  rewrite [X in _ + X = _](eq_bigr (fun => 0)); last first.
    move=> j.
    rewrite negbK => /eqP ->; by rewrite mul0r scale0r.
  rewrite big_const iter_addr0 addr0.
  apply eq_bigl => j; by rewrite mxE inE mulf_eq0 negb_or expf_neq0 // andbT.
apply eq_bigr => /= j _.
rewrite insubT // => jn.
rewrite (_ : Sub _ _ = j); last by apply val_inj.
rewrite !mxE inordK; last by rewrite (leq_trans (ltn_ord i)) // ltnW.
rewrite inordK //; last by rewrite ltnS // (leq_trans (ltn_ord i)).
by rewrite -exprM mulnC exprM -mulrA -exprS -exprM mulnC exprM.
Qed.

End syndromep_prop.

Lemma syndromep_t0 (F : fieldType) n (a : 'rV[F]_n.+1) e : syndromep a e 0 = 0.
Proof. by rewrite /syndromep poly_def big_ord0. Qed.


Require Export D.

(** **** Exercise: 2 stars (WHILE_true)  *)
(** Prove the following theorem. _Hint_: You'll want to use
    [WHILE_true_nonterm] here. *)

Lemma WHILE_true_nonterm : forall b c st st',
     bequiv b BTrue ->
     ~( (WHILE b DO c END) / st || st' ).
Proof. intros. unfold not. intros. remember (WHILE b DO c END) as Hw. induction H0;  inversion HeqHw; subst.
  unfold bequiv in H. rewrite H in H0. inversion H0.
  contradiction.
Qed.

Theorem WHILE_true: forall b c,
     bequiv b BTrue  ->
     cequiv
       (WHILE b DO c END)
       (WHILE BTrue DO SKIP END).
Proof.
  intros. split; intros.
  Case "->".
    apply WHILE_true_nonterm in H0. inversion H0. assumption.
  Case "<-".
    assert (~(WHILE BTrue DO SKIP END)/st||st'). apply (WHILE_true_nonterm BTrue SKIP st st'). unfold bequiv. reflexivity. contradiction.
Qed.


Require Import ZArith List.
From Semantics Require Import syntax little little_w_string parser asm.
Require Import String.
Import ListNotations.
Open Scope string_scope.

(* The file little contains a definition of the little language as a functor,
  where the actual type for strings is left abstract.  The advantage is that
  this parameter can be instantiated by Ocaml string in extracted code, or
  by Coq string in interactive experiments. *)

(* The file little_w_string contains the instantiation to be used in Coq
  interactive experiments.   The compiler defined in asm is also in a functor.
  To play with it in interactive experiments, we also instantiated with
  the Coq strings. *)
Module scomp := compiler str.
Import scomp.

(* If we want to compile an example, it is convenient to first parse this
  example to obtain an expression in the little datatype. *)
Definition little_cp s : list assembly :=
  match parse_program (tokenize s Start "") with
    Some (env, i) =>
    scomp.compile_instr (map fst env) 0 i
  | None => nil
  end.

(* Here is little example of a program.  This program computes the sum of
   the first 4 natural numbers. *)
Definition pg := little_cp
"variables x 0; y 0 in
while x < 4 do
x := x + 1;
y := x + y
done
end".

(* The following computation illustrates the program that we can obtain. *)
Compute pg.

(* The following computation illustrates the state of the stack machine
  after 4 steps of execution. *)
Compute exec_asm 4 pg nil [0%Z;0%Z] 0.
Compute nth_error pg 4.

(* The rest of the file illustrates how we can use the proof mode to step
  through the execution of the compiled program:
  we create two hypotheses, one is used to display the next instruction to
  execute, the other is used to display the current state of the machine:
  the stack, the memory, and the program counter. *)

(* This is a phantom type used to display the next instruction. *)
Definition ph (_ : option assembly) (_ : list Z * list Z * nat):= True.

Ltac xc :=
  match goal with
  id1 : ph _ (exec_asm ?n ?pg ?stk ?mem ?pc),
  id2 : ph _ _ |- _ =>
  clear id1 id2;
  let n' := constr:(S n) in
  let v := eval compute in (exec_asm n' pg stk mem pc) in
  let i := eval compute in (nth_error pg (snd v)) in
  assert (id1 : ph None (exec_asm n' pg stk mem pc)) by exact I;
  assert (id2 : ph i v) by reflexivity
  end.

Goal True.
assert (input : ph None (exec_asm 0 pg nil [0%Z; 0%Z] 0)) by exact I.
assert (state : ph None (nil, nil, 0%nat)) by exact I.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
xc.
exact I.
Qed.


Require Import Equations.Prop.Equations.
Require Import Arith.
Require Import Compare_dec.

Inductive term : Set :=
| Var (n : nat)
| Lam (t : term)
| App (t : term) (l : list term).

Equations subst_var (k : nat) (u : term) (t : nat) : term :=
  subst_var k u n with k ?= n =>
   { | Eq => u;
     | Gt => Var n;
     | Lt => Var (pred n) }.

Equations subst_term (k : nat) (u : term) (t : term) : term := {
subst_term k u (Var n) => subst_var k u n;
subst_term k u (Lam t) => Lam (subst_term (S k) u t);
subst_term k u (App t l) => App (subst_term k u t) (subst_tlist k u l) }

where subst_tlist (k : nat) (u : term) (t : list term) : list term := {
  subst_tlist k u nil := nil;
  subst_tlist k u (cons t ts) := cons (subst_term k u t) (subst_tlist k u ts) }.
  (* id_tlist t := List.map id_term t }. *)

Lemma subst_subst k u t : subst_term k u t = subst_term k u t.
Proof.
  revert k u t.
  refine (fst (subst_term_elim (fun k u t c => c = c) (fun k u l c => c = c) _ _ _ _ _));
  trivial.
Qed.


Require Import ZArith.
Require Import Coq.Arith.Compare_dec.
Require Import String.
Require Import Coq.Lists.List.
Import ListNotations.

Section ListUtil.

Variable V : Set.
Hypothesis V_eq_dec : forall x y : V, { x = y } + { x <> y }.

(* TODO: prove *)
Axiom edge_eq_dec :
	forall (x y : prod String String), { x = y } + { x <> y }.

Fixpoint FilterLenGEQ (L : list String) (a : String) : list String :=
	match L with
	| [] => []
	| b :: R =>
		if le_lt_dec (length a) (length b) then
			b :: FilterLenGEQ R a
		else
			FilterLenGEQ R a
	end.

Fixpoint StalinSort (L : list String) : list String :=
	match L with
	| [] => []
	| a :: R => a :: FilterLenGEQ (StalinSort R) a
	end.

Definition FilterMax (L : list String) : list String :=
	rev (StalinSort (rev (StalinSort L))).

Fixpoint RemoveFirst (L : list V) (a : V) : list V :=
	match L with
	| [] => []
	| b :: R => if V_eq_dec a b then R else (b :: (RemoveFirst R a))
	end.

Fixpoint RemoveAll (L : list V) (a : V) : list V :=
	match L with
	| [] => []
	| b :: R => if V_eq_dec a b then RemoveAll R a else (b :: RemoveAll R a)
	end.

Fixpoint Contains (L : list V) (a : V) : bool :=
	match L with
	| [] => false
	| b :: R => if V_eq_dec a b then true else Contains R a
	end.

Fixpoint Count (L : list V) (a : V) : nat :=
	match L with
	| [] => 0
	| b :: R =>
		if V_eq_dec a b then
			1 + (Count R a)
		else
			Count R a
	end.

Fixpoint RemoveDuplicates' (S L : list V) : list V :=
	match L with
	| [] => S
	| a :: R =>
		if Contains S a then
			RemoveDuplicates' S R
		else
			RemoveDuplicates' (a :: S) R
	end.

Definition RemoveDuplicates (L : list V) : list V :=
	RemoveDuplicates' [] L.

Fixpoint RemoveList (L S : list V) : list V :=
	match S with
	| [] => L
	| a :: R => RemoveList (RemoveFirst L a) R
	end.

Fixpoint StrSuffixes (L : list String) : list String :=
	match L with
	| [] => []
	| a :: R => (suff a) :: StrSuffixes R
	end.

Fixpoint StrPrefixes (L : list String) : list String :=
	match L with
	| [] => []
	| a :: R => (pref a) :: StrPrefixes R
	end.

Fixpoint StrMaxLen' (L : list String) (n : nat) {struct L} : nat :=
	match L with
	| [] => n
	| a :: R => StrMaxLen' R (max n (length a))
	end.

Definition StrMaxLen (L : list String) : nat := StrMaxLen' L 0.

Variable U : Set.
Hypothesis U_le : U -> U -> bool.
Hypothesis U_le_dec :
	forall (x y : U), { U_le x y = true } + { U_le y x = true }.

Fixpoint InsertSorted (L : list U) (z : U) : list U :=
	match L with
	| [] => [z]
	| a :: R =>
		if U_le_dec z a then
			z :: a :: R
		else
			a :: InsertSorted R z
	end.

Fixpoint Sort' (L S : list U) {struct L} : list U :=
	match L with
	| [] => S
	| a :: R => Sort' R (InsertSorted S a)
	end.

Definition Sort (L : list U) : list U :=
	Sort' L [].

End ListUtil.