(* mathcomp analysis (c) 2017 Inria and AIST. License: CeCILL-C.              *)
From mathcomp Require Import all_ssreflect ssralg ssrint ssrnum matrix.
From mathcomp Require Import interval rat.
From mathcomp.classical Require Import boolp classical_sets functions.
From mathcomp.classical Require Import mathcomp_extra.
Require Import reals ereal nsatz_realtype.
Require Import signed topology normedtype landau sequences derive realfun.

(******************************************************************************)
(*               Theory of exponential/logarithm functions                    *)
(*                                                                            *)
(* This file defines exponential and logarithm functions and develops their   *)
(* theory.                                                                    *)
(*                                                                            *)
(* * Differentiability of series (Section PseriesDiff)                        *)
(*   This formalization is inspired by HOL-Light (transc.ml). This part is    *)
(*   temporary: it should be subsumed by a proper theory of power series.     *)
(*         pseries f x == [series f n * x ^ n]_n                              *)
(*   pseries_diffs f i == (i + 1) * f (i + 1)                                 *)
(*                                                                            *)
(*                ln x == the natural logarithm                               *)
(*              a `^ x == power function (assumes a >= 0)                     *)
(*          riemannR a == sequence n |-> 1 / (n.+1) `^ a where a has a type   *)
(*                        of type realType                                    *)
(*                                                                            *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import Order.TTheory GRing.Theory Num.Def Num.Theory.
Import numFieldNormedType.Exports.

Local Open Scope classical_set_scope.
Local Open Scope ring_scope.

(* PR to mathcomp in progress *)
Lemma normr_nneg (R : numDomainType) (x : R) : `|x| \is Num.nneg.
Proof. by rewrite qualifE. Qed.
#[global] Hint Resolve normr_nneg : core.
(* /PR to mathcomp in progress *)

Section PseriesDiff.

Variable R : realType.

Definition pseries f (x : R) := [series f i * x ^+ i]_i.

Fact is_cvg_pseries_inside_norm f (x z : R) :
  cvg (pseries f x) -> `|z| < `|x| -> cvg (pseries (fun i => `|f i|) z).
Proof.
move=> Cx zLx; have [K [Kreal Kf]] := cvg_series_bounded Cx.
have Kzxn n : 0 <= `|K + 1| * `|z ^+ n| / `|x ^+ n|  by rewrite !mulr_ge0.
apply: normed_cvg.
apply: series_le_cvg Kzxn _ _ => [//=| /= n|].
  rewrite (_ : `|_ * _| = `|f n * x ^+ n| * `|z ^+ n| / `|x ^+ n|); last first.
    rewrite !normrM normr_id mulrAC mulfK // normr_eq0 expf_eq0 andbC.
    by case: ltrgt0P zLx; rewrite //= normr_lt0.
  do! (apply: ler_pmul || apply: mulr_ge0 || rewrite invr_ge0) => //.
  by apply Kf => //; rewrite (lt_le_trans _ (ler_norm _))// ltr_addl.
have F : `|z / x| < 1.
  by rewrite normrM normfV ltr_pdivr_mulr ?mul1r // (le_lt_trans _ zLx).
rewrite (_ : (fun _ => _) = geometric `|K + 1| `|z / x|); last first.
  by apply/funext => i /=; rewrite normrM exprMn mulrA normfV !normrX exprVn.
by apply: is_cvg_geometric_series; rewrite normr_id.
Qed.

Fact is_cvg_pseries_inside f (x z : R) :
  cvg (pseries f x) -> `|z| < `|x| -> cvg (pseries f z).
Proof.
move=> Cx zLx.
apply: normed_cvg; rewrite /normed_series_of /=.
rewrite (_ : (fun _ => _) = (fun i => `|f i| * `|z| ^+ i)); last first.
  by apply/funext => i; rewrite normrM normrX.
by apply: is_cvg_pseries_inside_norm Cx _; rewrite normr_id.
Qed.

Definition pseries_diffs (f : nat -> R) i := i.+1%:R * f i.+1.

Lemma pseries_diffsN (f : nat -> R) :  pseries_diffs (- f) = -(pseries_diffs f).
Proof. by apply/funext => i; rewrite /pseries_diffs /= -mulrN. Qed.

Lemma pseries_diffs_inv_fact :
  pseries_diffs (fun n => (n`!%:R)^-1) = (fun n => (n`!%:R)^-1 : R).
Proof.
apply/funext => i.
by rewrite /pseries_diffs factS natrM invfM mulrA mulfV ?mul1r.
Qed.

Lemma pseries_diffs_sumE n f x :
  \sum_(0 <= i < n)  pseries_diffs f i * x ^+ i =
  (\sum_(0 <= i < n) i%:R * f i * x ^+ i.-1) + n%:R * f n * x ^+ n.-1.
Proof.
case: n => [|n]; first by rewrite !big_nil !mul0r add0r.
under eq_bigr do unfold pseries_diffs.
by rewrite big_nat_recr //= big_nat_recl //= !mul0r add0r.
Qed.

Lemma pseries_diffs_equiv f x :
  let s i := i%:R * f i * x ^+ i.-1 in
  cvg (pseries (pseries_diffs f) x) -> series s -->
  lim (pseries (pseries_diffs f) x).
Proof.
move=> s Cx; rewrite -[lim _]subr0 /pseries [X in X --> _]/series /=.
rewrite [X in X --> _](_ : _ = (fun n => \sum_(0 <= i < n)
    pseries_diffs f i * x ^+ i - n%:R * f n * x ^+ n.-1)); last first.
  by rewrite funeqE => n; rewrite pseries_diffs_sumE addrK.
by apply: cvgB => //; rewrite -cvg_shiftS; exact: cvg_series_cvg_0.
Qed.

Lemma is_cvg_pseries_diffs_equiv f x :
  cvg (pseries (pseries_diffs f) x) -> cvg [series i%:R * f i * x ^+ i.-1]_i.
Proof.
by by move=> Cx; have := pseries_diffs_equiv Cx; move/(cvg_lim _) => -> //.
Qed.

Let pseries_diffs_P1 m (z h : R) :
  \sum_(0 <= i < m) ((h + z) ^+ (m - i) * z ^+ i - z ^+ m) =
  \sum_(0 <= i < m) z ^+ i * ((h + z) ^+ (m - i) - z ^+ (m - i)).
Proof.
rewrite !big_mkord; apply: eq_bigr => i _.
by rewrite mulrDr mulrN -exprD mulrC addnC subnK // ltnW.
Qed.

Let pseries_diffs_P2 n (z h : R) :
  h != 0 ->
  ((h + z) ^+ n - (z ^+ n)) / h - n%:R * z ^+ n.-1 =
  h * \sum_(0 <= i < n.-1) z ^+ i *
      \sum_(0 <= j < n.-1 - i) (h + z) ^+ j * z ^+ (n.-2 - i - j).
Proof.
move=> hNZ; apply: (mulfI hNZ).
rewrite mulrBr mulrC divfK //.
case: n => [|n].
  by rewrite !expr0 !(mul0r, mulr0, subr0, subrr, big_geq).
rewrite subrXX addrK -mulrBr; congr (_ * _).
rewrite -(big_mkord xpredT (fun i => (h + z) ^+ (n - i) * z ^+ i)).
rewrite big_nat_recr //= subnn expr0 -addrA -mulrBl.
rewrite -nat1r opprD addrA subrr sub0r mulNr.
rewrite mulr_natl -[in X in _ *+ X](subn0 n) -sumr_const_nat -sumrB.
rewrite pseries_diffs_P1 mulr_sumr !big_mkord; apply: eq_bigr => i _.
rewrite mulrCA; congr (_ * _).
rewrite subrXX addrK big_nat_rev /= big_mkord; congr (_ * _).
by apply: eq_bigr => k _; rewrite -!predn_sub subKn // -subnS.
Qed.

Let pseries_diffs_P3 (z h : R) n K :
  h != 0 -> `|z| <= K -> `|h + z| <= K ->
    `|((h +z) ^+ n - z ^+ n) / h - n%:R * z ^+ n.-1|
      <= n%:R * n.-1%:R * K ^+ n.-2 * `|h|.
Proof.
move=> hNZ zLK zhLk.
rewrite pseries_diffs_P2// normrM mulrC.
rewrite ler_pmul2r ?normr_gt0//.
rewrite (le_trans (ler_norm_sum _ _ _))//.
rewrite -mulrA mulrC -mulrA mulr_natl -[X in _ *+ X]subn0 -sumr_const_nat.
apply ler_sum_nat => i /=.
case: n => //= n ni.
rewrite normrM.
pose d := (n.-1 - i)%nat.
rewrite -[(n - i)%nat]prednK ?subn_gt0// predn_sub -/d.
rewrite -(subnK (_ : i <= n.-1)%nat) -/d; last first.
  by rewrite -ltnS prednK// (leq_ltn_trans _ ni).
rewrite addnC exprD mulrAC -mulrA.
apply: ler_pmul => //.
  by rewrite normrX ler_expn2r// qualifE (le_trans _ zLK).
apply: le_trans (_ : d.+1%:R * K ^+ d <= _); last first.
  rewrite ler_wpmul2r //; first by rewrite exprn_ge0 // (le_trans _ zLK).
  by rewrite ler_nat ltnS /d -subn1 -subnDA leq_subr.
rewrite (le_trans (ler_norm_sum _ _ _))//.
rewrite mulr_natl -[X in _ *+ X]subn0 -sumr_const_nat ler_sum_nat//= => j jd1.
rewrite -[in leRHS](subnK (_ : j <= d)%nat) -1?ltnS // addnC exprD normrM.
by rewrite ler_pmul// normrX ler_expn2r// qualifE (le_trans _ zLK).
Qed.

Lemma pseries_snd_diffs (c : R^nat) K x :
  cvg (pseries c K) ->
  cvg (pseries (pseries_diffs c) K) ->
  cvg (pseries (pseries_diffs (pseries_diffs c)) K) ->
  `|x| < `|K| ->
  is_derive x 1
    (fun x => lim (pseries c x))
    (lim (pseries (pseries_diffs c) x)).
Proof.
move=> Ck CdK CddK xLK; rewrite /pseries.
set s := (fun n : nat => _); set (f := fun x0 => _).
suff hfxs : h^-1 *: (f (h + x) - f x) @[h --> 0^'] --> lim (series s).
  have F : f^`() x = lim (series s) by apply: cvg_lim hfxs.
  have Df : derivable f x 1.
    move: hfxs; rewrite /derivable [X in X @ _](_ : _ =
        (fun h => h^-1 *: (f (h%:A + x) - f x))) /=; last first.
      by apply/funext => i //=; rewrite [i%:A]mulr1.
    by move=> /(cvg_lim _) -> //.
  by constructor; [exact: Df|rewrite -derive1E].
pose sx := fun n : nat => c n * x ^+ n.
have Csx : cvg (pseries c x) by apply: is_cvg_pseries_inside Ck _.
pose shx := fun h (n : nat) => c n * (h + x) ^+ n.
suff Cc : lim (h^-1 *: (series (shx h - sx))) @[h --> 0^'] --> lim (series s).
  apply: cvg_sub0 Cc.
  apply/cvgrPdist_lt => eps eps_gt0 /=.
  near=> h; rewrite sub0r normrN /=.
  rewrite (le_lt_trans _ eps_gt0)//.
  rewrite normr_le0 subr_eq0 -/sx -/(shx _); apply/eqP.
  have Cshx' : cvg (series (shx h)).
    apply: is_cvg_pseries_inside Ck _.
    rewrite (le_lt_trans (ler_norm_add _ _))// -(subrK  `|x| `|K|) ltr_add2r.
    near: h.
    apply/nbhs_ballP => /=; exists ((`|K| - `|x|) /2) => /=.
      by rewrite divr_gt0 // subr_gt0.
    move=> t; rewrite /ball /= sub0r normrN => H tNZ.
    rewrite (lt_le_trans H)// ler_pdivr_mulr // mulr2n mulrDr mulr1.
    by rewrite ler_paddr // subr_ge0 ltW.
  by rewrite limZr; [rewrite lim_seriesB|exact: is_cvg_seriesB].
apply: cvg_zero => /=.
suff Cc : lim
    (series (fun n => c n * (((h + x) ^+ n - x ^+ n) / h - n%:R * x ^+ n.-1)))
    @[h --> 0^'] --> (0 : R).
  apply: cvg_sub0 Cc.
  apply/cvgrPdist_lt => eps eps_gt0 /=.
  near=> h; rewrite sub0r normrN /=.
  rewrite (le_lt_trans _ eps_gt0)// normr_le0 subr_eq0; apply/eqP.
  have Cs : cvg (series s) by apply: is_cvg_pseries_inside CdK _.
  have Cs1 := is_cvg_pseries_diffs_equiv Cs.
  have Fs1 := pseries_diffs_equiv Cs.
  set s1 := (fun i => _) in Cs1.
  have Cshx : cvg (series (shx h)).
    apply: is_cvg_pseries_inside Ck _.
    rewrite (le_lt_trans (ler_norm_add _ _))// -(subrK  `|x| `|K|) ltr_add2r.
    near: h.
    apply/nbhs_ballP => /=; exists ((`|K| - `|x|) /2) => /=.
      by rewrite divr_gt0 // subr_gt0.
    move=> t; rewrite /ball /= sub0r normrN => H tNZ.
    rewrite (lt_le_trans H)// ler_pdivr_mulr // mulr2n mulrDr mulr1.
    by rewrite ler_paddr // subr_ge0 ltW.
  have C1 := is_cvg_seriesB Cshx Csx.
  have Ckf := @is_cvg_seriesZ _ _ h^-1 C1.
  have Cu : (series (h^-1 *: (shx h - sx)) - series s1) x0 @[x0 --> \oo] -->
      lim (series (h^-1 *: (shx h - sx))) - lim (series s).
    by apply: cvgB.
  set w := (fun n : nat => _ in RHS).
  have -> : w = h^-1 *: (shx h - sx)  - s1.
    apply: funext => i; rewrite !fctE.
    rewrite /w /shx /sx /s1 /= mulrBr; congr (_ - _); last first.
      by rewrite mulrCA !mulrA.
    by rewrite -mulrBr [RHS]mulrCA [_^-1 * _]mulrC.
  rewrite [X in X h = _]/+%R /= [X in _ + X h = _]/-%R /=.
  have -> : series (h^-1 *: (shx h - sx) - s1) =
           series (h^-1 *: (shx h - sx)) - (series s1).
    by apply/funext => i; rewrite /series /= sumrB.
  have -> : h^-1 *: series (shx h - sx) = series (h^-1 *: (shx h - sx)).
    by apply/funext => i; rewrite /series /= -scaler_sumr.
  exact/esym/cvg_lim.
pose r := (`|x| + `|K|) / 2.
have xLr : `|x| < r by rewrite ltr_pdivl_mulr // mulr2n mulrDr mulr1 ltr_add2l.
have rLx : r < `|K| by rewrite ltr_pdivr_mulr // mulr2n mulrDr mulr1 ltr_add2r.
have r_gt0 : 0 < r by apply: le_lt_trans xLr.
have rNZ : r != 0by case: ltrgt0P r_gt0.
apply: (@lim_cvg_to_0_linear _
  (fun n => `|c n| * n%:R * (n.-1)%:R * r ^+ n.-2)
  (fun h n => c n * (((h + x) ^+ n - x ^+ n) / h - n%:R * x ^+ n.-1))
  (r - `|x|)); first by rewrite subr_gt0.
- have : cvg [series `|pseries_diffs (pseries_diffs c) n| * r ^+ n]_n.
    apply: is_cvg_pseries_inside_norm CddK _.
    by rewrite ger0_norm // ltW // (le_lt_trans _ xLr).
  have -> : (fun n => `|pseries_diffs (pseries_diffs c) n| * r ^+ n) =
            (fun n => pseries_diffs (pseries_diffs
                                      (fun m => `|c m|)) n * r ^+ n).
    apply/funext => i.
    by rewrite /pseries_diffs !normrM !mulrA ger0_norm // ger0_norm.
  move=> /is_cvg_pseries_diffs_equiv.
  rewrite /pseries_diffs.
  have -> : (fun n => n%:R * ((n.+1)%:R * `|c n.+1|) * r ^+ n.-1) =
           (fun n => pseries_diffs
             (fun m => (m.-1)%:R * `|c m| * r^-1) n * r ^+ n).
    apply/funext => n.
    rewrite /pseries_diffs /= mulrA.
    case: n => [|n /=]; first by rewrite !(mul0r, mulr0).
    rewrite [_%:R *_]mulrC !mulrA -[RHS]mulrA exprS.
    by rewrite [_^-1 * _]mulrA mulVf ?mul1r.
  move/is_cvg_pseries_diffs_equiv.
  have ->// : (fun n => n%:R * (n.-1%:R * `|c n| / r) * r ^+ n.-1) =
              (fun n => `|c n| * n%:R * n.-1%:R * r ^+ n.-2).
  apply/funext => [] [|[|i]]; rewrite ?(mul0r, mulr0) //=.
  rewrite mulrA -mulrA exprS [_^-1 * _]mulrA mulVf //.
  rewrite mul1r !mulrA; congr (_ * _).
  by rewrite mulrC mulrA.
- move=> h /andP[h_gt0 hLrBx] n.
  rewrite normrM -!mulrA ler_wpmul2l //.
  rewrite (le_trans (pseries_diffs_P3 _ _ (ltW xLr) _))// ?mulrA -?normr_gt0//.
  by rewrite (le_trans (ler_norm_add _ _))// -(subrK `|x| r) ler_add2r ltW.
Unshelve. all: by end_near. Qed.

End PseriesDiff.

Section expR.
Variable R : realType.
Implicit Types x : R.

Lemma expR0 : expR 0 = 1 :> R.
Proof.
apply: lim_near_cst => //.
near=> m; rewrite -[m]prednK; last by near: m.
rewrite -addn1 series_addn series_exp_coeff0 big_add1 big1 ?addr0//.
by move=> i _; rewrite /exp_coeff /= expr0n mul0r.
Unshelve. all: by end_near. Qed.

Lemma expR_ge1Dx x : 0 <= x -> 1 + x <= expR x.
Proof.
move=> x_gt0; rewrite /expR.
pose f (x : R) i := (i == 0%nat)%:R + x *+ (i == 1%nat).
have F n : (1 < n)%nat -> \sum_(0 <= i < n) (f x i) = 1 + x.
  move=> /subnK<-.
  by rewrite addn2 !big_nat_recl //= /f /= mulr1n !mulr0n big1 ?add0r ?addr0.
have -> : 1 + x = lim (series (f x)).
  by apply/esym/lim_near_cst => //; near=> n; apply: F; near: n.
apply: ler_lim; first by apply: is_cvg_near_cst; near=> n; apply: F; near: n.
  exact: is_cvg_series_exp_coeff.
by near=> n; apply: ler_sum => [] [|[|i]] _;
  rewrite /f /exp_coeff /= !(mulr0n, mulr1n, expr0, expr1, divr1, addr0, add0r)
          // exp_coeff_ge0.
Unshelve. all: by end_near. Qed.

Lemma exp_coeffE x : exp_coeff x = (fun n => (fun n => (n`!%:R)^-1) n * x ^+ n).
Proof. by apply/funext => i; rewrite /exp_coeff /= mulrC. Qed.

Import GRing.Theory.
Local Open Scope ring_scope.

Lemma expRE :
  expR = fun x => lim (pseries (fun n => (fun n => (n`!%:R)^-1) n) x).
Proof. by apply/funext => x; rewrite /pseries -exp_coeffE. Qed.

Global Instance is_derive_expR x : is_derive x 1 expR (expR x).
Proof.
pose s1 n := pseries_diffs (fun n => n`!%:R^-1) n * x ^+ n.
rewrite expRE /= /pseries (_ : (fun _ => _) = s1); last first.
  by apply/funext => i; rewrite /s1 pseries_diffs_inv_fact.
apply: (@pseries_snd_diffs _ _ (`|x| + 1)); rewrite /pseries.
- by rewrite -exp_coeffE; apply: is_cvg_series_exp_coeff.
- rewrite (_ : (fun _ => _) = exp_coeff (`|x| + 1)).
    exact: is_cvg_series_exp_coeff.
  by apply/funext => i; rewrite pseries_diffs_inv_fact exp_coeffE.
- rewrite (_ : (fun _ => _) = exp_coeff (`|x| + 1)).
    exact: is_cvg_series_exp_coeff.
  by apply/funext => i; rewrite !pseries_diffs_inv_fact exp_coeffE.
by rewrite [ltRHS]ger0_norm// addrC -subr_gt0 addrK.
Qed.

Lemma derivable_expR x : derivable expR x 1.
Proof. by apply: ex_derive; apply: is_derive_exp. Qed.

Lemma continuous_expR : continuous (@expR R).
Proof.
by move=> x; exact/differentiable_continuous/derivable1_diffP/derivable_expR.
Qed.

Lemma expRxDyMexpx x y : expR (x + y) * expR (- x) = expR y.
Proof.
set v := LHS; pattern x in v; move: @v; set f := (X in let _ := X x in _) => /=.
apply: etrans (_ : f x = f 0) _; last by rewrite /f add0r oppr0 expR0 mulr1.
apply: is_derive_0_is_cst => x1.
apply: trigger_derive.
by rewrite /GRing.scale /= mulrN1 addr0 mulr1 mulrN addrC mulrC subrr.
Qed.

Lemma expRxMexpNx_1 x : expR x * expR (- x) = 1.
Proof. by rewrite -[X in _ X * _ = _]addr0 expRxDyMexpx expR0. Qed.

Lemma pexpR_gt1 x : 0 < x -> 1 < expR x.
Proof.
by move=> x_gt0; rewrite (lt_le_trans _ (expR_ge1Dx (ltW x_gt0)))// ltr_addl.
Qed.

Lemma expR_gt0 x : 0 < expR x.
Proof.
case: (ltrgt0P x) => [x_gt0|x_gt0|->]; last by rewrite expR0.
- exact: lt_trans (pexpR_gt1 x_gt0).
- have F : 0 < expR (- x) by rewrite (lt_trans _ (pexpR_gt1 _))// oppr_gt0.
  by rewrite -(pmulr_lgt0 _ F) expRxMexpNx_1.
Qed.

Lemma expR_ge0 x : 0 <= expR x. Proof. by rewrite ltW// expR_gt0. Qed.

Lemma expRN x : expR (- x) = (expR x)^-1.
Proof.
apply: (mulfI (lt0r_neq0 (expR_gt0 x))).
by rewrite expRxMexpNx_1 mulfV // (lt0r_neq0 (expR_gt0 x)).
Qed.

Lemma expRD x y : expR (x + y) = expR x * expR y.
Proof.
apply: (mulIf (lt0r_neq0 (expR_gt0 (- x)))).
rewrite expRxDyMexpx expRN [_ * expR y]mulrC mulfK //.
by case: ltrgt0P (expR_gt0 x).
Qed.

Lemma expRMm n x : expR (n%:R * x) = expR x ^+ n.
Proof.
elim: n x => [x|n IH x] /=; first by rewrite mul0r expr0 expR0.
by rewrite exprS -nat1r mulrDl mul1r expRD IH.
Qed.

Lemma expR_gt1 x:  (1 < expR x) = (0 < x).
Proof.
case: ltrgt0P => [x_gt0| xN|->]; last by rewrite expR0.
- by rewrite (pexpR_gt1 x_gt0).
- apply/idP/negP.
  rewrite -[x]opprK expRN -leNgt invf_cp1 ?expR_gt0 //.
  by rewrite ltW // pexpR_gt1 // lter_oppE.
Qed.

Lemma expR_lt1 x:  (expR x < 1) = (x < 0).
Proof.
case: ltrgt0P => [x_gt0|xN|->]; last by rewrite expR0.
- by apply/idP/negP; rewrite -leNgt ltW // expR_gt1.
- by rewrite -[x]opprK expRN invf_cp1 ?expR_gt0 // expR_gt1 lter_oppE.
Qed.

Lemma expRB x y : expR (x - y) = expR x / expR y.
Proof. by rewrite expRD expRN. Qed.

Lemma ltr_expR : {mono (@expR R) : x y / x < y}.
Proof.
move=> x y.
by  rewrite -[in LHS](subrK x y) expRD ltr_pmull ?expR_gt0 // expR_gt1 subr_gt0.
Qed.

Lemma ler_expR : {mono (@expR R) : x y / x <= y}.
Proof.
move=> x y.
case: (ltrgtP x y) => [xLy|yLx|<-]; last by rewrite lexx.
- by rewrite ltW // ltr_expR.
- by rewrite leNgt ltr_expR yLx.
Qed.

Lemma expR_inj : injective (@expR R).
Proof.
move=> x y exE.
by have [] := (ltr_expR x y, ltr_expR y x); rewrite exE ltxx; case: ltrgtP.
Qed.

Lemma expR_total_gt1 x :
  1 <= x -> exists y, [/\ 0 <= y, 1 + y <= x & expR y = x].
Proof.
move=> x_ge1; have x_ge0 : 0 <= x by apply: le_trans x_ge1.
have [x1 x1Ix| |x1 _ /eqP] := @IVT _ (fun y => expR y - x) _ _ 0 x_ge0.
- apply: continuousB => // y1; last exact: cst_continuous.
  by apply/continuous_subspaceT=> ?; exact: continuous_expR.
- rewrite expR0; have [_| |] := ltrgtP (1- x) (expR x - x).
  + by rewrite subr_le0 x_ge1 subr_ge0 (le_trans _ (expR_ge1Dx _)) ?ler_addr.
  + by rewrite ltr_add2r expR_lt1 ltNge x_ge0.
  + rewrite subr_le0 x_ge1 => -> /=; rewrite subr_ge0.
    by rewrite (le_trans _ (expR_ge1Dx x_ge0)) ?ler_addr.
- rewrite subr_eq0 => /eqP x1_x; exists x1; split => //.
  + by rewrite -ler_expR expR0 x1_x.
  + by rewrite -x1_x expR_ge1Dx // -ler_expR x1_x expR0.
Qed.

Lemma expR_total x : 0 < x -> exists y, expR y = x.
Proof.
case: (lerP 1 x) => [/expR_total_gt1[y [_ _ Hy]]|x_lt1 x_gt0].
  by exists y.
have /expR_total_gt1[y [H1y H2y H3y]] : 1 <= x^-1 by rewrite ltW // !invf_cp1.
by exists (-y); rewrite expRN H3y invrK.
Qed.

End expR.

Section Ln.
Variable R : realType.
Implicit Types x : R.

Notation exp := (@expR R).

Definition ln x : R := xget 0 [set y | exp y == x ].

Fact ln0 x : x <= 0 -> ln x = 0.
Proof.
rewrite /ln; case: xgetP => //= y _ /eqP yx x0.
by have := expR_gt0 y; rewrite yx => /(le_lt_trans x0); rewrite ltxx.
Qed.

Lemma expK : cancel exp ln.
Proof.
by move=> x; rewrite /ln; case: xgetP => [x1 _ /eqP/expR_inj //|/(_ x)[]/=].
Qed.

Lemma lnK : {in Num.pos, cancel ln exp}.
Proof.
move=> x; rewrite qualifE => x_gt0.
rewrite /ln; case: xgetP=> [x1 _ /eqP// |H].
by case: (expR_total x_gt0) => y /eqP Hy; case: (H y).
Qed.

Lemma lnK_eq x : (exp (ln x) == x) = (0 < x).
Proof.
by apply/eqP/idP=> [<-|x0]; [exact: expR_gt0|rewrite lnK// in_itv/= x0].
Qed.

Lemma ln1 : ln 1 = 0.
Proof. by apply/expR_inj; rewrite lnK// ?expR0// qualifE. Qed.

Lemma lnM : {in Num.pos &, {morph ln : x y / x * y >-> x + y}}.
Proof.
move=> x y x0 y0; apply: expR_inj; rewrite expRD !lnK//.
by move: x0 y0; rewrite !qualifE; exact: mulr_gt0.
Qed.

Lemma ln_inj : {in Num.pos &, injective ln}.
Proof. by move=> x y /lnK {2}<- /lnK {2}<- ->. Qed.

Lemma lnV : {in Num.pos, {morph ln : x / x ^-1 >-> - x}}.
Proof.
move=> x x0; apply: expR_inj; rewrite lnK// ?expRN ?lnK//.
by move: x0; rewrite !qualifE invr_gt0.
Qed.

Lemma ln_div : {in Num.pos &, {morph ln : x y / x / y >-> x - y}}.
Proof.
move=> x y x0 y0; rewrite (lnM x0) ?lnV//.
by move: y0; rewrite !qualifE/= invr_gt0.
Qed.

Lemma ltr_ln : {in Num.pos &, {mono ln : x y / x < y}}.
Proof. by move=> x y x_gt0 y_gt0; rewrite -ltr_expR !lnK. Qed.

Lemma ler_ln : {in Num.pos &, {mono ln : x y / x <= y}}.
Proof. by move=> x y x_gt0 y_gt0; rewrite -ler_expR !lnK. Qed.

Lemma lnX n x : 0 < x -> ln(x ^+ n) = ln x *+ n.
Proof.
move=> x_gt0; elim: n => [|n ih] /=; first by rewrite expr0 ln1 mulr0n.
by rewrite !exprS lnM ?qualifE// ?exprn_gt0// mulrS ih.
Qed.

Lemma le_ln1Dx x : 0 <= x -> ln (1 + x) <= x.
Proof.
move=> x_ge0; rewrite -ler_expR lnK ?expR_ge1Dx //.
by apply: lt_le_trans (_ : 0 < 1) _; rewrite // ler_addl.
Qed.

Lemma ln_sublinear x : 0 < x -> ln x < x.
Proof.
move=> x_gt0; apply: lt_le_trans (_ : ln (1 + x) <= _).
  by rewrite -ltr_expR !lnK ?qualifE ?addr_gt0 // ltr_addr.
by rewrite -ler_expR lnK ?qualifE ?addr_gt0// expR_ge1Dx // ltW.
Qed.

Lemma ln_ge0 x : 1 <= x -> 0 <= ln x.
Proof.
by move=> x_ge1; rewrite -ler_expR expR0 lnK// qualifE (lt_le_trans _ x_ge1).
Qed.

Lemma ln_gt0 x : 1 < x -> 0 < ln x.
Proof.
by move=> x_gt1; rewrite -ltr_expR expR0 lnK // qualifE (lt_trans _ x_gt1).
Qed.

Lemma continuous_ln x : 0 < x -> {for x, continuous ln}.
Proof.
move=> x_gt0; rewrite -[x]lnK//.
apply: nbhs_singleton (near_can_continuous _ _); near=> z; first exact: expK.
by apply: continuous_expR.
Unshelve. all: by end_near. Qed.

Global Instance is_derive1_ln (x : R) : 0 < x -> is_derive x 1 ln x^-1.
Proof.
move=> x_gt0; rewrite -[x]lnK//.
apply: (@is_derive_inverse R expR); first by near=> z; apply: expK.
  by near=>z; apply: continuous_expR.
by rewrite lnK // lt0r_neq0.
Unshelve. all: by end_near. Qed.

End Ln.

Section PowerPos.
Variable R : realType.
Implicit Types a x : R.

Definition power_pos a x :=
  if a == 0 then (x == 0)%:R else expR (x * ln a).

Local Notation "a `^ x" := (power_pos a x).

Lemma power_pos_ge0 a x : 0 <= a `^ x.
Proof. by rewrite /power_pos; case: ifPn => // _; exact: expR_ge0. Qed.

Lemma power_pos_gt0 a x : 0 < a -> 0 < a `^ x.
Proof. by move=> a0; rewrite /power_pos gt_eqF// expR_gt0. Qed.

Lemma power_posr1 a : 0 <= a -> a `^ 1 = a.
Proof.
move=> a0; rewrite /power_pos; case: ifPn => [/eqP->|a0'].
  by rewrite oner_eq0.
by rewrite mul1r lnK// posrE lt_neqAle eq_sym a0'.
Qed.

Lemma power_posr0 a : a `^ 0 = 1.
Proof.
by rewrite /power_pos; case: ifPn; rewrite ?eqxx// mul0r expR0.
Qed.

Lemma power_pos0 x : power_pos 0 x = (x == 0)%:R.
Proof. by rewrite /power_pos eqxx. Qed.

Lemma power_pos1 : power_pos 1 = fun=> 1.
Proof. by apply/funext => x; rewrite /power_pos oner_eq0 ln1 mulr0 expR0. Qed.

Lemma power_pos_eq0 x p : x `^ p = 0 -> x = 0.
Proof.
rewrite /power_pos. have [->|_] := eqVneq x 0 => //.
by move: (expR_gt0 (p * ln x)) => /gt_eqF /eqP.
Qed.

Lemma ler_power_pos a : 1 < a -> {homo power_pos a : x y / x <= y}.
Proof.
move=> a1 x y xy.
by rewrite /power_pos gt_eqF ?(le_lt_trans _ a1)// ler_expR ler_pmul2r// ln_gt0.
Qed.

Lemma power_posM x y r : 0 <= x -> 0 <= y -> (x * y) `^ r = x `^ r * y `^ r.
Proof.
rewrite 2!le_eqVlt.
move=> /predU1P[<-|x0] /predU1P[<-|y0]; rewrite ?(mulr0, mul0r,power_pos0).
- by rewrite -natrM; case: eqP.
- by case: eqP => [->|]/=; rewrite ?mul0r ?power_posr0 ?mulr1.
- by case: eqP => [->|]/=; rewrite ?mulr0 ?power_posr0 ?mulr1.
- rewrite /power_pos mulf_eq0; case: eqP => [->|x0']/=.
    rewrite (@gt_eqF _ _ y)//.
    by case: eqP => /=; rewrite ?mul0r ?mul1r// => ->; rewrite mul0r expR0.
  by rewrite gt_eqF// lnM ?posrE // -expRD mulrDr.
Qed.

Lemma power_posAC x y z : (x `^ y) `^ z = (x `^ z) `^ y.
Proof.
rewrite /power_pos.
have [->/=|z0] := eqVneq z 0; rewrite ?mul0r.
- have [->/=|y0] := eqVneq y 0; rewrite ?mul0r//=.
  have [x0|x0] := eqVneq x 0; rewrite ?eqxx ?oner_eq0 ?ln1 ?mulr0 ?expR0//.
  by rewrite oner_eq0 if_same ln1 mulr0 expR0.
- have [->/=|y0] := eqVneq y 0; rewrite ?mul0r/=.
    have [x0|x0] := eqVneq x 0; rewrite ?eqxx ?oner_eq0 ?ln1 ?mulr0 ?expR0//.
    by rewrite oner_eq0 if_same ln1  mulr0 expR0.
  have [x0|x0] := eqVneq x 0; rewrite ?eqxx ?oner_eq0 ?ln1 ?mulr0 ?expR0.
    by [].
  rewrite gt_eqF ?expR_gt0// gt_eqF; last by rewrite expR_gt0.
  by rewrite !expK mulrCA.
Qed.

Lemma power_posD a : 0 < a -> {morph power_pos a : x y / x + y >-> x * y}.
Proof. by move=> a0 x y; rewrite /power_pos gt_eqF// mulrDl expRD. Qed.

Lemma power_pos_mulrn a n : 0 <= a -> a `^ n%:R = a ^+ n.
Proof.
move=> a0; elim: n => [|n ih].
  by rewrite mulr0n expr0 power_posr0//; apply: lt0r_neq0.
move: a0; rewrite le_eqVlt => /predU1P[<-|a0].
  by rewrite !power_pos0 mulrn_eq0/= oner_eq0/= expr0n.
by rewrite -natr1 power_posD// ih power_posr1// ?exprS 1?mulrC// ltW.
Qed.

Lemma power_pos_inv1 a : 0 <= a -> a `^ (-1) = a ^-1.
Proof.
rewrite le_eqVlt => /predU1P[<-|a0].
  by rewrite power_pos0 invr0 oppr_eq0 oner_eq0.
apply/(@mulrI _ a); first by rewrite unitfE gt_eqF.
rewrite -[X in X * _ = _](power_posr1 (ltW a0)) -power_posD // subrr.
by rewrite power_posr0 divff// gt_eqF.
Qed.

Lemma power_pos_inv a n : 0 <= a -> a `^ (- n%:R) = a ^- n.
Proof.
move=> a0; elim: n => [|n ih].
  by rewrite -mulNrn mulr0n power_posr0 -exprVn expr0.
move: a0; rewrite le_eqVlt => /predU1P[<-|a0].
  by rewrite power_pos0 oppr_eq0 mulrn_eq0 oner_eq0 orbF exprnN exp0rz oppr_eq0.
rewrite -natr1 opprD power_posD// (power_pos_inv1 (ltW a0)) ih.
by rewrite -[in RHS]exprVn exprS [in RHS]mulrC exprVn.
Qed.

Lemma power_pos_intmul a (z : int) : 0 <= a -> a `^ z%:~R = a ^ z.
Proof.
move=> a0; have [z0|z0] := leP 0 z.
  rewrite -[in RHS](gez0_abs z0) abszE -exprnP -power_pos_mulrn//.
  by rewrite natr_absz -abszE gez0_abs.
rewrite -(opprK z) (_ : - z = `|z|%N); last by rewrite ltz0_abs.
by rewrite -exprnN -power_pos_inv// nmulrn.
Qed.

Lemma power12_sqrt a : 0 <= a -> a `^ (2^-1) = Num.sqrt a.
Proof.
rewrite le_eqVlt => /predU1P[<-|a0].
  by rewrite power_pos0 sqrtr0 invr_eq0 pnatr_eq0.
have /eqP : (a `^ (2^-1)) ^+ 2 = (Num.sqrt a) ^+ 2.
  rewrite sqr_sqrtr; last exact: ltW.
  by rewrite /power_pos gt_eqF// -expRMm mulrA divrr ?mul1r ?unitfE// lnK.
rewrite eqf_sqr => /predU1P[//|/eqP h].
have : 0 < a `^ 2^-1 by apply: power_pos_gt0.
by rewrite h oppr_gt0 ltNge sqrtr_ge0.
Qed.

End PowerPos.
Notation "a `^ x" := (power_pos a x) : real_scope.

Section riemannR_series.
Variable R : realType.
Implicit Types a : R.
Local Open Scope real_scope.

Definition riemannR a : R ^nat := fun n => (n.+1%:R `^ a)^-1.
Arguments riemannR a n /.

Lemma riemannR_gt0 a i : 0 <= a -> 0 < riemannR a i.
Proof. by move=> ?; rewrite /riemannR invr_gt0 power_pos_gt0. Qed.

Lemma dvg_riemannR a : 0 <= a <= 1 -> ~ cvg (series (riemannR a)).
Proof.
case/andP => a0; rewrite le_eqVlt => /predU1P[->|a1].
  rewrite (_ : riemannR 1 = harmonic); first exact: dvg_harmonic.
  by rewrite funeqE => i /=; rewrite power_posr1.
have : forall n, harmonic n <= riemannR a n.
  case=> /= [|n]; first by rewrite power_pos1 invr1.
  rewrite -[leRHS]div1r ler_pdivl_mulr ?power_pos_gt0 // mulrC ler_pdivr_mulr //.
  by rewrite mul1r -[leRHS]power_posr1 // (ler_power_pos) // ?ltr1n // ltW.
move/(series_le_cvg harmonic_ge0 (fun i => ltW (riemannR_gt0 i a0))).
by move/contra_not; apply; exact: dvg_harmonic.
Qed.

End riemannR_series.


Require Import BenB.

Variable X: R -> Prop.
Variable Y: R -> Prop.

Theorem getallen_007 :
  (forall t:R, X t -> (exists u:R, u in (t+2,t+5] /\ Y u))
->
  (forall t:R, X t -> (exists u:R, u in (t+1,t+6] /\ Y u)).
Proof.
imp_i a1.
all_i a.
imp_i a2.
exi_e (exists u : R, u in  (a + 2, a + 5] /\ Y u) b a3.
imp_e (X a).
all_e (forall t : R, X t -> exists u : R, u in  (t + 2, t + 5] /\ Y u) a.
hyp a1.
hyp a2.
exi_i b.
con_i.
interval.
con_i.
imp_e (a+2 < b).
imp_i a4.
lin_solve.
con_e1 (b <= a+5).
con_e1 (Y b).
hyp a3.
imp_e (b <= a+5).
imp_i a4.
lin_solve.
con_e2 (a+2 < b).
con_e1 (Y b).
hyp a3.
con_e2 (b in (a + 2, a + 5]).
hyp a3.
Qed.


Require Import Iron.Language.SystemF.Step.
Require Import Iron.Language.SystemF.SubstExpExp.
Require Import Iron.Language.SystemF.SubstTypeExp.
Require Import Iron.Language.SystemF.SubstTypeType.
Require Import Iron.Language.SystemF.TyJudge.

(* When an expression takes a step the results has the same type. *)
Theorem preservation
 :  forall ke te x x' t
 ,  TYPE ke te x t
 -> STEP x x'
 -> TYPE ke te x' t.
Proof.
 intros ke te x x' t HT HS.
 gen ke te x' t.
 induction x; intros.

 Case "XVar".
  inverts HS.

 Case "XLAM".
  inverts HS.

 Case "XAPP".
  inverts HT.
  inverts keep HS.

  SCase "ESAPPLAM".
   inverts H3.
   eapply subst_type_value in H4; eauto.
   rewrite substTE_liftTE in H4. auto.

  SCase "ESAPP1".
   apply TYAPP; eauto.

 Case "XLam".
  inverts HS.

 Case "XApp".
  inverts HT.
  inverts keep HS.

  SCase "ESAppLam".
   inverts H3.
   lets D: subst_value_value H9 H5. auto.

  SCase "EsApp1".
   eapply TYApp; eauto.

  SCase "EsApp2".
   eapply TYApp; eauto.
Qed.

(* When we multi-step evaluate some expression,
   then the result has the same type as the original.
 *)
Lemma preservation_steps
 :  forall x1 t1 x2
 ,  TYPE nil nil x1 t1
 -> STEPS x1 x2
 -> TYPE nil nil x2 t1.
Proof.
 intros.
 induction H0; eauto.
  eapply preservation; eauto.
Qed.

(* When we multi-step evaluate some expression,
   then the result has the same type as the original.
   Using the left-linearised form for the evaluation.
 *)
Lemma preservation_stepsl
 :  forall x1 t1 x2
 ,  TYPE nil nil x1 t1
 -> STEPSL x1 x2
 -> TYPE nil nil x2 t1.
Proof.
 intros.
 induction H0.
  auto.
  apply IHSTEPSL.
  eapply preservation.
   eauto. auto.
Qed.


Definition I {A:Type} x:A := x.
Definition K {A B:Type} (x:A) (y:B) := x.
Definition F {A B:Type} (x:A) (y:B) := y.
Definition S {A B C:Type} (x:A->B->C) (y:A->B) (z:A) := x z (y z).

Theorem ki_f : forall (A B:Type)(x:A)(y:B), K I x y = F x y.
Proof.
  intros A B x y.
  unfold K.
  unfold I.
  unfold F.
  reflexivity.
Qed.

Theorem skk_i : forall (A B:Type)(x:A), S K (K:A->B->A) x = I x.
Proof.
  intros A B x.
  unfold S.
  unfold K.
  unfold I.
  reflexivity.
Qed.


Require Import Setoid Morphisms.

From mathcomp Require Import all_ssreflect.
From GraphTheory Require Import edone finite_quotient bij preliminaries.
From GraphTheory Require Import digraph sgraph treewidth minor checkpoint.
From GraphTheory Require Import setoid_bigop structures mgraph mgraph2.

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

Local Open Scope quotient_scope.
Set Bullet Behavior "Strict Subproofs".

(** * Skeletons *)

Section Skeleton.
Variables Lv Le : Type.
Notation graph := (graph Lv Le).

Definition adjacent (G : graph) (x y : G) :=
  [exists e, e \in edges x y :|: edges y x].

Lemma adjacent_sym (G : graph) : symmetric (@adjacent G).
Proof. move=> x y. by rewrite /adjacent setUC. Qed.

Lemma adjacentI (G : graph) (x y : G) (e : edge G) : e \in edges x y -> adjacent x y.
Proof. move=> He. apply/existsP. exists e. by rewrite inE He. Qed.

Arguments adjacentI [G x y] e _.

Lemma adjacent_edge (G : graph) (e : edge G) : adjacent (source e) (target e).
Proof. apply: (adjacentI e). by rewrite !inE. Qed.

(** The following lemma avoids the need for without loss of generality
reasoning (regarding the direction of the edge) when analyzing
[adjacent x y] *)
Lemma adjacentP (G : graph) (P : G -> G -> Prop) :
  Symmetric P ->
  (forall e : edge G, P (source e) (target e)) ->
  (forall x y : G,  adjacent x y -> P x y).
Proof.
  move=> S H x y. case/existsP=> e. rewrite !inE.
  case/orP=> /andP[/eqP<- /eqP<-] //. exact: S.
Qed.

Definition sk_rel (G : graph) := fun x y : G => (x != y) && adjacent x y.

Lemma sk_rel_sym (G : graph) : symmetric (@sk_rel G).
Proof. move=> x y. by rewrite /sk_rel/= eq_sym adjacent_sym. Qed.

Lemma sk_rel_irrefl (G : graph) : irreflexive (@sk_rel G).
Proof. move=> x. by rewrite /sk_rel/= eqxx. Qed.

Definition skeleton (G : graph) :=
  SGraph (@sk_rel_sym G) (@sk_rel_irrefl G).

Lemma skelP (G : graph) (P : G -> G -> Prop) :
  Symmetric P ->
  (forall e : edge G, source e != target e -> P (source e) (target e)) ->
  (forall x y : skeleton G, x -- y -> P x y).
Proof.
  move => S H x y. case/andP=> xNy. case/existsP=> e He. move: He xNy. rewrite !inE.
  case/orP=> /andP[/eqP<- /eqP<-]; last rewrite eq_sym; move=> /H//. exact: S.
Qed.

End Skeleton.

Coercion skeleton : graph >-> sgraph.

Section SSkeleton.
Variables (Lv : comMonoid) (Le : elabelType).
Notation graph := (graph Lv Le).
Notation graph2 := (graph2 Lv Le).

(** Edges of skeletons of quotients *)
Lemma sk_rel_mergeE (G : graph) (e : equiv_rel G) x y :
  @sk_rel _ _ (merge G e) x y <->
  x != y /\ exists x0 y0 : skeleton G, [/\ \pi x0 = x, \pi y0 = y & x0 -- y0].
Proof.
  rewrite /= /sk_rel.
  case: (boolP (x != y)) => //=; last by move => _; split => [|[]].
  move => xy; split.
  - move => A. split => //. move: xy. pattern x, y. apply adjacentP => //.
    + move => {x y A} x y H xy.
      case: H => [|x0 [y0] [? ? /andP [E A]]]; first by rewrite eq_sym.
      exists y0; exists x0. by rewrite /edge_rel/=/sk_rel eq_sym adjacent_sym A E.
    + move => e0. exists (@endpoint _ _ G false e0). exists (@endpoint _ _ G true e0).
      split => // ; last apply/andP;split => //.
      * apply: contraNN xy => /eqP H. by rewrite eqmodE H.
      * apply/existsP; exists e0. by rewrite !inE !eqxx.
  - case => _ [x0] [y0] [Px Py /andP [Dxy0]]. case/existsP => [e0 E].
    wlog E : x0 y0 x y Dxy0 Px Py {xy E} / e0 \in edges x0 y0.
    { move => W. case/setUP : E; first exact: W.
      rewrite adjacent_sym. apply: W => //. by rewrite eq_sym. }
    rewrite inE in E. case/andP : E => [E1 E2].
    apply/existsP; exists e0. by rewrite !inE /= (eqP E1) (eqP E2) Px Py !eqxx.
Qed.

Lemma hom_skel (G1 G2 : graph) (h: iso G1 G2) :
  {homo h : x y / (x : skeleton _) -- y}.
Proof.
  apply: skelP.
  - move => x y. by rewrite sgP.
  - move => e He. rewrite /edge_rel/=/sk_rel.
    rewrite bij_eq ?He //=. apply/existsP; exists (h.e e).
    rewrite !inE !endpoint_iso /=.
    case (h.d e)=>/=; by rewrite !eqxx.
Qed.

Instance skel_iso: CProper (iso ==> diso) (@skeleton Lv Le).
Proof.
  intros F G h. exists (iso_v h). apply: hom_skel. apply: (hom_skel (iso_sym h)).
Defined.

Lemma pi_hom (G : graph) (e : equiv_rel G) :
  hom_s (pi e : skeleton G -> skeleton (merge G e)).
Proof.
  move => x y xy Dxy. apply/sk_rel_mergeE. split => //. by exists x; exists y.
Qed.
Arguments pi_hom [G] e.

(** *** Strong skeletons *)

Definition sskeleton (G : graph2) := @sgraph.add_edge (skeleton G) input output.

Lemma sskelP (G : graph2) (P : G -> G -> Prop) :
  Symmetric P ->
  (forall e : edge G, source e != target e -> P (source e) (target e)) ->
  (input != output :> G -> P input output) ->
  (forall x y : sskeleton G, x -- y -> P x y).
Proof.
  move => S H IO x y. case/orP. exact: skelP.
  case/orP => /= /and3P [A /eqP ? /eqP ?];subst; first exact: IO.
  apply: S. exact: IO.
Qed.

(* Note: The proof below is a bit obsucre due to the abbiguity of [x -- y] *)
Lemma skel_sub (G : graph2) : sgraph.subgraph (skeleton G) (sskeleton G).
Proof. exists id => //= x y H _. exact: subrelUl. Qed.

(** Isomorphim Lemmas *)

Lemma hom2_sskel (G1 G2 : graph2) (h: iso2 G1 G2) :
  forall x y, @edge_rel (sskeleton G1) x y -> @edge_rel (sskeleton G2) (h x) (h y).
Proof.
  (* TODO: reuse [hom_skel] above? *)
  apply sskelP.
  - move => x y. by rewrite sgP.
  - move => e He. rewrite /edge_rel /=  [_ -- _](_ : _ = true) /= /edge_rel //=.
    rewrite /sk_rel /= bij_eq ?He //=. apply/existsP; exists (h.e e).
    rewrite !inE !endpoint_iso.
    case (h.d e)=>/=; by rewrite !eqxx.
  - move => H. by rewrite /edge_rel /= bij_eq // H iso2_input iso2_output !eqxx.
Qed.

Instance sskel_iso2: CProper (iso2 ==> diso) sskeleton.
Proof.
  intros F G h. exists (iso_v h). exact: hom2_sskel. exact:(hom2_sskel (iso2_sym h)).
Defined.

Lemma decomp_iso2 (G1 G2 : graph2) (T : forest) B1 :
  @sdecomp T (sskeleton G1) B1 -> G1 ≃2 G2 ->
  exists2 B2, @sdecomp T (sskeleton G2) B2 & width B2 = width B1.
Proof.
  move => dec iso. apply: decomp_iso dec _. exact: sskel_iso2.
Qed.

(** Bridging Lemmas *)

Lemma adjacent_induced (G : graph) (V : {set G}) (x y : induced V) :
  adjacent x y = adjacent (val x) (val y).
Proof.
  apply/existsP/existsP => -[e]; rewrite ?inE => He.
  - exists (val e). move: He. by rewrite !inE -!val_eqE.
  - suff eV : e \in edge_set V by exists (Sub e eV); rewrite !inE -!val_eqE.
    rewrite inE. case/orP: He => /andP[/eqP-> /eqP->]; apply/andP; split; exact: valP.
Qed.

Lemma edge_set_adj (G : graph2) (x y : G) :
  @edge_set _ _ G [set x; y] == set0 -> ~~ @adjacent _ _ G x y.
Proof.
  apply: contraTN => /existsP[e]. rewrite !inE => He.
  apply/set0Pn. exists e. rewrite !inE.
  by case/orP: He => /andP[->->]; rewrite orbT.
Qed.

Lemma sskeleton_subgraph_for (G : graph2) (V : {set G}) (E : {set edge G})
  (con : consistent V E) (i o : sig [eta mem V]) : val i = input -> val o = output ->
  sgraph.subgraph (sskeleton (point (subgraph_for con) i o)) (sskeleton G).
Proof.
  rewrite {2}/sskeleton/= => <- <-.
  exists val; first exact: val_inj.
  rewrite /hom_s. move => x y xy _. move: x y xy. apply sskelP.
  - move=> x y. by rewrite sg_sym.
  - move=> e sNt. apply/orP; left. apply/andP. split=> //. exact: adjacent_edge.
  - move=> /= iNo. by rewrite /edge_rel /= iNo !eqxx.
Qed.

Lemma sskeleton_adjacent (G : graph) (i o : G) :
  adjacent i o -> diso G (sskeleton (point G i o)).
Proof.
  move=> Aio.
  exists (bij_id: bij G (sskeleton (point G i o))) => /=.
  by move=>x y; rewrite {2}/edge_rel/= => ->.
  rewrite /is_dhom. apply sskelP.
  - move=> x y. by rewrite sg_sym.
  - rewrite /edge_rel/=/sk_rel => e ->. exact: adjacent_edge.
  - by rewrite /edge_rel/=/sk_rel => ->.
Qed.

Lemma remove_edge_add (G : graph) (e : edge G) :
  remove_edges [set e] ∔ [source e, elabel e, target e] ≃ G.
Proof.
  Iso bij_id (bijD1 e) xpred0. constructor => //.
  - by case => [f b|[|]].
  - by case => [f|] /=.
Defined.

Lemma remove_loops (G : graph) (E : {set edge G}) :
  {in E, forall e, source e = target e} ->
  diso G (remove_edges E).
Proof.
  move=> Eloops.
  have Esame x y : x != y -> @edges _ _ (remove_edges E) x y = val @^-1: @edges _ _ G x y.
  { move=> xNy. apply/setP=> e. by rewrite !inE. }
  exists (bij_id: bij G (remove_edges E)) => //= x y; rewrite /=/sk_rel => /andP[xNy].
  all: rewrite /edge_rel/=/sk_rel.
  all: rewrite xNy /adjacent/= !Esame // 1?eq_sym // -preimsetU.
  - case/existsP=> e He.
    suff H : e \notin E by apply/existsP; exists (Sub e H); rewrite inE.
    apply: contraNN xNy => /Eloops eq_e. move: He. rewrite !inE -eq_e.
    by case/orP=> /andP[/eqP<- /eqP<-].
  - case/existsP=> e. rewrite inE => He. apply/existsP. by exists (val e).
Qed.

Lemma remove_edges_connected (G : graph) (E : {set edge G}) :
  {in E, forall e : edge G, connect (@sk_rel _ _ (remove_edges E)) (source e) (target e)} ->
  connected [set: skeleton G] -> connected [set: skeleton (remove_edges E)].
Proof.
  move=> E_conn G_conn. apply: connectedTI => x y. have := connectedTE G_conn x y.
  apply: connect_sub x y. move=> /=. apply skelP.
  - by move=> x y; rewrite connect_symI //; exact: sk_rel_sym (remove_edges E).
  - move=> e sNt. case: (boolP (e \in E)) => [/E_conn//|He].
    apply: connect1. rewrite /edge_rel/=/sk_rel sNt /=.
    by apply/existsP; exists (Sub e He); rewrite !inE !eqxx.
Qed.

Lemma remove_edges_cross (G : graph) (V : {set G}) (E : {set edge G}) (x y : G) :
  E \subset edge_set V -> sk_rel x y -> y \notin V -> @sk_rel _ _ (remove_edges E) x y.
Proof.
  move=> E_subV xy yNV.
  have {yNV} : (x \notin V) || (y \notin V) by rewrite yNV.
  pattern x, y. revert x y xy.
  apply skelP ; first by move=> x y; rewrite orbC sk_rel_sym.
  move=> e sNt stNV. rewrite /sk_rel sNt /=.
  case: (boolP (e \in E)) => He; last first.
  - apply/existsP; exists (Sub e He); by rewrite !inE !eqxx.
  - move: He stNV => /(subsetP E_subV). rewrite inE. by case/andP=> -> ->.
Qed.

Lemma remove_edges_restrict (G : graph) (V : {set G}) (E : {set edge G}) (x y : G) :
  E \subset edge_set V -> connect (restrict (~: V) (@sk_rel _ _ G)) x y ->
  connect (@sk_rel _ _ (remove_edges E)) x y.
Proof.
  move=> E_subV. apply: connect_mono x y => x y /=. rewrite !inE -andbA.
  case/and3P=> xNV yNV xy. exact: remove_edges_cross xy yNV.
Qed.

Lemma sskeleton_remove_io (G : graph2) (E : {set edge G}) :
  E \subset @edge_set _ _ G IO ->
  diso (sskeleton (point (remove_edges E) input output)) (sskeleton G).
Proof.
  move=> E_subIO.
  exists (bij_id: bij (sskeleton (point (remove_edges E) input output)) (sskeleton G)) => //.
  all: rewrite /is_dhom; apply sskelP.
  - move=> x y. by rewrite sg_sym.
  - move=> e sNt. apply/orP; left. rewrite /edge_rel/=/sk_rel sNt /=. exact: adjacent_edge.
  - rewrite /edge_rel /= => ->. by rewrite !eqxx.
  - move=> x y. by rewrite sg_sym.
  - move=> e sNt /=. case: (boolP (e \in E)) => Ee; last first.
    + apply/orP; left. rewrite /edge_rel/=/sk_rel sNt /=. apply/existsP; exists (Sub e Ee).
      by rewrite !inE !eqxx.
    + move: Ee sNt => /(subsetP E_subIO). rewrite !inE /edge_rel/=.
      by case/andP=> /orP[]/eqP-> /orP[]/eqP->; rewrite !eqxx // eq_sym => ->.
  - rewrite /edge_rel/= => ->. by rewrite !eqxx.
Qed.

(** ** Interval and Bag Graphs *)

(** NOTE: for interval graphs, we need to remove self loops on the
ends, because these edges will be edges of the bag graph for the end
nodes. *)
Definition interval_edges (G : graph) (x y : G) :=
  edge_set (@interval G x y) :\: (edges x x :|: edges y y).

Lemma interval_edges_sym (G : graph) (x y : G) :
  interval_edges x y = interval_edges y x.
Proof. by rewrite /interval_edges interval_sym setUC. Qed.

Lemma igraph_proof (G : graph) (x y : skeleton G) :
  consistent (interval x y) (interval_edges x y).
Proof.
  move=> e. rewrite inE =>[b]. rewrite inE =>/andP [_ H].
  rewrite /edge_set in_set in H. move: H=>/andP[? ?]. by case b.
Qed.

Definition igraph (G : graph) (x y : skeleton G) :=
  @point (subgraph_for (@igraph_proof G x y))
         (Sub x (intervalL x y))
         (Sub y (intervalR x y)).

Definition bgraph (G : graph) (U : {set G}) (x:G) :=
  @point (induced (@bag G U x))
         (Sub x (@bag_id G U x))
         (Sub x (@bag_id G U x)).

Lemma bgraph_eq_io (G : graph) (U : {set G}) (x : G) : input = output :> @bgraph G U x.
Proof. by []. Qed.

Lemma interval_bag_edges_disj (G : graph) (U : {set G}) (x y : G) :
  connected [set: skeleton G] -> x \in @CP (skeleton G) U -> y \in @CP (skeleton G) U ->
  [disjoint edge_set (@bag G U x) & @interval_edges G x y].
Proof.
  move=> G_conn x_cp y_cp. rewrite -setI_eq0 -subset0. apply/subsetP => e.
  rewrite 3!inE => /and3P[]/andP[src_p tgt_p].
  rewrite 4!inE ![_ \in @interval G _ _]inE (lock sinterval) !inE -lock.
  rewrite negb_or !negb_and -!orbA => /andP[eNx eNy].
  case/andP=> /or3P[src_x|src_y|src_sI] /or3P[tgt_x|tgt_y|tgt_sI].
  all: move: eNx eNy; rewrite ?src_x ?src_y ?tgt_x ?tgt_y ?orbF //= => eNx eNy.
  - move: eNx. by rewrite (eqP tgt_y) -(@bag_cp G _ U) // -(eqP tgt_y) tgt_p.
  - by case: (disjointE (@interval_bag_disj G U x y y_cp) tgt_p tgt_sI).
  - move: eNx. by rewrite (eqP src_y) -(@bag_cp G _ U) // -(eqP src_y) src_p.
  - by case: (disjointE (@interval_bag_disj G U x y y_cp) tgt_p tgt_sI).
  - by case: (disjointE (@interval_bag_disj G U x y y_cp) src_p src_sI).
  - by case: (disjointE (@interval_bag_disj G U x y y_cp) src_p src_sI).
  - by case: (disjointE (@interval_bag_disj G U x y y_cp) src_p src_sI).
Qed.

Lemma bag_edges_disj (G : graph) (U : {set G}) (x y : G) :
  connected [set: skeleton G] -> x \in @CP G U -> y \in @CP G U -> x != y ->
  [disjoint edge_set (@bag G U x) & edge_set (@bag G U y)].
Proof.
  move=> G_conn x_cp y_cp xNy. rewrite -setI_eq0 -subset0. apply/subsetP => e.
  rewrite 3!inE. case/andP=> /andP[src_x tgt_x] /andP[src_y tgt_y].
  by case: (disjointE (@bag_disj G _ U x y _ _ _) src_x src_y).
Qed.

Lemma interval_edges_disj_cp (G : graph) (x y z : G) :
  z \in @cp G x y -> [disjoint interval_edges x z & interval_edges z y].
Proof.
  move=> z_cpxy. rewrite -setI_eq0 -subset0. apply/subsetP => e.
  rewrite 6!inE negb_or !negb_and. case/andP=> /and3P[_ src_Ixz tgt_Ixz].
  rewrite 5!inE negb_or !negb_and. case/and3P=> /andP[e_z _] src_Izy tgt_Izy.
  move: e_z.
  have : source e \in [set z] by rewrite -(intervalI_cp z_cpxy) inE src_Ixz src_Izy.
  rewrite inE =>->/=.
  have : target e \in [set z] by rewrite -(intervalI_cp z_cpxy) inE tgt_Ixz tgt_Izy.
  by rewrite inE =>->.
Qed.

Lemma interval_bag_edge_cover (G : graph) (x y : G) :
  connected [set: skeleton G] -> x != y ->
  [set: edge G] = edge_set (@bag G [set x; y] x) :|:
                  @interval_edges G x y :|:
                  edge_set (@bag G [set x; y] y).
Proof.
  move=> G_conn xNy. apply/eqP. rewrite eq_sym -subTset. apply/subsetP=> e _.
  move: (sinterval_bag_cover G_conn xNy) => compU.
  have : target e \in [set: G] by []. have : source e \in [set: G] by [].
  rewrite !{}compU !in_setU -!orbA.
  case: (boolP (source e \in @sinterval G x y)) => [Hsrc _|Nsrc /= Hsrc].
  + case: (boolP (target e \in @sinterval G x y)) => [Htgt _|Ntgt /= Htgt].
    { rewrite ![e \in _]inE ![_ \in @interval G _ _]inE Hsrc Htgt.
      rewrite !orbT negb_or !negb_and.
      suff [-> ->] : source e != x /\ source e != y by [].
      by split; apply: contraTneq Hsrc => ->; rewrite (@sinterval_bounds G). }
    wlog Htgt : x y xNy Hsrc Ntgt {Htgt} / target e \in @bag G [set x; y] x.
    { move=> Hyp. case/orP: Htgt; first exact: Hyp.
      rewrite setUC orbC orbAC orbC interval_edges_sym.
      apply: Hyp; rewrite 1?sinterval_sym //. by rewrite eq_sym. }
    have Nsrc : source e \notin @bag G [set x; y] x.
    { rewrite (disjointFl (@interval_bag_disj G _ x y _) Hsrc) //.
      apply: CP_extensive. by rewrite !inE eqxx. }
    have src_tgt : @sedge G (target e) (source e).
    { rewrite /=/sk_rel adjacent_sym adjacent_edge andbT.
      by apply: contraNneq Ntgt =>->. }
    have : target e = x := bag_exit_edge G_conn _ Htgt Nsrc src_tgt.
    move/(_ (CP_extensive _)). rewrite 3!inE eqxx => /(_ _)/Wrap[]// tgt_x.
    rewrite ![e \in _]inE tgt_x (@intervalL G) [_ \in @interval G _ _]inE Hsrc.
    rewrite orbT !andbT negb_or !negb_and.
    suff [->->] : source e != x /\ source e != y by [].
    by split; apply: contraTneq Hsrc =>->; rewrite (@sinterval_bounds G).
  + wlog Hsrc : x y xNy {Nsrc Hsrc} / source e \in @bag G [set x; y] x.
    { move=> Hyp. case/orP: Hsrc; first exact: Hyp.
      rewrite setUC sinterval_sym interval_edges_sym orbC orbAC orbC.
      rewrite [(e \in _) || _]orbC orbAC [_ || (e \in _)]orbC.
      by apply: Hyp; rewrite eq_sym. }
    case: (boolP (target e \in @bag G [set x; y] x)) => Ntgt /=.
      by rewrite [e \in _]inE Hsrc Ntgt.
    have src_tgt : @sedge G (source e) (target e).
    { rewrite /=/sk_rel adjacent_edge andbT. by apply: contraNneq Ntgt =><-. }
    have : source e = x := bag_exit_edge G_conn _ Hsrc Ntgt src_tgt.
    move/(_ (CP_extensive _)). rewrite 3!inE eqxx => /(_ _)/Wrap[]// src_x.
    case/orP=> Htgt.
    * rewrite ![e \in _]inE src_x (@intervalL G) (negbTE xNy) orbF eqxx/=.
      have -> : target e != x.
      { apply: contraTneq Htgt =>->. by rewrite (@sinterval_bounds G). }
      by have -> : target e \in @interval G x y by rewrite inE Htgt.
    * have Nsrc : source e \notin @bag G [set x; y] y.
      { have yNx : y != x by rewrite eq_sym.
        rewrite (disjointFl (bag_disj G_conn _ _ yNx) Hsrc) //;
        by apply: CP_extensive; rewrite !inE eqxx. }
      have := bag_exit_edge G_conn (CP_extensive _) Htgt Nsrc _.
      rewrite sg_sym 3!inE eqxx => /(_ _ src_tgt)/Wrap[]// tgt_y.
      rewrite ![e \in _]inE src_x tgt_y (@intervalL G) (@intervalR G).
      by rewrite !eqxx eq_sym (negbTE xNy).
Qed.

Lemma interval_cp_edge_cover (G : graph) (x y z : G) :
  connected [set: skeleton G] -> z \in @cp G x y :\: [set x; y] ->
  @interval_edges G x y = @interval_edges G x z :|:
                          edge_set (@bag G [set x; y] z) :|:
                          @interval_edges G z y.
Proof.
  move=> G_conn zPcpxy.
  have z_cpxy : z \in @cp G x y by move: z zPcpxy; apply/subsetP; exact: subsetDl.
  have z_cp : z \in @CP G [set x; y].
  { apply/bigcupP; exists (x, y); by [rewrite in_setX !in_set2 !eqxx |]. }
  have [x_cp y_cp] : x \in @CP G [set x; y] /\ y \in @CP G [set x; y]
    by split; apply: CP_extensive; rewrite !inE eqxx.
  apply/eqP. rewrite eqEsubset andbC !subUset [(_ \subset _) && _ && _]andbAC.
  apply/andP; split; first (apply/andP; split).
  - wlog suff : x y z zPcpxy {z_cpxy x_cp y_cp z_cp} /
                  interval_edges x z \subset interval_edges x y.
    { move=> Hyp. rewrite (Hyp x y z zPcpxy) /=.
      by rewrite interval_edges_sym (interval_edges_sym x) Hyp 1?cp_sym 1?setUC. }
    move: zPcpxy. rewrite in_setD in_set2 negb_or => /andP[]/andP[zNx zNy] z_cpxy.
    apply/subsetP=> e. rewrite ![e \in _]inE !negb_or.
    case/and3P=> /andP[eNx eNz] Hsrc Htgt. rewrite eNx /=.
    have -> : source e \in @interval G x y.
    { move: Hsrc. rewrite !in_setU !in_set1 -orbA.
      case/or3P=> [->//|/eqP->|/(subsetP (sinterval_sub G_conn z_cpxy))->//].
      move: z_cpxy => /(subsetP (cp_sub_interval G_conn _ _)).
      by rewrite !in_setU !in_set1. }
    have -> : target e \in @interval G x y.
    { move: Htgt. rewrite !in_setU !in_set1 -orbA.
      case/or3P=> [->//|/eqP->|/(subsetP (sinterval_sub G_conn z_cpxy))->//].
      move: z_cpxy => /(subsetP (cp_sub_interval G_conn _ _)).
      by rewrite !in_setU !in_set1. }
    rewrite /= andbT.
    suff : y \notin @interval G x z by apply: contraNN => /andP[/eqP<-].
    rewrite in_setU in_set2 [_ == z]eq_sym (negbTE zNy) orbF negb_or.
    apply/andP; split; first by apply: contraTneq z_cpxy =>->; rewrite cpxx inE.
    by rewrite inE negb_and !negbK (@cp_sym G y x) z_cpxy.
  - apply/subsetP=> e. rewrite ![e \in _]inE negb_or.
    have /subsetP PsubI := bag_sub_sinterval G_conn x_cp y_cp zPcpxy.
    case/andP=> /PsubI Hsrc /PsubI Htgt.
    rewrite ![_ \in @interval G x y]inE Hsrc Htgt !orbT /= andbT.
    apply/andP; split; apply: contraTN Hsrc => /andP[/eqP<-];
    by rewrite sinterval_bounds.
  - apply/subsetP=> e.
    rewrite in_setD andbC !in_setU inE (interval_cp_cover G_conn zPcpxy).
    rewrite negb_or 2!in_setU 2!(in_setU (target e)) => /andP[]/andP[].
    rewrite [(_ \in _) || _]orbC -2!orbA. case/orP=> Hsrc Htgt.
    + wlog Htgt : x y z zPcpxy Hsrc x_cp y_cp z_cp {z_cpxy Htgt} /
          (target e \in @bag G [set x; y] z) || (target e \in x |: @sinterval G x z).
      { case/or3P: Htgt => /= Htgt Hyp.
        * apply: Hyp => //; by rewrite Htgt.
        * apply: Hyp => //; by rewrite Htgt.
        * rewrite andbC orbC orbCA orbC setUC (interval_edges_sym x)interval_edges_sym.
          by apply: Hyp; rewrite setUC 1?cp_sym // sinterval_sym Htgt. }
      case/orP: Htgt => Htgt _; first by rewrite ![e \in _]inE Hsrc Htgt.
      case: (altP (source e =P target e)) => He.
        by rewrite ![e \in _]inE -He Hsrc.
      have src_tgt : @sedge G (source e) (target e).
      { by rewrite /=/sk_rel He adjacent_edge. }
      have zNx : z != x by move: zPcpxy; rewrite !inE negb_or -andbA => /and3P[].
      have Ntgt : target e \notin @bag G [set x; y] z.
      { move: Htgt; rewrite sinterval_sym in_setU1.
        case/orP=> [/eqP->|Htgt]; last first.
          by rewrite (disjointFl (interval_bag_disj _ x_cp) Htgt).
        apply/bagPn. exists x; by [|rewrite cpxx inE]. }
      move/cpP/(_ (edgep src_tgt)): (bag_exit G_conn z_cp Hsrc Ntgt).
      rewrite mem_edgep orbC. have /negbTE->/= : z != target e
        by apply: contraNneq Ntgt =><-; rewrite (@bag_id G).
      move=> /eqP Esrc. rewrite ![e \in _]inE -Esrc eqxx (negbTE zNx) /=.
      rewrite {1}Esrc eq_sym He (@intervalR G) in_setU in_set2.
      by move: Htgt; rewrite in_setU1; case/orP=>->.
    + wlog Hsrc : x y z zPcpxy x_cp y_cp z_cp Htgt z_cpxy {Hsrc} /
          source e \in x |: @sinterval G x z.
      { case/orP: Hsrc => /= Hsrc; first by [apply]; move=> Hyp.
        rewrite andbC orbC orbCA orbC setUC (interval_edges_sym x) interval_edges_sym.
        apply: Hyp; rewrite 1?[_ |: set1 _]setUC 1?cp_sym //.
        * by rewrite orbC orbAC orbC (@sinterval_sym G y) sinterval_sym.
        * by rewrite sinterval_sym. }
      case/or3P: Htgt => Htgt.
      * case/andP=> eNx _. rewrite 2!inE negb_or eNx 2!inE negb_and.
        have ->/= : source e != z.
        { apply: contraTneq Hsrc => ->.
          rewrite in_setU1 (@sinterval_bounds G) orbF.
          move: zPcpxy; rewrite in_setD in_set2 negb_or; by case/andP=> /andP[]. }
        have -> : source e \in @interval G x z.
        { by move: Hsrc; rewrite !in_setU !in_set1 => /orP[]->. }
        suff -> : target e \in @interval G x z by [].
        by move: Htgt; rewrite !in_setU !in_set1 => /orP[]->.
      * case: (altP (source e =P target e)) => He _.
          by rewrite ![e \in _]inE He Htgt.
        have tgt_src : @sedge G (target e) (source e).
        { by rewrite /=/sk_rel eq_sym He adjacent_sym adjacent_edge. }
        have zNx : z != x by move: zPcpxy; rewrite !inE negb_or -andbA => /and3P[].
        have Nsrc : source e \notin @bag G [set x; y] z.
        { move: Hsrc; rewrite sinterval_sym in_setU1.
          case/orP=> [/eqP->|Hsrc]; last first.
            by rewrite (disjointFl (interval_bag_disj _ x_cp) Hsrc).
          apply/bagPn. exists x; by [|rewrite cpxx inE]. }
        move/cpP/(_ (edgep tgt_src)): (bag_exit G_conn z_cp Htgt Nsrc).
        rewrite mem_edgep orbC. have /negbTE->/= : z != source e
          by apply: contraNneq Nsrc =><-; rewrite (@bag_id G).
        move=> /eqP Etgt. rewrite ![e \in _]inE -Etgt eqxx (negbTE zNx) andbF andbT /=.
        rewrite {1}Etgt He (@intervalR G) in_setU in_set2.
        by move: Hsrc; rewrite in_setU1; case/orP=>->.
      * case: (altP (source e =P target e)) Hsrc Htgt => [<-|He Hsrc Htgt].
        { rewrite !in_setU1; case/orP=> [/eqP->|Hsrc].
          - rewrite inE z_cpxy /= orbF => /eqP Exy.
            move: zPcpxy. by rewrite -Exy cpxx setUid setDv inE.
          - rewrite (disjointFr (sinterval_disj_cp z_cpxy) Hsrc) orbF => /eqP Htgt.
            move: Hsrc. by rewrite Htgt inE (@cp_sym G y x) z_cpxy andbF. }
        have {He} He : @sedge G (source e) (target e).
        { by rewrite /=/sk_rel He adjacent_edge. }
        have [/negbTE srcNz /negbTE tgtNz] : source e != z /\ target e != z.
        { split; [apply: contraTneq Hsrc|apply: contraTneq Htgt]=>->.
          all: rewrite in_setU1 negb_or inE mem_cpl ?andbF andbT.
          all: move: zPcpxy; by rewrite !inE negb_or -andbA =>/and3P[]. }
        have {Hsrc} Hsrc : source e \in @interval G x z.
        { move: Hsrc; rewrite /interval !in_setU !in_set1 => /orP[/eqP->|->//].
          by rewrite eqxx. }
        have {Htgt} Htgt : target e \in @interval G z y.
        { move: Htgt; rewrite /interval !in_setU !in_set1 => /orP[/eqP->|->//].
          by rewrite eqxx. }
        have := interval_edge_cp z_cpxy He Hsrc Htgt. by rewrite srcNz tgtNz.
Qed.

Lemma has_edge (G : graph) (x y : G) :
  connected [set: skeleton G] -> x != y -> 0 < #|edge G|.
Proof.
  move/connectedTE/(_ x y). case/connect_irredP => p _ xy.
  case: (splitL p xy) => x' [/= xx'] _. apply/card_gt0P.
  case/andP: xx' => _. case/existsP=> e _. by exists e.
Qed.

(* Is this the most general type? *)
Lemma card_val (T : finType) (P : pred T) (s : subFinType P) (A : pred s) :
  #|val @: A| = #|A|.
Proof. by rewrite card_imset. Qed.

(* lifting connectedness from the skeleton *)
Lemma connected_skeleton' (G : graph) V E (con : @consistent _ _ G V E) :
  forall U : {set subgraph_for con}, @connected (skeleton G) (val @: U) ->
  (forall e, e \in edge_set (val @: U) -> source e != target e ->
             let x := source e in let y := target e in
             exists2 e, e \in E & (e \in edges x y) || (e \in edges y x)) ->
  @connected (skeleton (subgraph_for con)) U.
Proof.
  move => U. set U' := val @: U => conn_U all_edges x y x_U y_U.
  case/connectP: (conn_U _ _ (imset_f val x_U) (imset_f val y_U)) => p.
  elim: p x x_U => [|a p IH] x x_U; first by move=> _ /val_inj <-; exact: connect0.
  rewrite (lock edge_rel) /= -!andbA -lock. case/and4P=> _ a_U' xa.
  have Ha : a \in V by case/imsetP: a_U' => b _ ->; exact: valP.
  set b : subgraph_for con := Sub a Ha. rewrite -[a]/(val b) => p_path p_last.
  have b_U : b \in U by rewrite -(mem_imset _  _ val_inj).
  apply: connect_trans (IH b b_U p_path p_last). apply: connect1 => /=.
  apply/andP; split; first by apply/andP; split. move: xa.

  rewrite -[a]/(val b).
  move: b x b_U x_U {p_last p_path a_U' IH p} => {a Ha} b x b_U x_U.
  rewrite /edge_rel/=/sk_rel -val_eqE. case/andP=> xNb. rewrite xNb /= => adjv_xb.
  wlog [e0] : b x b_U x_U xNb {adjv_xb} / exists e, e \in edges (val x) (val b).
  { move=> Hyp. case/existsP: adjv_xb => e. rewrite inE => /orP[]He.
    - by apply: Hyp => //; exists e.
    - rewrite adjacent_sym. apply: Hyp => //; by [rewrite eq_sym | exists e]. }
  rewrite inE. case/andP=> /eqP Hsrc /eqP Htgt.
  have Ne0 : source e0 != target e0 by rewrite Hsrc Htgt.
  have : e0 \in edge_set U' by rewrite inE Hsrc Htgt !imset_f.
  case/all_edges=> [//|] e' Ee'. rewrite Hsrc Htgt => He'.
  set e : edge (subgraph_for con) := Sub e' Ee'.
  have He : e \in edges x b :|: edges b x.
  { move: He'. by rewrite !inE -[e']/(val e) -!(inj_eq val_inj). }
  apply/existsP. by exists e.
Qed.

Lemma connected_skeleton (G : graph) V E (con : @consistent _ _ G V E) :
  forall U : {set subgraph_for con}, @connected (skeleton G) (val @: U) ->
  (forall e, e \in edge_set (val @: U) -> source e != target e -> e \in E) ->
  @connected (skeleton (subgraph_for con)) U.
Proof.
  move=> U conn_U all_edges. apply: connected_skeleton' conn_U _.
  move=> e E1 E2; exists e; rewrite ?inE ?eqxx //. exact: all_edges.
Qed.

Lemma connected_bgraph (G : graph2) (U : {set G}) (x : G) :
  connected [set: skeleton G] -> x \in @CP (skeleton G) U ->
  connected [set: skeleton (bgraph U x)].
Proof.
  move => conn_G cp_x.
  apply: connected_skeleton; rewrite imset_valT memKset //. exact: connected_bag.
Qed.

Lemma connected_igraph (G : graph2) (x y: G) :
  connected [set: skeleton G] ->
  connected [set: skeleton (igraph x y)].
Proof.
  move=> conn_G. apply: connected_skeleton; rewrite imset_valT memKset.
  + exact: connected_interval.
  + move => e E1 E2. rewrite 4!inE E1 andbT negb_or. apply/andP;split.
    * apply: contraNN E2 => /andP [/eqP -> /eqP ->]; by rewrite eqxx.
    * apply: contraNN E2 => /andP [/eqP -> /eqP ->]; by rewrite eqxx.
Qed.

Lemma iso_pointxx (G : graph) (x : G) :
  diso (sskeleton (point _ x x)) (skeleton G).
Proof.
  exists (bij_id : bij (sskeleton (point G x x)) (skeleton G)) => u v /=.
  - case/or3P => // /and3P[uNv /eqP eq1 /eqP eq2];
    move: uNv; by rewrite eq1 eq2 eqxx.
  - by rewrite {2}/edge_rel/= => ->.
Qed.

Lemma sub_pointxx (G : graph) (x:G) :
  sgraph.subgraph (sskeleton (point _ x x))
                  (skeleton G).
Proof. apply: iso_subgraph; exact: iso_pointxx. Qed.

(* The subgraph relation lifts to skeletons *)
Lemma sub_sub (G H : graph) :
  subgraph G H -> sgraph.subgraph G H.
Proof.
  case => hv [he] [hd] [hom] [inj_hv inj_he].
  exists hv => // x y xy _. move: x y xy.
  apply skelP; first by move=> x y; rewrite sg_sym.
  move=> e sNt. (* by *) rewrite /edge_rel/=/sk_rel (inj_eq inj_hv) sNt.
  generalize (endpoint_ihom (is_ihom:=hom) e false).
  generalize (endpoint_ihom (is_ihom:=hom) e true).
  case (hd e)=>/= <- <-.
  by rewrite adjacent_sym adjacent_edge.
  by apply adjacent_edge.
Qed.

Definition flesh_out_graph (G : sgraph) sym0 tt (z : G) : graph2 :=
  {| graph_of :=
       {| vertex := G ; edge := [finType of { p : G * G | p.1 -- p.2 }];(* TODO: avoid clones? *)
          endpoint b e := if b then snd (val e) else (val e).1;
          vlabel _ := tt;
          elabel := fun _ => sym0 |} ;
     input := z; output := z |}.

Lemma flesh_out (G : sgraph) (sym0 : Le) (tt: Lv) (z : G) :
  { G' & (diso (sskeleton G') G * diso (skeleton G') G)%type}.
Proof.
  pose G' := flesh_out_graph sym0 tt z. exists G'.
  suff iso : diso (skeleton G') G.
  { split=> //. rewrite <-iso. exact: iso_pointxx. }
  exists (bij_id : bij (skeleton G') G) => x y; rewrite /sk_rel.
  - case/andP=> _ /existsP[][/=][u v /=] uv. rewrite !inE /=.
    case/orP=> /andP[/eqP<- /eqP<-] //; by rewrite sg_sym.
  - move=> xy. rewrite /edge_rel/=/sk_rel sg_edgeNeq //=.
    apply/existsP; exists (Sub (x, y) xy). by rewrite !inE !eqxx.
Qed.

(** *** Disjoint Union of a connected component and the remainder of the graph *)

Lemma edge_component (G : graph) (e : edge G) :
  @component_of G (source e) = @component_of G (target e).
Proof.
  case: (altP (source e =P target e)) => [->//|sDt].
  apply: same_pblock => //. apply/components_pblockP.
  have st : (source e : skeleton G) -- (target e) .
  { by rewrite /edge_rel/=/sk_rel sDt adjacent_edge. }
  by exists (prev (edgep st)).
Qed.
Opaque merge.

Arguments unl [Lv Le G H] x : simpl never.
Arguments unr [Lv Le G H] x : simpl never.

Lemma edge_set_component (G : graph) (C : {set skeleton G}) (e : edge G) :
  C \in @components G [set: G] -> (source e \in C) = (target e \in C).
Proof.
  move => comp_C. apply/idP/idP.
  - move => inC. rewrite (mem_component comp_C inC).
    by rewrite edge_component (@in_component_of G).
  - move => inC. rewrite (mem_component comp_C inC).
    by rewrite -edge_component (@in_component_of G).
Qed.
Arguments edge_set_component [G C e].

(* if C is a component, this becomes an equivalence *)
Lemma edge_setN (G : graph) (C : {set G}) (e : edge G):
  e \in edge_set C -> e \notin edge_set (~: C).
Proof. rewrite !inE. by case/andP => -> ->. Qed.

Lemma edge_comp (G : graph) (C : {set G}) (e : edge G):
  C \in components [set: skeleton G] ->
  (e \in edge_set C) + (e \in edge_set (~: C))%type.
Proof.
  move => comp_C. case: (boolP (source e \in C)) => p; [left|right].
  - by rewrite inE -(edge_set_component comp_C) p.
  - by rewrite !inE -(edge_set_component comp_C) p.
Qed.

Section IsoComponents.
Variables (G : graph) (C : {set G}).
(* TODO: suffices that there is no edge between [C] and [~:C] *)
Hypothesis comp_C : C \in components [set: skeleton G].
Let G1 := induced C.
Let G2 := induced (~: C).

Lemma decC z : (z \in C) + (z \in ~: C)%type.
Proof. case: (boolP (z \in C)) => p; [by left|right]. by rewrite inE p. Qed.

Lemma decE (e : edge G) : (e \in edge_set C) + (e \in edge_set (~: C)).
Proof. exact: edge_comp. Qed.

Definition component_v (x : union G1 G2) := match x with inl x => val x | inr x => val x end.
Definition component_v' (z : G) : union G1 G2 :=
    match decC z with inl p => inl (Sub z p) | inr p => inr (Sub z p) end.

Definition component_e (e : edge (union G1 G2)) := match e with inl e => val e | inr e => val e end.
Definition component_e' (e : edge G) : edge (union G1 G2) :=
    match decE e with inl p => inl (Sub e p) | inr p => inr (Sub e p) end.

Lemma component_can_v : cancel component_v component_v'.
Proof.
  case => a; rewrite /component_v/component_v'; case: (decC _) => p.
  - congr inl. exact: val_inj.
  - exfalso. move: (valP a) => /= X. by rewrite inE X in p.
  - exfalso. move: (valP a) => /=. by rewrite inE p.
  - congr inr. exact: val_inj.
Qed.

Lemma component_can_v' : cancel component_v' component_v.
Proof. by move => x; rewrite /component_v/component_v'; case: (decC x). Qed.

Lemma component_can_e : cancel component_e component_e'.
Proof.
  case => e; rewrite /component_e/component_e'; case: (decE _) => p.
  - congr inl. exact: val_inj.
  - exfalso. move: (valP e) => /= /edge_setN X. by contrab.
  - exfalso. move: (valP e) => /= X. move/edge_setN in p. by rewrite X in p.
  - congr inr. exact: val_inj.
Qed.

Lemma component_can_e' : cancel component_e' component_e.
Proof. move => x; rewrite /component_e/component_e'; by case (decE _). Qed.

Lemma component_hom : is_ihom component_v component_e xpred0.
Proof. repeat split; by case. Qed.

Definition iso_component : iso (union (induced C) (induced (~: C))) G :=
  Eval hnf in Iso' component_can_v component_can_v' component_can_e component_can_e' component_hom.

End IsoComponents.

End SSkeleton.


Require Import Coq.ZArith.Zpower Coq.ZArith.ZArith.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZUtil.
Require Import Coq.Lists.List.

Local Open Scope Z_scope.

Section Pow2Base.
  Context (limb_widths : list Z).
  Local Notation "w[ i ]" := (nth_default 0 limb_widths i).
  Fixpoint base_from_limb_widths limb_widths :=
    match limb_widths with
    | nil => nil
    | w :: lw => 1 :: map (Z.mul (two_p w)) (base_from_limb_widths lw)
    end.
  Local Notation base := (base_from_limb_widths limb_widths).
  Definition bounded us := forall i, 0 <= nth_default 0 us i < 2 ^ w[i].
  Definition upper_bound := 2 ^ (sum_firstn limb_widths (length limb_widths)).
End Pow2Base.