(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect.
From mathcomp Require boolp.
From mathcomp Require Import Rstruct.
Require Import Reals Lra.
Require Import ssrR Reals_ext Ranalysis_ext logb convex.

(******************************************************************************)
(*                      Results about the Analysis of ln                      *)
(*                                                                            *)
(* Section ln_id_sect.                                                        *)
(*   about the function x |-> ln x - (x - 1)                                  *)
(* Section xlnx_sect.                                                         *)
(*   about the function x |-> x * ln x                                        *)
(* Section diff_xlnx                                                          *)
(*   about the function x |-> xlnx (1 - x) - xlnx x.                          *)
(* Section Rabs_xlnx                                                          *)
(*   proof that | x - y | <= a implies | xlnx x - xlnx y | <= - xlnx a        *)
(* Section log_concave                                                        *)
(*   concavity of log                                                         *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope R_scope.

Import Order.Theory.

Section ln_id_sect.

Definition ln_id x := ln x - (x - 1).

Lemma pderivable_ln_id_xle1 : pderivable ln_id (fun x => 0 < x <= 1).
Proof.
rewrite /pderivable => x Hx.
rewrite /ln_id.
apply derivable_pt_plus.
- apply derivable_pt_ln, Hx.
- apply derivable_pt_opp, derivable_pt_minus;
    [apply derivable_pt_id | apply derivable_pt_cst].
Defined.

Definition ln_id' x (H : 0 < x <= 1) := derive_pt ln_id x (pderivable_ln_id_xle1 H).

Lemma derive_pt_ln_id_xle1 : forall x (Hx : 0 < x <= 1), (/ x) - 1 = ln_id' Hx.
Proof.
move=> y Hy.
rewrite /ln_id' /pderivable_ln_id_xle1 /ln_id.
rewrite derive_pt_plus derive_pt_opp derive_pt_ln derive_pt_minus derive_pt_id derive_pt_cst.
rewrite subR0.
reflexivity.
Defined.

Lemma derive_pt_ln_id_xle1_ge0 x (Hx : 0 < x <= 1) : 0 < if x==1 then 1 else ln_id' Hx.
Proof.
case/boolP : (x == 1) => Hcase ; first lra.
rewrite -derive_pt_ln_id_xle1; apply/subR_gt0.
rewrite -invR1; apply ltR_inv => //; first by case: Hx.
case (Rle_lt_or_eq_dec x 1) ; [apply Hx | by [] | ].
move/eqP in Hcase ; move => Habs.
rewrite Habs in Hcase ; by contradict Hcase.
Defined.

Lemma ln_idlt0_xlt1 : forall x, 0 < x < 1 -> ln_id x < 0.
Proof.
rewrite {2}(_ : 0 = ln_id 1); last by rewrite /ln_id ln_1 2!subRR.
move=> x Hx.
have lt01 : 0 < 1 by lra.
apply (pderive_increasing lt01 derive_pt_ln_id_xle1_ge0).
- by split; [apply Hx | apply ltRW, Hx].
- lra.
- by apply Hx.
Qed.

Lemma ln_idlt0_xgt1 x : 0 < x -> 1 < x -> ln_id x < 0.
Proof.
move=> x0 x1.
rewrite /ln_id; apply/subR_lt0/exp_lt_inv.
rewrite (exp_ln _ x0) -{1}(addR0 x) -(subRR 1) addRCA.
have ? : x - 1 <> 0 by exact/eqP/gtR_eqF/subR_gt0. (* for Coq 8.14 *)
have ? : 0 < x - 1 by exact/subR_gt0. (* for Coq 8.13 *)
exact/exp_ineq1.
Qed.

Lemma ln_idgt0 x : 0 < x -> ln_id x <= 0.
Proof.
case: (ltgtP x 1) => [| |] x1 x0.
- by apply/ltRW/ln_idlt0_xlt1; split=> //; apply/RltP.
- by apply/ltRW/ln_idlt0_xgt1 => //; exact/RltP.
- by rewrite x1 /ln_id ln_1 2!subRR; exact/leRR.
Qed.

Lemma ln_id_cmp x : 0 < x -> ln x <= x - 1.
Proof. by move=> Hx; apply Rminus_le; apply ln_idgt0; exact Hx. Qed.

Lemma log_id_cmp x : 0 < x -> log x <= (x - 1) * log (exp 1).
Proof.
by move=> x0; rewrite logexp1E; apply leR_wpmul2r;
  [exact/invR_ge0 | exact/ln_id_cmp].
Qed.

Lemma ln_id_eq x : 0 < x -> ln x = x - 1 -> x = 1.
Proof.
move=> Hx' Hx.
case (total_order_T x 1) => [ [] // Hx2 | Hx2]; contradict Hx.
- apply/eqP/ltR_eqF; rewrite -subR_lt0.
  apply ln_idlt0_xlt1; split; [exact Hx' | exact Hx2].
- by apply/eqP/ltR_eqF; rewrite -subR_lt0; exact: ln_idlt0_xgt1.
Qed.

Lemma log_id_eq x : 0 < x -> log x = (x - 1) * log (exp 1) -> x = 1.
Proof.
move=> Hx'; rewrite logexp1E.
rewrite eqR_mul2r; last exact/nesym/eqP/ltR_eqF/invR_gt0.
apply ln_id_eq; by [apply Hx' | apply Hx].
Qed.

End ln_id_sect.

Section xlnx_sect.

Section xlnx.

Definition xlnx := fun x => if 0 <b x then x * ln x else 0.

Lemma xlnx_0 : xlnx 0 = 0.
Proof. rewrite /xlnx mul0R; by case : ifP. Qed.

Lemma xlnx_1 : xlnx 1 = 0.
Proof. rewrite /xlnx ln_1 mulR0 ; by case : ifP. Qed.

Lemma xlnx_neg x : 0 < x < 1 -> xlnx x < 0.
Proof.
case => lt0x ltx1.
rewrite /xlnx.
have -> : 0 <b x ; first by apply/ltRP.
rewrite -(oppRK 0) ltR_oppr oppR0 -mulRN.
apply mulR_gt0 => //.
rewrite ltR_oppr oppR0.
apply exp_lt_inv.
by rewrite exp_ln // exp_0.
Qed.

Lemma continue_xlnx : continuity xlnx.
Proof.
rewrite /continuity => r.
rewrite /continuity_pt /continue_in /limit1_in /limit_in => eps eps_pos /=.
case (total_order_T 0 r) ; first case ; move=> Hcase.
- have : continuity_pt (fun x => x * ln x) r.
    apply continuity_pt_mult.
      by apply derivable_continuous_pt, derivable_id.
    by apply derivable_continuous_pt, derivable_pt_ln.
  rewrite /continuity_pt /continue_in /limit1_in /limit_in => /(_ eps eps_pos).
  case => /= k [k_pos Hk].
  exists (Rmin k r); split; first exact/Rlt_gt/Rmin_pos.
  - move=> x ; rewrite /D_x ; move => [[_ Hx1] Hx2].
    rewrite /xlnx.
    have -> : 0 <b x.
      apply/ltRP.
      rewrite -(addR0 x) -{2}(subRR r) addRA addRAC.
      apply (@leR_ltR_trans ((x + - r) + `| x + - r |)).
        rewrite addRC -leR_subl_addr sub0R -normRN; exact: Rle_abs.
      rewrite /R_dist in Hx2.
      apply/ltR_add2l/(@ltR_leR_trans (Rmin k r)) => //; exact: geR_minr.
    have -> : 0 <b r by apply/ltRP.
    apply Hk.
    split => //.
    exact/(ltR_leR_trans Hx2)/geR_minl.
- subst r.
  exists (exp (- 2 * / eps)).
  split ; first exact: exp_pos.
  move=> x; rewrite /R_dist subR0; case=> Hx1 Hx2.
  rewrite /xlnx ltRR'.
  case: ifPn => Hcase; move/ltRP in Hcase.
  + rewrite (geR0_norm _ (ltRW Hcase)) in Hx2.
    rewrite subR0 -{1}(exp_ln _ Hcase).
    set X := ln x.
    have X_neg : X < 0.
      apply (@ltR_trans (-2 * / eps)).
      by apply exp_lt_inv; subst X; rewrite exp_ln.
      rewrite mulNR.
      exact/oppR_lt0/divR_gt0.
    apply: (@ltR_leR_trans (2 * / (- X))).
    * rewrite ltR0_norm; last first.
        rewrite -(mulR0 (exp X)) ltR_pmul2l => //; exact: exp_pos.
      rewrite -mulRN.
      apply (@ltR_pmul2r (/ - X)); first exact/invR_gt0/oppR_gt0.
      rewrite -mulRA mulRV ?mulR1; last by rewrite oppR_eq0; apply/ltR_eqF.
      rewrite -(invRK 2); last exact/eqP.
      rewrite -mulRA ( _ : forall r, r * r = r ^ 2); last by move=> ?; rewrite /pow mulR1.
      rewrite expRV; last exact/eqP/not_eq_sym/eqP/ltR_eqF/oppR_gt0.
      rewrite -invRM; last 2 first.
        by rewrite invR_neq0' //; exact/gtR_eqF.
        by rewrite expR_eq0 oppR_eq0; exact/ltR_eqF.
      rewrite -(invRK (exp X)); last exact/gtR_eqF/exp_pos.
      apply ltR_inv => //.
        exact/invR_gt0/exp_pos.
        by apply/mulR_gt0; [lra | apply expR_gt0; lra].
      rewrite -exp_Ropp mulRC (_ : 2 = INR 2`!) //.
      exact/exp_strict_lb/oppR_gt0.
    * apply (@leR_pmul2r (/ 2)); first exact/invR_gt0.
      rewrite mulRC mulRA mulVR ?mul1R //; last exact/gtR_eqF.
      rewrite -(invRK eps); last exact/gtR_eqF.
      rewrite -invRM //; last 2 first.
        exact/gtR_eqF/invR_gt0.
        exact/eqP.
      apply leR_inv => //.
      - by apply/mulR_gt0 => //; exact: invR_gt0.
      - rewrite leR_oppr mulRC -mulNR.
        by apply/exp_le_inv/ltRW; subst X; rewrite exp_ln.
  + by rewrite subRR normR0.
- exists (- r); split; first exact/oppR_gt0.
  move=> x [[_ Hx1] Hx2].
  rewrite /R_dist /xlnx.
  have -> : 0 <b x = false.
    apply/ltRP/leRNgt.
    rewrite -(addR0 x) -{1}(subRR r) addRA addRAC.
    apply (@leR_trans ((x + - r) - `| x + - r |)).
      apply/leR_add2l/ltRW; by rewrite ltR_oppr.
    exact/Rle_minus/Rle_abs.
  have -> : 0 <b r = false by apply/negbTE; rewrite -leRNgt'; apply/leRP/ltRW.
  by rewrite subRR normR0.
Qed.

(* TODO: not used *)
Lemma uniformly_continue_xlnx : uniform_continuity xlnx (fun x => 0 <= x <= 1).
Proof.
apply Heine ; first by apply compact_P3.
move=> x _ ; by apply continue_xlnx.
Qed.

Let xlnx_total := fun y => y * ln y.

Lemma derivable_xlnx_total x : 0 < x -> derivable_pt xlnx_total x.
Proof.
move=> x_pos.
apply derivable_pt_mult.
  by apply derivable_id.
by apply derivable_pt_ln.
Defined.

Lemma xlnx_total_xlnx x : 0 < x -> xlnx x = xlnx_total x.
Proof. by rewrite /xlnx /f => /ltRP ->. Qed.

Lemma derivable_pt_xlnx x (x_pos : 0 < x) : derivable_pt xlnx x.
Proof. apply (@derivable_f_eq_g _ _ x 0 xlnx_total_xlnx x_pos (derivable_xlnx_total x_pos)). Defined.

Lemma derive_xlnx_aux1 x (x_pos : 0 < x) :
  derive_pt xlnx x (derivable_pt_xlnx x_pos) =
  derive_pt xlnx_total x (derivable_xlnx_total x_pos).
Proof. by rewrite -derive_pt_f_eq_g. Qed.

Lemma derive_xlnx_aux2 x (x_pos : 0 < x) : derive_pt xlnx x (derivable_pt_xlnx x_pos) = ln x + 1.
Proof.
rewrite derive_xlnx_aux1 /f derive_pt_mult derive_pt_ln.
rewrite mulRV ?gtR_eqF //.
rewrite (_ : derive_pt ssrfun.id x (derivable_id x) = 1) ; first by rewrite mul1R.
by rewrite -(derive_pt_id x); apply proof_derive_irrelevance.
Qed.

Lemma derive_pt_xlnx x (x_pos : 0 < x) (pr : derivable_pt xlnx x) : derive_pt xlnx x pr = ln x + 1.
Proof. rewrite -derive_xlnx_aux2 ; by apply proof_derive_irrelevance. Qed.

Lemma pderivable_Ropp_xlnx : pderivable (fun y => - xlnx y) (fun x => 0 < x <= exp (- 1)).
Proof.
move=> x /= Hx.
apply derivable_pt_opp.
apply derivable_pt_xlnx.
apply Hx.
Defined.

Lemma xlnx_sdecreasing_0_Rinv_e_helper : forall (t : R) (Ht : 0 < t <= exp (-1)),
  0 < (if t == exp (-1) then 1 else derive_pt (fun x => - xlnx x) t (pderivable_Ropp_xlnx Ht)).
Proof.
move=> t [t0 te]; case: ifPn => [//|] /eqP Hcase.
rewrite derive_pt_opp derive_pt_xlnx //.
rewrite ltR_oppr oppR0 addRC -ltR_subRL sub0R.
apply exp_lt_inv; by rewrite exp_ln // ltR_neqAle.
Qed.

Lemma xlnx_sdecreasing_0_Rinv_e x y :
  0 <= x <= exp (-1) -> 0 <= y <= exp (-1) -> x < y -> xlnx y < xlnx x.
Proof.
move=> [x1 x2] [y1 y2] xy.
case/boolP : (x == 0) => [/eqP ->|x0].
- rewrite xlnx_0; apply xlnx_neg.
  exact: (conj (@leR_ltR_trans x _ _ _ _) (leR_ltR_trans y2 ltRinve1)).
- rewrite -[X in _ < X]oppRK ltR_oppr.
  have {}x0 : 0 < x by apply/ltRP; rewrite lt0R x0; exact/leRP.
  have {x1 y1}y0 : 0 < y by exact: (@ltR_trans x).
  exact: (pderive_increasing (exp_pos _) xlnx_sdecreasing_0_Rinv_e_helper).
Qed.

Lemma xlnx_decreasing_0_Rinv_e x y :
  0 <= x <= exp (-1) -> 0 <= y <= exp (-1) -> x <= y -> xlnx y <= xlnx x.
Proof.
move=> Hx Hy Hxy.
case/boolP : (x == y) => [/eqP ->|/eqP H]; first exact/leRR.
by apply/ltRW/xlnx_sdecreasing_0_Rinv_e => //; rewrite ltR_neqAle.
Qed.

End xlnx.

Section diff_xlnx.

Definition diff_xlnx := fun x => xlnx (1 - x) - xlnx x.

Lemma derivable_pt_diff_xlnx x (Hx : 0 < x < 1) : derivable_pt diff_xlnx x.
Proof.
rewrite /diff_xlnx.
apply derivable_pt_plus ; last by apply derivable_pt_opp, derivable_pt_xlnx, Hx.
apply (derivable_pt_comp (fun x => 1 + - x) xlnx).
  apply derivable_pt_plus ; first by apply derivable_pt_const.
  apply derivable_pt_Ropp.
apply derivable_pt_xlnx.
rewrite subR_gt0; by case: Hx.
Defined.

Lemma derive_pt_diff_xlnx x (Hx : 0 < x < 1) :
  derive_pt diff_xlnx x (derivable_pt_diff_xlnx Hx) = -(2 + ln (x * (1-x))).
Proof.
rewrite derive_pt_plus derive_pt_opp derive_pt_xlnx; last by apply Hx.
rewrite derive_pt_comp derive_pt_plus derive_pt_const.
rewrite derive_pt_xlnx /=; last first.
  rewrite subR_gt0; by case: Hx.
rewrite add0R ln_mult; first field.
- by apply Hx.
- rewrite subR_gt0; by case: Hx.
Qed.

Lemma diff_xlnx_0 : diff_xlnx 0 = 0.
Proof. by rewrite /diff_xlnx subR0 xlnx_0 xlnx_1 subRR. Qed.

Lemma diff_xlnx_1 : diff_xlnx 1 = 0.
Proof. by rewrite /diff_xlnx subRR xlnx_0 xlnx_1 subRR. Qed.

Lemma derive_diff_xlnx_neg_aux x (Hx : 0 < x < 1) : x < exp (-2) -> 0 < derive_pt diff_xlnx x (derivable_pt_diff_xlnx Hx).
Proof.
rewrite derive_pt_diff_xlnx; case: Hx => Hx1 Hx2 xltexp2.
rewrite oppRD subR_gt0.
apply exp_lt_inv.
rewrite exp_ln ; last first.
  apply mulR_gt0 => //; by rewrite subR_gt0.
apply (@ltR_trans (exp (-2) * (1 - x))).
  apply ltR_pmul2r => //; by rewrite ltR_subRL addR0.
rewrite -{2}(mulR1 (exp (-2))).
apply ltR_pmul2l; first exact: exp_pos.
apply (@ltR_add2r (-1)).
by rewrite addRAC -[X in _ < X](addR0 _) ltR_add2l ltR_oppl oppR0.
Qed.

Lemma derive_diff_xlnx_pos x (Hx : 0 < x < 1) (pr : derivable_pt diff_xlnx x) :
  x < exp (-2) -> 0 < derive_pt diff_xlnx x pr.
Proof.
rewrite (proof_derive_irrelevance _ (derivable_pt_diff_xlnx Hx)) //.
exact: derive_diff_xlnx_neg_aux.
Qed.

Lemma diff_xlnx_sincreasing_0_Rinv_e2 : forall x y : R, 0 <= x <= exp (-2) -> 0 <= y <= exp (-2) -> x < y -> diff_xlnx x < diff_xlnx y.
Proof.
apply derive_sincreasing_interv.
- move=> x /= [Hx1 Hx2].
  apply derivable_pt_diff_xlnx.
  split => //.
  exact: (ltR_trans Hx2 ltRinve21).
- move=> x /= Hx.
  rewrite /diff_xlnx.
  apply continuity_pt_minus ; last by apply continue_xlnx.
  apply (continuity_pt_comp (fun x => 1 - x) xlnx); last by apply continue_xlnx.
  apply continuity_pt_plus ; first by apply continuity_pt_const.
  apply continuity_pt_opp.
  apply derivable_continuous_pt.
  by apply derivable_pt_id.
- by apply exp_pos.
- move => t prt [Ht1 Ht2].
  apply derive_diff_xlnx_pos => //.
  exact: (conj Ht1 (ltR_trans Ht2 ltRinve21)).
Qed.

Lemma xlnx_ineq x : 0 <= x <= exp (-2) -> xlnx x <= xlnx (1-x).
Proof.
move=> [Hx1 Hx2].
apply Rge_le, Rminus_ge, Rle_ge.
rewrite -diff_xlnx_0 -/(diff_xlnx x).
case/boolP : (0 == x) => [/eqP ->|/eqP xnot0]; first exact/leRR.
apply/ltRW/diff_xlnx_sincreasing_0_Rinv_e2 => //.
  split; [exact/leRR | exact/ltRW/exp_pos].
by rewrite ltR_neqAle.
Qed.

End diff_xlnx.

Section Rabs_xlnx.

Definition xlnx_delta a := fun x => xlnx (x + a) - xlnx x.

Lemma derivable_xlnx_delta eps (Heps : 0 < eps < 1) x (Hx : 0 < x < 1 - eps) :
  derivable_pt (xlnx_delta eps) x.
Proof.
rewrite /xlnx_delta.
apply derivable_pt_minus.
- apply (derivable_pt_comp (fun x => x + eps) xlnx).
    apply derivable_pt_plus ; first by apply derivable_pt_id.
    by apply derivable_pt_const.
  apply derivable_pt_xlnx.
  apply addR_gt0; by [apply Heps | apply Hx].
- by apply derivable_pt_xlnx, Hx.
Defined.

Lemma derive_pt_xlnx_delta eps (Heps : 0 < eps < 1) x (Hx : 0 < x < 1 - eps) :
  derive_pt (xlnx_delta eps) x (derivable_xlnx_delta Heps Hx) = ln (x + eps) - ln x.
Proof.
rewrite derive_pt_minus derive_pt_comp derive_pt_plus derive_pt_id.
rewrite derive_pt_const derive_pt_xlnx; last first.
  apply addR_gt0; by [apply Hx | apply Heps].
rewrite derive_pt_xlnx ; by [field | apply Hx].
Qed.

Lemma increasing_xlnx_delta eps (Heps : 0< eps < 1) :
  forall x y : R, 0 <= x <= 1 - eps -> 0 <= y <= 1 - eps -> x < y ->
                  xlnx_delta eps x < xlnx_delta eps y.
Proof.
apply derive_sincreasing_interv.
- move=> x /= [Hx1 Hx2] ; rewrite /xlnx_delta.
  apply derivable_pt_minus.
  - apply (derivable_pt_comp (fun x => x + eps) xlnx).
      apply derivable_pt_plus ; first by apply derivable_pt_id.
      by apply derivable_pt_const.
    apply derivable_pt_xlnx.
    apply addR_gt0 => //; by apply Heps.
  - exact: derivable_pt_xlnx.
- move=> x /= [Hx1 Hx2] ; rewrite /xlnx_delta.
  apply continuity_pt_minus.
  - apply (continuity_pt_comp (fun x => x + eps) xlnx); last by apply continue_xlnx.
      apply continuity_pt_plus ; first by apply derivable_continuous_pt, derivable_pt_id.
      by apply continuity_pt_const.
  - by apply continue_xlnx.
- apply subR_gt0; by case: Heps.
- move=> t prd Ht.
  rewrite (proof_derive_irrelevance _ (derivable_xlnx_delta Heps Ht)) //.
  rewrite derive_pt_xlnx_delta.
  apply/subR_gt0/ln_increasing; first by apply Ht.
  rewrite -{1}(addR0 t).
  by apply ltR_add2l, Heps.
Qed.

Lemma xlnx_delta_bound eps : 0 < eps <= exp (-2) ->
  forall x, 0 <= x <= 1 - eps -> `| xlnx_delta eps x | <= - xlnx eps.
Proof.
move=> [Heps1 Heps2] x [Hx1 Hx2].
apply/leRP; rewrite leR_Rabsl oppRK; apply/andP; split; apply/leRP.
- rewrite (_ : xlnx eps = xlnx_delta eps 0); last first.
    by rewrite /xlnx_delta add0R xlnx_0 subR0.
  case/boolP : (0 == x) => [/eqP <-|/eqP xnot0]; first exact/leRR.
  apply/ltRW/increasing_xlnx_delta => //.
  + exact: (conj Heps1 (leR_ltR_trans Heps2 ltRinve21)).
  + split; by [apply (@leR_trans x) | exact: leRR].
  + by rewrite ltR_neqAle.
- apply (@leR_trans (xlnx_delta eps (1 - eps))).
    case/boolP : (x == 1 - eps) => [/eqP ->|/eqP xnot0]; first exact/leRR.
    apply/ltRW/increasing_xlnx_delta => //.
    + exact: (conj Heps1 (leR_ltR_trans Heps2 ltRinve21)).
    + split; by [apply (@leR_trans x) | exact: leRR].
    + by rewrite ltR_neqAle.
  rewrite /xlnx_delta subRK xlnx_1 sub0R leR_oppr oppRK.
  apply xlnx_ineq.
  split => //; exact: ltRW.
Qed.

Lemma Rabs_xlnx a (Ha : 0 <= a <= exp(-2)) x y :
  0 <= x <= 1 -> 0 <= y <= 1 -> `| x - y | <= a ->
  `| xlnx x - xlnx y | <= - xlnx a.
Proof.
move=> [Hx1 Hx2] [Hy1 Hy2] H.
case : (Rtotal_order x y) ; last case ; move => Hcase.
- have Haux : y = x + `| x - y |.
    by rewrite distRC gtR0_norm ?subR_gt0 // subRKC.
  rewrite Haux -normRN oppRD oppRK addRC.
  apply (@leR_trans (- xlnx `| x - y |)).
    apply xlnx_delta_bound.
    - split.
      - exact/Rabs_pos_lt/eqP/ltR_eqF/subR_lt0.
      - by apply (@leR_trans a) => //; apply Ha.
    - by split => //; rewrite leR_subr_addr -Haux.
  rewrite leR_oppr oppRK.
  apply xlnx_decreasing_0_Rinv_e => //.
  - split; first exact: normR_ge0.
    apply (@leR_trans a) => //.
    apply (@leR_trans (exp (- 2))); first by apply Ha.
    apply/ltRW/exp_increasing; lra.
  - split; first by apply Ha.
    apply (@leR_trans (exp (-2))); first by apply Ha.
    apply/ltRW/exp_increasing; lra.
- subst x ; rewrite subRR normR0 leR_oppr oppR0.
  case/orP : (orbN (0 == a)); last move=> anot0.
    by move=> /eqP <-; rewrite xlnx_0; exact: leRR.
  apply/ltRW/xlnx_neg; split.
  - apply/ltRP; rewrite lt0R eq_sym anot0; exact/leRP/(proj1 Ha).
  - exact: (leR_ltR_trans (proj2 Ha) ltRinve21).
- apply Rgt_lt in Hcase.
  have Haux : x = y + `| x - y | by rewrite gtR0_norm ?subR_gt0 // subRKC.
  rewrite distRC in H Haux.
  rewrite Haux.
  apply (@leR_trans (- xlnx `| y - x |)).
    apply xlnx_delta_bound.
    - split.
      - exact/Rabs_pos_lt/eqP/ltR_eqF/subR_lt0.
      - by apply (@leR_trans a) => //; apply Ha.
    - split => //.
      by rewrite leR_subr_addr -Haux.
  rewrite leR_oppr oppRK.
  apply xlnx_decreasing_0_Rinv_e => //.
  + split; first exact: normR_ge0.
    apply (@leR_trans a) => //.
    apply (@leR_trans (exp (-2))); first by apply Ha.
    apply/ltRW/exp_increasing; lra.
  - split; first by apply Ha.
    apply (@leR_trans (exp (-2))); first by apply Ha.
    apply/ltRW/exp_increasing; lra.
Qed.

End Rabs_xlnx.

End xlnx_sect.

Section log_concave.

Lemma pderivable_log a x1 : 0 <= a -> pderivable log (fun x2 : R => a < x2 < x1).
Proof.
move=> a0; rewrite /pderivable => x Hx.
rewrite /log /Log (_ : (fun x0 => ln x0 / ln 2) =
  (mult_real_fct (/ ln 2) (fun x0 => ln x0))); last first.
  by rewrite boolp.funeqE => x0; rewrite /mult_real_fct mulRC.
apply/derivable_pt_scal/derivable_pt_ln/(leR_ltR_trans a0); by case: Hx.
Qed.

Lemma ln_concave_at_gt0 x y (t : prob) : x < y ->
  0 < x -> 0 < y -> concave_function_at ln x y t.
Proof.
move=> xy x0 y0; apply RNconcave_function_at.
set Df := fun x => - / x.
move: t.
have HDf : pderivable (fun x => - ln x) (fun x0 => x <= x0 <= y).
  rewrite (_ : (fun x => - ln x) = comp Ropp ln); last by rewrite boolp.funeqE.
  move=> r xry; apply derivable_pt_comp; last exact: derivable_pt_Ropp.
  apply/derivable_pt_ln/(@ltR_leR_trans x) => //; by case: xry.
set DDf := fun x => / x^2.
have HDDf : pderivable Df (fun x0 : R => x <= x0 <= y).
  rewrite /Df (_ : (fun x => - / x) = comp Ropp Rinv); last first.
    by rewrite boolp.funeqE.
  move=> r xry; apply derivable_pt_comp; last exact/derivable_pt_Ropp.
  rewrite (_ : Rinv = inv_fct (fun x => x)); last by rewrite boolp.funeqE.
  apply derivable_pt_inv; last exact: derivable_pt_id.
  by apply/eqP/gtR_eqF/(@ltR_leR_trans x) => //; case: xry.
apply: (@second_derivative_convexf_pt _ _ _ HDf Df _ HDDf DDf) => //.
- move=> r xry; rewrite /Df.
  have r0 : 0 < r by apply (@ltR_leR_trans x) => //; case: xry.
  transitivity (derive_pt (comp Ropp ln) _
    (derivable_pt_comp ln Ropp _ (derivable_pt_ln r0) (derivable_pt_Ropp _))).
    by rewrite derive_pt_comp /= mulN1R.
  exact: proof_derive_irrelevance.
- move=> r xry; rewrite /DDf /Df.
  have /eqP r0 : r != 0 by apply/gtR_eqF/(@ltR_leR_trans x) => //; case: xry.
  transitivity (derive_pt (comp Ropp Rinv) _
    (derivable_pt_comp Rinv Ropp _
      (derivable_pt_inv _ _ r0 (derivable_pt_id _)) (derivable_pt_Ropp _))).
    rewrite derive_pt_comp [in RHS]/= derive_pt_inv derive_pt_id mulN1R.
    by rewrite /Rdiv mulNR oppRK mul1R Rsqr_pow2 (* TODO: rename? *).
  exact/proof_derive_irrelevance.
- move=> r; rewrite /DDf => -[x11 x12].
  rewrite -expRV; last by apply/gtR_eqF/(@ltR_leR_trans x).
  exact/expR_ge0/ltRW/invR_gt0/(@ltR_leR_trans x).
Qed.

Local Open Scope reals_ext_scope.

Lemma log_concave_at_gt0W x y (t : prob) : x < y ->
  0 < x -> 0 < y -> concave_function_at log x y t.
Proof.
move=> xy x0 y0; rewrite /log /Log.
apply concave_function_atN; [exact: ln_concave_at_gt0 | exact/ltRW/invR_gt0/ln2_gt0].
Qed.

Lemma log_concave_at_gt0 x y (t : prob) : 0 < x -> 0 < y -> concave_function_at log x y t.
Proof.
move=> x0 y0.
case/boolP : (x <b y) => [/ltRP xy|].
  exact: log_concave_at_gt0W.
rewrite -leRNgt' => /leRP; rewrite leR_eqVlt => -[->|yx].
exact: concave_function_atxx.
rewrite (probK t); apply: concavef_at_onem => //; exact: log_concave_at_gt0W.
Qed.

Lemma log_concave : concave_function_in Rpos_interval log.
Proof.
by move=> x y t; rewrite !classical_sets.in_setE => Hx Hy; apply log_concave_at_gt0.
Qed.

End log_concave.


Require Import Iron.Language.SystemF2Store.Base.

(********************************************************************)
(* Data Constructors
   Carries a data constructor tag and an arity. *)
Inductive datacon : Type :=
 | DataCon  : nat -> nat -> datacon.
Hint Constructors datacon.

Fixpoint datacon_beq t1 t2 :=
  match t1, t2 with
  | DataCon n11 n12, DataCon n21 n22
  => beq_nat n11 n21 && beq_nat n12 n22
  end.

Lemma beq_true_and_split
 :  forall a1 a2
 ,  true = a1 && a2
 -> true = a1 /\ true = a2.
Proof.
 destruct a1; destruct a2; auto.
Qed.

Lemma beq_false_and_split
 :  forall a1 a2
 ,  false = a1 && a2
 -> false = a1 \/ false = a2.
Proof.
 destruct a1; destruct a2; auto.
Qed.

(* Boolean equality for data constructors. *)
Lemma datacon_beq_eq
 :  forall dc dc'
 ,  true = datacon_beq dc dc'
 -> dc = dc'.
Proof.
 intros.
 destruct dc.
 destruct dc'.
 simpl in H.
  apply beq_true_and_split in H. inverts H.
  apply beq_nat_eq in H0.
  apply beq_nat_eq in H1.
  burn.
Qed.

(* Boolean negation for data constructors. *)
Lemma datacon_beq_false
 :  forall dc
 ,  false = datacon_beq dc dc
 -> False.
Proof.
 intro.
 destruct dc.
 simpl.
 intros.
  apply beq_false_and_split in H.
  inverts H.
   induction n. false. auto.
   induction n0. false. auto.
Qed.

Lemma datacon_eq_ex
 : forall (dc1 dc2 : datacon)
 , dc1 = dc2 \/ dc1 <> dc2.
Proof.
 intros.
 assert (exists b, b = datacon_beq dc1 dc2).
  eauto. dest b.
 destruct b.
  apply datacon_beq_eq in H. subst. auto.
  right. unfold not. intros.
  subst. apply datacon_beq_false in H. auto.
Qed.
Hint Resolve datacon_eq_ex.


(*
Parts of this file are copied and modified from the Coq Demos of the lecture Semantics at UdS:
http://www.ps.uni-saarland.de/courses/sem-ws17/confluence.v
 *)

Set Implicit Arguments.
Require Import Morphisms FinFun.
From Undecidability.HOU Require Import std.tactics.

Set Default Proof Using "Type".

Section ClosureRelations.
  Variables (X: Type).
  Implicit Types (R S: X -> X -> Prop) (x y z : X).

  Notation "R <<= S" := (subrelation R S) (at level 70).
  Notation "R === S" := (R <<= S /\ S <<= R) (at level 70).

  Definition functional R :=
    forall x y z, R x y -> R x z -> y = z.

  Inductive star R : X -> X -> Prop :=
  | starRefl x     : star R x x
  | starStep x x' y : R x x' -> star R x' y -> star R x y.

  Inductive multiple R : X -> X -> Prop :=
  | multipleSingle x y: R x y -> multiple R x y
  | multipleStep x x' y: R x x' -> multiple R x' y -> multiple R x y.

  Inductive counted R : nat -> X -> X -> Prop :=
  | countedRefl x: counted R 0 x x
  | countedStep x x' y n: R x x' -> counted R n x' y -> counted R (S n) x y.

  Inductive sym R: X -> X -> Prop :=
  | symId x y: R x y -> sym R x y
  | symInv x y: R y x -> sym R x y.

  Hint Constructors star multiple counted : core.

  Definition Normal R x := forall y, ~ R x y.
  Definition evaluates R s t := star R s t /\ Normal R t.
  Definition equiv R := star (sym R).

  Fact Normal_star_stops R x:
    Normal R x -> forall y, star R x y -> x = y.
  Proof.
    destruct 2; firstorder.
  Qed.

  Lemma star_trans R x y z :
    star R x y -> star R y z -> star R x z.
  Proof.
    induction 1; eauto.
  Qed.

  Lemma multiple_trans R x y z :
    multiple R x y -> multiple R y z -> multiple R x z.
  Proof.
    induction 1; eauto.
  Qed.

  Fact counted_trans R x y z m n:
    counted R m x y -> counted R n y z -> counted R (m + n) x z.
  Proof.
    induction 1; cbn; eauto.
  Qed.

  Global Instance multiple_transitive R:
    Transitive (multiple R).
  Proof.
    intros ?; eapply multiple_trans.
  Qed.

  Global Instance star_preorder R: PreOrder (star R).
  Proof.
    constructor; hnf; eauto using star_trans.
  Qed.

  Global Instance star_exp R:
    R <<= star R.
  Proof.
    unfold subrelation; eauto.
  Qed.

  Global Instance multiple_exp R:
    R <<= multiple R.
  Proof.
    unfold subrelation; eauto.
  Qed.

  Fact counted_exp R:
    R === counted R 1.
  Proof.
    unfold subrelation; split; eauto.
    intros x y H; inv H; inv H2; eauto.
  Qed.

  Global Instance multiple_star R : multiple R <<= star R.
  Proof.
    induction 1; eauto.
  Qed.

  Lemma multiple_destruct R x y:
    multiple R x y <-> exists2 x', (R x x') & (star R x' y).
  Proof.
    split.
    - induction 1; eauto.
      destruct IHmultiple; eexists; eauto.
    - intros [? H1 H2]; revert x H1; induction H2; eauto.
  Qed.

  Lemma step_star_multiple R x y z:
    R x y -> star R y z -> multiple R x z.
  Proof.
    intros H1 H2; apply multiple_destruct; eauto.
  Qed.

  Lemma multiple_star_step R x y z :
    multiple R x y -> star R y z -> multiple R x z.
  Proof.
    intros [] % multiple_destruct ?. eapply multiple_destruct.
    eexists; eauto using star_trans.
  Qed.

  Hint Resolve star_trans multiple_trans counted_trans star_exp
       multiple_exp counted_exp : core.

  Global Instance star_mono R S :
    R <<= S -> star R <<= star S.
  Proof.
    intros H x y.
    induction 1; eauto.
  Qed.

  Global Instance multiple_mono R S :
    R <<= S -> multiple R <<= multiple S.
  Proof.
    intros H x y.
    induction 1; eauto.
  Qed.

  Global Instance eval_subrel R:
    (evaluates R) <<= (star R).
  Proof. intros x y []. assumption. Qed.

  Fact star_closure R S :
    PreOrder S -> R <<= S -> star R <<= S.
  Proof.
    intros H1 H2 x y.
    induction 1 as [x|x x' y H4 _ IH].
    - reflexivity.
    - transitivity x'; auto.
  Qed.

  Fact star_idem R :
    star (star R) === star R.
  Proof.
    split.
    - induction 1; eauto.
    - apply star_mono, star_exp.
  Qed.

  Fact multiple_idem R :
    multiple (multiple R) === multiple R.
  Proof.
    split; eauto.
    induction 1; eauto.
  Qed.

  Fact multiple_fixpoint R :
    multiple (star R) === star R.
  Proof.
    split.
    - induction 1; eauto.
    - eauto.
  Qed.

  Fact star_absorbtion R :
    star (multiple R) === star R.
  Proof.
    split.
    - induction 1; eauto.
      apply multiple_destruct in H. destruct H. eauto.
    - eapply star_mono. eauto.
  Qed.

  Lemma sym_symmetric R x y:
    sym R x y -> sym R y x.
  Proof.
    intros []; eauto using sym.
  Qed.

  Global Instance sym_Symmetric R:
    Symmetric (sym R).
  Proof.
    firstorder using sym_symmetric.
  Qed.

  Lemma refl_star R x y:
    x = y -> star R x y.
  Proof.
    intros ->; eauto.
  Qed.

  Lemma refl_equiv R x:
    equiv R x x.
  Proof.
    constructor.
  Qed.

  Lemma equiv_trans R x y z:
    equiv R x y -> equiv R y z -> equiv R x z.
  Proof. eapply star_trans. Qed.

  Lemma equiv_symm R x y:
    equiv R x y -> equiv R y x.
  Proof.
    induction 1.
    constructor; eauto.
    eapply star_trans; eauto.
    econstructor 2; eauto using refl_equiv, sym_symmetric.
  Qed.

  Global Instance equiv_star R:
    star R <<= equiv R.
  Proof.
    induction 1; unfold equiv in *; eauto using sym, star.
  Qed.

  Global Instance equiv_rel R:
    R <<= equiv R.
  Proof.
    transitivity (star R); typeclasses eauto.
  Qed.

  Lemma equiv_expand R x x' y y':
    star R x x' -> star R y y' -> equiv R x' y' -> equiv R x y.
  Proof.
    intros. eapply equiv_trans.
    eapply equiv_star, H. eapply equiv_symm.
    eapply equiv_trans. eapply equiv_star, H0.
    now eapply equiv_symm.
  Qed.

  Lemma equiv_reduce R x x' y y' :
    star R x x' -> star R y y' -> equiv R x y -> equiv R x' y'.
  Proof.
    intros. eapply equiv_trans.
    eapply equiv_symm, equiv_star, H.
    now eapply equiv_trans, equiv_star, H0.
  Qed.

  Lemma eq_equiv R (x y: X):
    x = y -> equiv R x y.
  Proof. intros ->;eapply refl_equiv. Qed.

  Global Instance equiv_equivalence R:
    Equivalence (equiv R).
  Proof.
    constructor; firstorder using refl_equiv, equiv_trans, equiv_symm.
  Qed.

  Lemma equiv_join R x y z:
    star R x z -> star R y z -> equiv R x y.
  Proof.
    intros. transitivity z.
    rewrite H; reflexivity. symmetry.
    rewrite H0; reflexivity.
  Qed.

  (* Right-recursive version of star. *)
  Inductive starL R x:  X -> Prop :=
  | starReflL : starL R x x
  | starStepL  y y':  starL R x y -> R y y' -> starL R x y'.

  Hint Constructors starL : core.

  Lemma star_starL R x y :
    starL R x y <-> star R x y .
  Proof.
    split.
    - induction 1; auto. induction IHstarL; eauto.
    - induction 1; eauto. clear H0. induction IHstar; eauto.
  Qed.

  Lemma subrel_unfold R S (H: R <<= S) x y: R x y -> S x y.
  Proof. eapply H. Qed.

End ClosureRelations.

#[export] Hint Extern 4 => eapply subrel_unfold; [ typeclasses eauto |] : core.

#[export] Hint Constructors star multiple counted : core.
#[export] Hint Resolve star_trans multiple_trans counted_trans star_exp
     multiple_exp counted_exp equiv_join : core.


(** Programs and Proofs Ilya Sergey *)
(* http://ilyasergey.net/pnp/ *)

(**
「数学構造のコード化」DepRecords.v から抜粋した。
 *)

(**
7 Encoding Mathematical Structures
 *)
Module DepRecords.
  From mathcomp Require Import ssreflect ssrbool ssrnat ssrfun.

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

(**
7.1 Encoding partial commutative monoids

ひとつめのモジュール、可換モノイド。
(mathcompの命名法では、pcmType)
 *)
  Module PCMDef.

(**
Mixinの定義
*)
    Record mixin_of (T : Type) :=
      Mixin
        {
          valid_op : T -> bool;
          join_op : T -> T -> T;
          unit_op : T;
          _ : commutative join_op;
          _ : associative join_op;
          _ : left_id unit_op join_op;
          _ : forall x y, valid_op (join_op x y) -> valid_op x;
          _ : valid_op unit_op
        }.

    Lemma r_unit T (pcm: mixin_of T) (t: T) :
      (join_op pcm t (unit_op pcm)) = t.
    Proof.
      case: pcm => _ join unit Hc _ Hlu _ _ /=.
                  by rewrite Hc Hlu.
    Qed.

(**
7.1.3 Packaging the structure from mixins
 *)
(**
Packの定義
*)
    Section Packing.
      Structure pack_type : Type :=
        Pack {
            type : Type;
            _ : mixin_of type
          }.
      Local Coercion type : pack_type >-> Sortclass.
(**
packのインスタンスは任意のsortの要素
（typeフィールドを経由して参照される、型Typeのこと）
にコアーションされる。コアーションのために

``type :  pack_type -> Type``

が挿入される。原文：

an instance of pack type should be coerced into an element of an arbitrary sort,
it should be done via referring to is type field.

``Coercion F : A >-> B.``

Aのインスタンスは任意のB要素（Fフィールドを経由して参照される）
にコアーションされる。次と比較せよ。
コアーションのために ``is_true`` が挿入される。

``Coercion is_true : bool >-> Sortclass. (* Prop *)``
 *)
      Check type.

      Variable cT: pack_type.
      Definition pcm_struct : mixin_of cT := (* Coercion cT *)
        let: Pack _ c := cT return mixin_of cT in c.
      Definition valid := valid_op pcm_struct.
      Definition join := join_op pcm_struct.
      Definition unit := unit_op pcm_struct.
    End Packing.

(**
Exports の宣言
*)
    Module Exports.
      Notation pcm := pack_type.
      Notation PCMMixin := Mixin.
      Notation PCM T m := (@Pack T m).
      Notation "x \+ y" := (join x y) (at level 43, left associativity). (* join_opではない。 *)
      Notation valid := valid.
      Notation Unit := unit.
      Coercion type : pack_type >-> Sortclass.

(**
7.2 Properties of partial commutative monoids

可換則や結合則を証明しておく。これらはexportされる。
*)
      Section PCMLemmas.
        Variable U : pcm.

        Lemma joinC (x y : U) : x \+ y = y \+ x. (* Coercion U *)
        Proof.
            by case: U x y => tp [v j z Cj *]; apply Cj.
        Qed.

        Lemma joinA (x y z : U) : x \+ (y \+ z) = x \+ y \+ z.
        Proof.
            by case: U x y z => tp [v j z Cj Aj *]; apply: Aj.
        Qed.
(**
Exercices 7.1
*)
        Lemma joinAC (x y z : U) : x \+ y \+ z = x \+ z \+ y.
        Proof.
          rewrite -[x \+ z \+ y]joinA.
          rewrite [z \+ y]joinC.
          rewrite [x \+ (y \+ z)]joinA.
          by [].
        Qed.

        Lemma joinCA (x y z : U) : x \+ (y \+ z) = y \+ (x \+ z).
        Proof.
          rewrite [y \+ (x \+ z)]joinA.
          rewrite [y \+ x]joinC.
          rewrite -[x \+ y \+ z]joinA.
          by [].
        Qed.

        Lemma validL (x y : U) : valid (x \+ y) -> valid x.
        Proof.
          case: U x y => tp [v j z Cj Aj H1 H2 H3 x y] => H.
          by apply: (H2 x y).
        Qed.

        Lemma validR (x y : U) : valid (x \+ y) -> valid y.
        Proof.
          case: U x y => tp [v j z Cj Aj H1 H2 H3 x y].
          rewrite [x \+ y]Cj.
          by apply: (H2 y x).
        Qed.

        Lemma unitL (x : U) : (@Unit U) \+ x = x.
        Proof.
          case: U x => tp [v j z Cj Aj H1 H2 H3 x].
          by apply H1.
        Qed.

        Lemma unitR (x : U) : x \+ (@Unit U) = x.
        Proof.
          case: U x => tp [v j z Cj Aj H1 H2 H3 x].
          rewrite [x \+ _]Cj.
          by apply H1.
        Qed.

        Lemma valid_unit : valid (@Unit U).
        Proof.
          case: U => tp [v j z Cj Aj H1 H2 H3].
          by apply H3.
        Qed.
(**
End of Exercices 7.1
 *)
      End PCMLemmas.
    End Exports.
  End PCMDef.
  Export PCMDef.Exports.                    (* Exportsをexportする。 *)
(**
ひとつめのモジュール、可換モノイドの終了。
 *)

(**
7.3 Implementing inheritance hierarchies

ふたつめのモジュール、簡約可換モノイド。
(mathcompの命名法では、cancelPcmType)
 *)
  Module CancelPCM.
(**
Mixin -- PCMに簡約法則を追加する。
 *)
    Record mixin_of (U : pcm) :=
      Mixin
        {
          _ : forall a b c : U, valid (a \+ b) -> a \+ b = a \+ c -> b = c
        }.

(**
Packing -- Struture pack_type ... の定義は前のモジュールと同じ。

Section Packing. と End Packing. の有無は関係なく、
Variableなどの宣言の必要に応じて、Section にすればよい。
 *)
    Structure pack_type : Type :=
      Pack {
          pcmT : pcm;
          _ : mixin_of pcmT
        }.

(**
Exports の宣言
*)
    Module Exports.
      Notation cancel_pcm := pack_type.
      Notation CancelPCMMixin := Mixin.
      Notation CancelPCM T m:= (@Pack T m).
      Coercion pcmT : pack_type >-> pcm.
(**
可換則を証明しておく。
 *)
      Lemma cancel (U: cancel_pcm) (x y z: U): (* Coecion U *)
        valid (x \+ y) -> x \+ y = x \+ z -> y = z.
      Proof.
          by case: U x y z => Up [Hc] x y z; apply: Hc.
      Qed.
    End Exports.
  End CancelPCM.
  Export CancelPCM.Exports.                 (* Exportsをexportする。 *)
(**
ふたつめのモジュール、簡約可換モノイドの終了。
 *)

  Lemma cancelC (U: cancel_pcm) (x y z : U) :
    valid (y \+ x \+ z) -> y \+ x = x \+ z -> y = z.
  Proof.
      by move/validL; rewrite ![y \+ _]joinC; apply: cancel.
  Qed.

(**
7.4 Instantiation and canonical structures

簡約モノイドを整数についてインスタンスを作る。
(mathcompの命名法では、nat_pcmType)
 *)
  Definition natPCMMixin :=
    PCMMixin
      addnC                                 (* commutative *)
      addnA                                 (* associative *)
      add0n                                 (* left_id *)
      (fun x y => @id true)                 (* valid_op join_op *)
      (erefl _).                            (* valid_op unit_op *)

  Definition NatPCM := PCM nat natPCMMixin.
  Canonical natPCM := NatPCM.               (* 原文では、PCM nat natPCMMixin. *)
  Print Canonical Projections.
(**
nat <- PCMDef.type ( natPCM )
が追加される。typeはCoercionであることに注意！
 *)

(**
natPCM が Canonical でないと、add_perm の定義がエラーになる。
natPCM を Canonical にすると、add_perm の nat を natPCM として扱える。
 *)
  Lemma add_perm (a b c : nat) : a \+ (b \+ c) = a \+ (c \+ b).
  Proof.
      by rewrite [c \+ b]joinC.
  Qed.

(** 可換簡約モノイドを整数についてインスタンスを作る。
(mathcompの命名法では、nat_cancelPcmType) *)
(**
簡約規則を証明しておく。
 *)
  Lemma cancelNat : forall a b c : nat, true -> a + b = a + c -> b = c.
  Proof.
    move=> a b c; elim: a => // n /(_ is_true_true) Hn _ H.
      by apply: Hn; rewrite !addSn in H; move/eq_add_S: H.
  Qed.

  (**
natPCM が Canonicalでないと、cancelNat が使用できない。
natPCM を Canonical にすると、cancelNat の nat を natPCM として扱える。
 *)
  Definition cancelNatPCMMixin :=
    CancelPCMMixin
      cancelNat.                            (* 簡約規則 *)

  Definition CancelNatPCM := CancelPCM natPCM cancelNatPCMMixin.
  Canonical cancelNatPCM := CancelNatPCM.
  (* 原文では、直接、CancelPCM natPCM cancelNatPCMMixin を使って定義される。 *)
  Print Canonical Projections.
(**
natPCM <- CancelPCM.pcmT ( cancelNatPCM )
が追加される。pcmTはCoercionであることに注意！
 *)

  Section PCMExamples.
    Variables a b c: nat.

    Check PCMDef.join_op : forall T : Type, PCMDef.mixin_of T -> T -> T -> T.
    Check PCMDef.join : forall cT : pcm, cT -> cT -> cT.
    About "_ \+ _".                         (* PCMDef.join  *)

    Goal a \+ (b \+ c) =  c \+ (b \+ a).
      by rewrite joinA [c \+ _]joinC [b \+ _]joinC.
    Qed.

    Goal c \+ a = a \+ b -> c = b.
      by rewrite [c \+ _]joinC; apply: cancel.
    Qed.

    Lemma addn_join (x y: nat): x + y = x \+ y.
    Proof.
        by [].
    Qed.
  End PCMExamples.

(**
Exercise 7.2 Partially-ordered sets
(see. ssr_pnp_poset.v)
*)

(**
Exercise 7.3 Canonical instances of partially ordered sets
*)

(**
7.4.2 Types with decidable equalities
 *)
  Module Equality.
    Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y).

(**
Mixinの定義
*)
    Structure mixin_of T :=
      Mixin {
          op : rel T;
          _ : axiom op
        }.

(**
Packの定義
*)
    Structure type :=
      Pack
        {
          sort;
         _ : mixin_of sort
        }.

(**
Exports の宣言
*)
    Module Exports.
      Notation EqMixin := Mixin.
      Notation EqType T m := (@Pack T m).     (* "@"が必要。 *)
    End Exports.
  End Equality.
  Export Equality.Exports.       (* 他に習って、Exportsをexportする。 *)

End DepRecords.

(* END *)


Require Import Setoid CMorphisms.
Require Relation_Definitions.
From mathcomp Require Import all_ssreflect.
From GraphTheory Require Import edone preliminaries bij.

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

(** * Directed Graphs  *)

(** This file contains a number of constructions and lemmas to reason about
paths in (finite) graphs. The most basic notion of a graph is just a type
packaged together with a relation. *)

(** The underlying type could be more permissive e.g. [countType] or even
[eqType]. However, this would required a more complicated setup in order to
ensure that the coercions to [countType] and [finType] (for finite graphs) are
not just convertible but indeed equal. Otherwise, some automation using [auto]
fails. So far, we only deal with with finite graphs, so "telescopes" suffice *)

Record relType := RelType { rel_car :> finType; edge_rel : rel rel_car }.
Notation "x -- y" := (edge_rel x y) (at level 30).
Prenex Implicits edge_rel.

(** experimental notation for passing [edge_rel] or [sedge] *)
(* TODO/TOTHINK : use this pervasively *)
Notation "(--)" := (fun x y => x -- y).

(** maintain the notation [x -- y] under simplification *)

Arguments edge_rel : simpl never.

(** For [G : relType] and [x, y : G] we define two auxiliary notions: *)

(** [pathp x y p] == the list (x::p) is an xy-path in G. *)

(** [upath x y p] == the list (x::p) is an irredundant xy-path in G. *)

(** Due to the asymmetry in the definitions of of [path],[pathp], and [upath], these
are ill-suited for the symmetry reasoning prevalent in graph theory. We remedy
this by providing a type family of packaged paths [Path x y] which abstracts
away this asymmetry. We then lift many of the lemmas from the path library to
the setting of simple graphs. *)

(** ** Unpackaged Paths *)

Section PathP.
Variable (T : relType).
Implicit Types (x y : T) (p : seq T).

Definition pathp x y p := path (--) x p && (last x p == y).

Lemma pathpW y x p : pathp x y p -> path (--) x p.
Proof. by case/andP. Qed.

Lemma pathp_last y x p : pathp x y p -> last x p = y.
Proof. by case/andP => _ /eqP->. Qed.

Lemma pathp_cat x y p1 p2 :
  pathp x y (p1++p2) = (pathp x (last x p1) p1) && (pathp (last x p1) y p2).
Proof. by rewrite {1}/pathp cat_path last_cat /pathp eqxx andbT /= -andbA. Qed.

Lemma pathp_concat x y z p q :
  pathp x y p -> pathp y z q -> pathp x z (p++q).
Proof.
  move => /andP[A B] /andP [C D].
  rewrite pathp_cat (eqP B) /pathp -andbA. exact/and4P.
Qed.

Lemma pathpxx x : pathp x x [::].
Proof. exact: eqxx. Qed.

Lemma pathp_nil x y : pathp x y [::] -> x = y.
Proof. by case/andP => _ /eqP. Qed.

Lemma pathp_cons x y z p :
  pathp x y (z :: p) = x -- z && pathp z y p.
Proof. by rewrite -cat1s pathp_cat {1}/pathp /= eqxx !andbT. Qed.

Lemma pathp_rcons x y z p: pathp x y (rcons p z) -> y = z.
Proof. case/andP => _ /eqP <-. exact: last_rcons. Qed.

Lemma rcons_pathp x y p : path (--) x (rcons p y) = pathp x y (rcons p y).
Proof. by rewrite /pathp last_rcons eqxx andbT. Qed.

CoInductive pathp_split z x y : seq T -> Prop :=
  PPSplit p1 p2 : pathp x z p1 -> pathp z y p2 -> pathp_split z x y (p1 ++ p2).

Lemma ppsplitP z x y p : z \in x :: p -> pathp x y p -> pathp_split z x y p.
Proof.
  case/splitPl => p1 p2 /eqP H1 /andP [H2 H3].
  rewrite cat_path last_cat in H2 H3. case/andP : H2 => H2 H2'.
  constructor; last rewrite -(eqP H1); exact/andP.
Qed.

Lemma pathp_shorten x y p :
  pathp x y p -> exists p', [/\ pathp x y p', uniq (x::p') & {subset p' <= p}].
Proof. case/andP. case/shortenP => p' *. by exists p'. Qed.

(** Irredundant paths *)

Definition upath x y p := uniq (x::p) && pathp x y p.

Lemma upathW x y p : upath x y p -> pathp x y p.
Proof. by case/andP. Qed.

Lemma upathWW x y p : upath x y p -> path (--) x p.
Proof. by move/upathW/pathpW. Qed.

Lemma upath_uniq x y p : upath x y p -> uniq (x::p).
Proof. by case/andP. Qed.

Lemma upath_cons x y z p :
  upath x y (z::p) = [&& x -- z, x \notin (z::p) & upath z y p].
Proof.
  rewrite /upath pathp_cons [z::p]lock /= -lock.
  case: (x -- z) => //. by case (uniq _).
Qed.

Lemma upath_consE x y z p :
  upath x y (z :: p) -> [/\ x -- z, x \notin z :: p & upath z y p].
Proof. rewrite upath_cons. by move/and3P. Qed.

Lemma upath_nil x p : upath x x p -> p = [::].
Proof. case: p => //= a p /and3P[/= A B C]. by rewrite -(eqP C) mem_last in A. Qed.

End PathP.

(** Lifting Lemmas for unpackaged paths *)

Lemma subrel_pathp (T : finType) (e1 e2 : rel T) (x y : T) (p : seq T) :
  subrel e1 e2 -> @pathp (RelType e1) x y p -> @pathp (RelType e2) x y p.
Proof.
  move => sub12. elim: p x => //= z p IHp x. rewrite !pathp_cons => /andP [A B].
  apply/andP;split; [exact: sub12 | exact: IHp].
Qed.

Lemma lift_pathp_on (G H : relType) (f : G -> H) a b p' :
  (forall x y, f x \in f a :: p' -> f y \in f a :: p' -> f x -- f y -> x -- y) -> injective f ->
  pathp (f a) (f b) p' -> {subset p' <= codom f} -> exists p, pathp a b p /\ map f p = p'.
Proof.
  move => A I /andP [B /eqP C] D.  case: (lift_path A B D) => p [p1 p2]; subst.
  exists p. split => //. apply/andP. split => //. rewrite last_map in C. by rewrite (I _ _ C).
Qed.

Lemma lift_pathp (G H : relType) (f : G -> H) a b p' :
  (forall x y, f x -- f y -> x -- y) -> injective f ->
  pathp (f a) (f b) p' -> {subset p' <= codom f} -> exists p, pathp a b p /\ map f p = p'.
Proof. move => I. apply: lift_pathp_on. auto. Qed.

Lemma lift_upath_on (G H : relType) (f : G -> H) a b p' :
  (forall x y, f x \in f a :: p' -> f y \in f a :: p' -> f x -- f y -> x -- y) -> injective f ->
  upath (f a) (f b) p' -> {subset p' <= codom f} -> exists p, upath a b p /\ map f p = p'.
Proof.
  move => A B /andP [C D] E. case: (lift_pathp_on A B D E) => p [p1 p2].
  exists p. split => //. apply/andP. split => //. by rewrite -(map_inj_uniq B) /= p2.
Qed.

Lemma lift_upath (G H : relType) (f : G -> H) a b p' :
  (forall x y, f x -- f y -> x -- y) -> injective f ->
  upath (f a) (f b) p' -> {subset p' <= codom f} -> exists p, upath a b p /\ map f p = p'.
Proof. move => I. apply: lift_upath_on. auto. Qed.

(** ** Packaged paths *)

(** We now define packaged paths (i.e., a vertex-indexed collection of
types [Path x y] whose elements are the paths between [x] and [y]). In
particular, this abstracts from the asymmetry in [spath x y p] which
states that [x::p] is an xy-path (paths are never empty). *)

Section Pack.
Variables (T : relType).
Implicit Types x y z : T.

Section PathDef.
  Variables (x y : T).

  Record Path : predArgType := { pval : seq T; _ : pathp x y pval }.

  Canonical Path_subType := [subType for pval].
  Definition Path_eqMixin := Eval hnf in [eqMixin of Path by <:].
  Canonical Path_eqType := Eval hnf in EqType Path Path_eqMixin.
  Definition Path_choiceMixin := Eval hnf in [choiceMixin of Path by <:].
  Canonical Path_choiceType := Eval hnf in ChoiceType Path Path_choiceMixin.
  Definition Path_countMixin := Eval hnf in [countMixin of Path by <:].
  Canonical Path_countType := Eval hnf in CountType Path Path_countMixin.

  Record UPath : predArgType := { uval : seq T; _ : upath x y uval }.

  Canonical UPath_subType := [subType for uval].
  Definition UPath_eqMixin := Eval hnf in [eqMixin of UPath by <:].
  Canonical UPath_eqType := Eval hnf in EqType UPath UPath_eqMixin.
  Definition UPath_choiceMixin := Eval hnf in [choiceMixin of UPath by <:].
  Canonical UPath_choiceType := Eval hnf in ChoiceType UPath UPath_choiceMixin.
  Definition UPath_countMixin := Eval hnf in [countMixin of UPath by <:].
  Canonical UPath_countType := Eval hnf in CountType UPath UPath_countMixin.

End PathDef.
End Pack.

(** constructor for [Path x (last x p)] given [pth_p : path (--) x p] *)
Lemma Path_of_proof (G : relType) (x : G) (p : seq G) :
  path (--) x p -> pathp x (last x p) p.
Proof. by rewrite /pathp eqxx andbT. Qed.

Definition Path_of_path (G : relType) (x : G) (p : seq G) (pth_p : path (--) x p)
  := Build_Path (Path_of_proof pth_p).

Section PathOps.
Variables (T : relType) (x y z : T) (p : Path x y) (q : Path y z).

Definition nodes := locked (x :: val p).
Lemma nodesE : nodes = x :: val p. by rewrite /nodes -lock. Qed.
Definition irred := uniq nodes.
Lemma irredE : irred = uniq nodes. by []. Qed.
Definition tail := val p.

Definition pcat_proof := pathp_concat (valP p) (valP q).
Definition pcat : Path x z := Sub (val p ++ val q) pcat_proof.

Lemma path_last: last x (val p) = y.
Proof. move: (valP p). exact: pathp_last. Qed.

End PathOps.

Definition in_nodes (T : relType) (x y : T) (p : Path x y) : collective_pred T :=
  [pred u | u \in nodes p].
Canonical Path_predType (T : relType) (x y :T) :=
  Eval hnf in @PredType T (Path x y) (@in_nodes T x y).
Coercion in_nodes : Path >-> collective_pred.

Section PathTheory.
Variable (G : relType).
Implicit Types (x y z u : G).

Lemma nodes_eqE x y (p q : Path x y) : (nodes p == nodes q) = (p == q).
Proof.
  case: q p => q pth_q [p pth_p].
  by rewrite !nodesE -val_eqE /= eqseq_cons eqxx.
Qed.

Lemma mem_path x y (p : Path x y) u : u \in p = (u \in nodes p).
Proof. by rewrite in_collective. Qed.

Section Fixed.
Variables (x y z : G) (p : Path x y) (q : Path y z).

Lemma in_tail : z != x -> z \in p -> z \in tail p.
Proof. move => A. by rewrite mem_path nodesE inE (negbTE A). Qed.

Lemma path_end : y \in p.
Proof. by rewrite mem_path nodesE -[in X in X \in _](path_last p) mem_last. Qed.

Lemma path_begin : x \in p.
Proof. by rewrite mem_path nodesE mem_head. Qed.

Lemma mem_pcatT u : (u \in pcat p q) = (u \in p) || (u \in tail q).
Proof. by rewrite !mem_path !nodesE !inE mem_cat -orbA. Qed.

Lemma tailW : {subset tail q <= q}.
Proof. move => u. rewrite mem_path nodesE. exact: mem_tail. Qed.

Lemma mem_pcat u :  (u \in pcat p q) = (u \in p) || (u \in q).
Proof.
  rewrite mem_pcatT. case A: (u \in p) => //=.
  rewrite mem_path !nodesE inE (_ : u == y = false) //.
  apply: contraFF A => /eqP->. exact: path_end.
Qed.

Lemma nodes_pcat : nodes (pcat p q) = nodes p ++ behead (nodes q).
Proof. by rewrite !nodesE. Qed.

End Fixed.

Lemma pcatA u v x y (p : Path u v) (q : Path v x) (r : Path x y) :
  pcat (pcat p q) r = pcat p (pcat q r).
Proof. apply/eqP. by rewrite -val_eqE /= catA. Qed.

(** The one-node path *)

Definition idp (u : G) := Build_Path (pathpxx u).

Lemma mem_idp (x u : G) : (x \in idp u) = (x == u).
Proof. by rewrite mem_path nodesE !inE. Qed.

Lemma irred_idp (x : G) : irred (idp x).
Proof. by rewrite irredE nodesE. Qed.

Lemma pcat_idL (x y : G) (p : Path x y) :
  pcat (idp x) p = p.
Proof. exact: val_inj. Qed.

Lemma pcat_idR (x y : G) (p : Path x y) :
  pcat p (idp y) = p.
Proof. apply: val_inj => /=. by rewrite cats0. Qed.

Lemma irredxx (x : G) (p : Path x x) : irred p -> p = idp x.
Proof.
  rewrite irredE /tail (lock uniq); case: p => p p_pth /=.
  rewrite nodesE /= -lock => p_uniq. apply/val_inj => /=.
  by have /upath_nil-> : upath x x p by rewrite /upath p_uniq p_pth.
Qed.

(** Paths with a single edge using an injection from (proofs of) [x -- y] *)

Lemma edgep_proof x y (xy : x -- y) : pathp x y [:: y].
Proof. by rewrite pathp_cons xy pathpxx. Qed.

Definition edgep x y (xy : x -- y) := Build_Path (edgep_proof xy).

Lemma mem_edgep x y z (xy : x -- y) :
  z \in edgep xy = (z == x) || (z == y).
Proof. by rewrite mem_path nodesE !inE. Qed.

Lemma mem_pcat_edgeL x y z (xy : x -- y) (p : Path y z) u :
  (u \in pcat (edgep xy) p) = (u == x) || (u \in p).
Proof.
  rewrite mem_pcat mem_edgep. case: (altP (u =P y)) => //= ->. by rewrite path_begin.
Qed.

Lemma mem_pcat_edgeR x y z (yz : y -- z) (p : Path x y) u :
  (u \in pcat p (edgep yz)) = (u == z) || (u \in p).
Proof.
  rewrite mem_pcat mem_edgep.
  case: (altP (u =P y)) => //= [->|]; by rewrite ?path_end 1?orbC.
Qed.

Lemma edgeLP x y z (xy : x -- y) (p : Path y z) u :
  reflect (u = x \/ u \in p) (u \in pcat (edgep xy) p).
Proof.
  rewrite mem_pcat mem_edgep -orbA. apply: (iffP or3P) => [|[->|->]]; rewrite ?eqxx.
  1: case => [/eqP->|/eqP->|->]; rewrite ?inE. all: by firstorder using path_begin.
Qed.

(** These are easier to prove by breaking the abstraction barrier than by using
[irred_cat] below. *)

Lemma irred_edge x y (xy: x -- y) : irred (edgep xy) = (x != y).
Proof. by rewrite irredE nodesE /= inE andbT. Qed.

Lemma irred_edgeL y x z1 (xz1 : x -- z1) (p : Path z1 y) :
  irred (pcat (edgep xz1) p) = (x \notin p) && irred p.
Proof. case: p => p pth_p. by rewrite !irredE /= mem_path !nodesE /=. Qed.

Lemma irred_edgeR y x z (yz : y -- z) (p : Path x y) :
  irred (pcat p (edgep yz)) = (z \notin p) && irred p.
Proof.
  rewrite !irredE !mem_path !nodesE /= cats1 rcons_uniq mem_rcons !inE.
  rewrite eq_sym !negb_or. case: (x \notin pval p); by rewrite andbA.
Qed.

(** Induction principles for packaged paths *)

Lemma Path_ind (P : forall x x0 : G, Path x x0 -> Type) (y : G) (x : G) (p : Path x y) :
  P y y (idp y) ->
  (forall (x z : G) (p : Path z y) (xz : x -- z), P z y p -> P x y (pcat (edgep xz) p)) ->
  P x y p.
Proof.
  move => Hbase Hstep. case: p => [p pth_p].
  elim: p x pth_p => [|z p IH] x A.
  - have ?: x = y. { exact: pathp_nil. }
    subst y. rewrite [Build_Path _](_ : _ = idp x) //. exact: val_inj.
  - move: {-}(A). rewrite pathp_cons => /andP [xz B2].
    have -> : Build_Path A =
             (pcat (edgep xz) (Build_Path B2)) by exact: val_inj.
    apply: Hstep. exact: IH.
Qed.

Lemma irred_ind P (y : G) :
  P y y (idp y) ->
  (forall x z (p : Path z y) (xz : x -- z),
      irred p -> x \notin p -> P z y p -> P x y (pcat (edgep xz) p)) ->
  forall x (p : Path x y), irred p -> P x y p.
Proof.
  move => Hbase Hstep x p.
  pattern x,y,p. apply: Path_ind => // {x p} x z p xz IH.
  rewrite irred_edgeL => /andP[A B]. by apply: Hstep; auto.
Qed.

Lemma path_closed (A : pred G) x y (p : Path x y) :
  x \in A -> (forall y z, y \in A -> y -- z -> z \in A) -> {subset p <= A}.
Proof.
  move => xA clos_A. move: xA. pattern x,y,p. apply: Path_ind => {x p}.
  - move => yA z. by rewrite mem_idp => /eqP->.
  - move => x z p xz IH xA u. rewrite mem_pcat mem_edgep -orbA.
    have ? : z \in A by exact: clos_A xz.
    case/or3P => [/eqP->|/eqP->|] //. exact: IH.
Qed.

Lemma uncycle x y (p : Path x y) :
  exists2 p' : Path x y, {subset p' <= p} & irred p'.
Proof.
  case: p => p pth_p. case/pathp_shorten : (pth_p) => p' [A B C].
  exists (Build_Path A). move => z. rewrite !mem_path !nodesE !SubK.
  + rewrite !inE. case/predU1P => [->|/C ->] //. by rewrite eqxx.
  + by rewrite /irred nodesE.
Qed.

End PathTheory.
Definition inE := (inE,mem_pcat,path_begin,path_end).

(** NOTE: Up to here, nothing depends on the vertex type being finite. The
constuctions below make use of functions that are only defined on finite types,
e.g., [connect] or [#|G|] *)

(*
Record diGraph := DiGraph { di_vertex : finType;
                            di_edge : rel di_vertex }.

Canonical digraph_relType (D : diGraph) := RelType (@di_edge D).
Coercion digraph_relType : diGraph >-> relType.
Coercion di_vertex : diGraph >-> finType.
Prenex Implicits di_edge.
*)

(** The simple setup above causes the coercion to [finType] to be different from
(but convertible to) the coercions to [choiceType]. This causes [auto] and hence
[trivial] and [by] to fail. *)

Notation diGraph := relType.
Notation DiGraph := RelType.
Goal forall (T : diGraph) (A : pred T), A \subset [set: T]. by []. Qed.

Section DiGraphTheory.
Variables (D : diGraph).
Implicit Types (x y : D).

Lemma upath_size x y p : upath x y p -> size p < #|D|.
Proof. move=> /upath_uniq/card_uniqP/= <-. exact: max_card. Qed.

CoInductive usplit z x y : seq D -> Prop :=
  USplit p1 p2 : upath x z p1 -> upath z y p2 -> [disjoint x::p1 & p2]
                 -> usplit z x y (p1 ++ p2).

Lemma usplitP z x y p : z \in x :: p -> upath x y p -> usplit z x y p.
Proof.
  move => in_p /andP [U P]. case: (ppsplitP in_p P) U  => p1 p2 sp1 sp2.
  rewrite -cat_cons cat_uniq -disjoint_has disjoint_sym => /and3P [? C ?].
  suff H: z \notin p2 by constructor.
  apply/negP. apply: disjointE C _. by rewrite -(pathp_last sp1) // mem_last.
Qed.

Lemma upathP x y : reflect (exists p, upath x y p) (connect (--) x y).
Proof.
  apply: (iffP connectP) => [[p p1 p2]|[p /and3P [p1 p2 /eqP p3]]]; last by exists p.
  exists (shorten x p). case/shortenP : p1 p2 => p' ? ? _ /esym/eqP ?. exact/and3P.
Qed.

Lemma pathpP x y : reflect (exists p, pathp x y p) (connect (--) x y).
Proof.
  apply: (iffP idP) => [|[p] /andP[A /eqP B]]; last by apply/connectP; exists p.
  case/upathP => p /upathW ?. by exists p.
Qed.

(* Set Printing All. *)

Section Fixed.
Variables (x y z : D) (p : Path x y) (q : Path y z).

(** NOTE: [rewrite mem_pcat] requres [digraph_relType] to be canonical *)
Lemma subset_pcatL : p \subset pcat p q.
Proof. apply/subsetP => u. by rewrite mem_pcat => ->. Qed.

Lemma subset_pcatR : q \subset pcat p q.
Proof. apply/subsetP => u. by rewrite mem_pcat => ->. Qed.

Lemma pcat_subset (A : pred D) : p \subset A -> q \subset A -> pcat p q \subset A.
Proof.
  move => /subsetP Hp /subsetP Hq. apply/subsetP => u.
  rewrite !mem_pcat. case/orP; [exact: Hp|exact: Hq].
Qed.

(** This is easy to prove and in some contetxs exactly what is needed. However,
it introduces an unpleasant asymmetry between [p] and [q]. *)
Lemma irred_catD :
  irred (pcat p q) = [&& irred p, irred q & [disjoint p & tail q]].
Proof.
  rewrite /irred {1}/nodes -lock /pcat SubK -cat_cons cat_uniq.
  rewrite -disjoint_has disjoint_sym -nodesE.
  case A : [disjoint _ & _] => //. case: (uniq (nodes p)) => //=. rewrite nodesE /=.
  case: (uniq _) => //=. by rewrite !andbT (disjointFr A _) // path_end.
Qed.

(** This lemma is more symmetric than [irred_catD], but the set equality is
sometimes cumbersome to use. *)
Lemma irred_cat :
  irred (pcat p q) = [&& irred p, irred q & [set u : D in p | u \in q] == [set y]].
Proof.
  rewrite /irred {1}nodesE (lock uniq) /= -lock -cat_cons -nodesE cat_uniq.
  congr (_ && _). rewrite (nodesE q) /=. case: uniq => //; rewrite !andbT.
  apply/hasPn/andP.
  - move=> H. split; first by apply/negP=>/H/=; rewrite path_end.
    apply/eqP/setP=> u; rewrite !inE.
    apply/andP/eqP; last by [move=>->; rewrite path_begin path_end].
    case=> u_p. rewrite mem_path nodesE inE =>/orP[/eqP//|/H/=]. by rewrite u_p.
  - case=> zNTq. rewrite eqEsubset =>/andP[/subsetP sub _].
    move=> u u_q /=. apply/negP=> u_p.
    case/(_ u _)/Wrap: sub; rewrite inE.
    + rewrite u_p /=; exact: tailW.
    + apply/negP; by apply: contraNneq zNTq =>{1}<-.
Qed.

(** Introduction and elimination lemmas for [irred (pcat p q)] that avoid the
use of set equality *)
Lemma irred_catI :
  (forall k : D, k \in p -> k \in q -> k = y) -> irred p -> irred q -> irred (pcat p q).
Proof.
  move => H Ip Iq. rewrite irred_cat Ip Iq /=. apply/eqP/setP => k.
  rewrite !inE. apply/andP/eqP => [[]|->]. exact: H. by rewrite path_begin path_end.
Qed.

(** TODO: This lemma should be used instead of the [irred_cat] where appropriate *)
Lemma irred_catE :
  irred (pcat p q) -> [/\ irred p, irred q & forall k, k \in p -> k \in q -> k = y].
Proof.
  rewrite irred_cat. case/and3P => [? ? A]. split => // k K1 K2.
  apply/eqP. move/eqP/setP/(_ k) : A. by rewrite !inE K1 K2.
Qed.

End Fixed.

Lemma connect_irredP x y :
  reflect (exists p : Path x y, irred p) (connect (--) x y).
Proof.
  apply: (iffP (upathP _ _)) => [[p /andP [U P]]|[p I]].
  + exists (Sub p P).  by rewrite /irred nodesE.
  + exists (val p). apply/andP;split; by [rewrite /irred nodesE in I| exact: valP].
Qed.

Lemma Path_connect x y (p : Path x y) : connect (--) x y.
Proof. apply/pathpP. exists (val p). exact: valP. Qed.

(** *** Splitting Paths **)

Lemma splitL x y (p : Path x y) :
  x != y -> exists z xz (p' : Path z y), p = pcat (edgep xz) p' /\ p' =i tail p.
Proof.
  move => xy. case: p => p. elim: p x xy => [|a p IH] x xy H.
  - move/pathp_nil : (H) => ?. subst y. by rewrite eqxx in xy.
  - move: (H) => H'. move: H. rewrite pathp_cons => /andP [A B].
    exists a. exists A. exists (Build_Path B). split; first exact: val_inj.
    move => w. by rewrite in_collective nodesE !inE.
Qed.

Lemma splitR x y (p : Path x y) :
  x != y -> exists z (p' : Path x z) zy, p = pcat p' (edgep zy).
Proof.
  move => xy. case: p. elim/last_ind => [|p a IH] H.
  - move/pathp_nil : (H) => ?. subst y. by rewrite eqxx in xy.
  - move: (H) => H'.
    case/andP : H. rewrite rcons_path => /andP [A B] C.
    have sP : pathp x (last x p) p by rewrite /pathp A eqxx.
    move: (pathp_rcons H') => ?; subst a.
    exists (last x p). exists (Build_Path sP). exists B.
    apply: val_inj => /=. by rewrite cats1.
Qed.

CoInductive psplit z x y : Path x y -> Prop :=
  PSplit (p1 : Path x z) (p2 : Path z y) : psplit z (pcat p1 p2).

Lemma psplitP z x y (p : Path x y) : z \in p -> psplit z p.
Proof.
  move: (valP p) => pth_p in_p. rewrite mem_path nodesE in in_p.
  case/(ppsplitP in_p) E : _ / pth_p => [p1 p2 P1 P2].
  have -> : p = pcat (Sub p1 P1) (Sub p2 P2) by exact: val_inj.
  by constructor.
Qed.

(** This should be the canonical way to split irredundant paths *)
CoInductive isplit z x y : Path x y -> Prop :=
  ISplit (p1 : Path x z) (p2 : Path z y) :
    irred p1 -> irred p2 -> (forall k, k \in p1 -> k \in p2 -> k = z) -> isplit z (pcat p1 p2).

Lemma isplitP z x y (p : Path x y) : irred p -> z \in p -> isplit z p.
Proof.
  move => I in_p. case/psplitP : _ / in_p I => p1 p2 /irred_catE [*].
  by constructor.
Qed.

Lemma split_at_first_aux {A : pred D} x y (p : seq D) k :
    pathp x y p -> k \in A -> k \in x::p ->
    exists z p1 p2, [/\ p = p1 ++ p2, pathp x z p1, pathp z y p2, z \in A
                & forall z', z' \in A -> z' \in x::p1 -> z' = z].
Proof.
  move => pth_p in_A in_p.
  pose n := find A (x::p).
  pose p1 := take n p.
  pose p2 := drop n p.
  pose z := last x p1.
  have def_p : p = p1 ++ p2 by rewrite cat_take_drop.
  move: pth_p. rewrite {1}def_p pathp_cat. case/andP => pth_p1 pth_p2.
  have X : has A (x::p) by apply/hasP; exists k.
  exists z. exists p1. exists p2. split => //.
  - suff -> : z = nth x (x :: p) (find A (x :: p)) by exact: nth_find.
    rewrite /z /p1 last_take // /n -ltnS. by rewrite has_find in X.
  - move => z' in_A' in_p'.
    have has_p1 : has A (x::p1) by (apply/hasP;exists z').
    rewrite /z (last_nth x) -[z'](nth_index x in_p').
    suff -> : index z' (x::p1) = size p1 by [].
    apply/eqP. rewrite eqn_leq. apply/andP;split.
    + by rewrite -ltnS -[(size p1).+1]/(size (x::p1)) index_mem.
    + rewrite leqNgt. apply: contraTN in_A' => C.
      rewrite -[z'](nth_index x in_p') unfold_in before_find //.
      apply: leq_trans C _.
      have -> : find A (x :: p1) = n by rewrite /n def_p -cat_cons find_cat has_p1.
      rewrite size_take. by case: (ltngtP n (size p)) => [|/ltnW|->].
Qed.

Lemma split_at_first {A : pred D} x y (p : Path x y) k :
  k \in A -> k \in p ->
  exists z (p1 : Path x z) (p2 : Path z y),
    [/\ p = pcat p1 p2, z \in A & forall z', z' \in A -> z' \in p1 -> z' = z].
Proof.
  case: p => p pth_p /= kA kp. rewrite mem_path nodesE in kp.
  case: (split_at_first_aux pth_p kA kp) => z [p1] [p2] [def_p pth_p1 pth_p2 A1 A2].
  exists z. exists (Build_Path pth_p1). exists (Build_Path pth_p2). split => //.
  + subst p. exact: val_inj.
  + move => ?. rewrite mem_path nodesE. exact: A2.
Qed.

Lemma irred_is_edge (x y : D) (p : Path x y) :
  irred p -> x != y -> {subset p <= [set x;y]} -> exists xy : x -- y, p = edgep xy.
Proof.
  move => Ip xDy sub_xy. case: (splitL p xDy) => y' [xy'] [p' [def_p _]].
  subst. move: Ip. rewrite irred_edgeL => /andP[xp' Ip'].
  suff ? : y' = y. { subst. rewrite [p']irredxx // pcat_idR. by exists xy'. }
  move/(_ y') : sub_xy. rewrite mem_pcat path_begin orbT !inE => /(_ isT).
  case/orP => /eqP ?; subst => //. by rewrite path_begin in xp'.
Qed.

(** *** Between nodes (reflection lemmas) *)

(** NOTE: need to require either x != y or x \in A since packaged
paths are never empty *)
Lemma connect_irredRP {A : pred D} x y : x != y ->
  reflect (exists2 p: Path x y, irred p & p \subset A)
          (connect (restrict A (--)) x y).
Proof.
  move => Hxy. apply: (iffP connect_restrictP) => //.
  - case => p [pth_p lst_p uniq_p sub_A].
    have pvalP : pathp x y p by rewrite /pathp pth_p lst_p.
    exists (Build_Path pvalP); first by rewrite irredE nodesE.
    apply/subsetP => z. rewrite mem_path nodesE. exact: sub_A.
  - case => p Ip /subsetP subA; exists (val p).
    by case/andP : (valP p) => ? /eqP ?; rewrite -nodesE -irredE.
Qed.

(* This is only useful if the [x = y] case does not require [x \in A] *)
Lemma connect_restrict_case x y (A : pred D) :
  connect (restrict A (--)) x y ->
  x = y \/ [/\ x != y, x \in A, y \in A & connect (restrict A (--)) x y].
Proof.
  case: (altP (x =P y)) => [|? conn]; first by left.
  case/connect_irredRP : (conn) => // p _ /subsetP subA.
  right; split => //; by rewrite subA ?path_end ?path_begin.
Qed.

Lemma connectRI (A : pred D) x y (p : Path x y) :
  {subset p <= A} -> connect (restrict A (--)) x y.
Proof.
  case: (boolP (x == y)) => [/eqP ?|]; first by subst y; rewrite connect0.
  move => xy subA. apply/connect_irredRP => //. case: (uncycle p) => p' p1 p2.
  exists p' => //. apply/subsetP => z /p1. exact: subA.
Qed.

End DiGraphTheory.
Arguments connect_irredRP {D A x y}.
Arguments connectRI {D A x y} p.
Arguments irred_is_edge [D x y] p.

Section DiPathTheory.
Variable (G : diGraph).
Implicit Types (x y z : G).

Section Finite.
  Variables x y : G.
  Notation UPath := (UPath x y).

  Definition UPath_tuple (up : UPath) : {n : 'I_#|G| & n.-tuple G} :=
    let (p, Up) := up in existT _ (Ordinal (upath_size Up)) (in_tuple p).
  Definition tuple_UPath (s : {n : 'I_#|G| & n.-tuple G}) : option UPath :=
    let (_, p) := s in match boolP (upath x y p) with
      | AltTrue Up => Some (Sub (val p) Up)
      | AltFalse _ => None
    end.
  Lemma UPath_tupleK : pcancel UPath_tuple tuple_UPath.
  Proof.
    move=> [/= p Up].
    case: {-}_ / boolP; last by rewrite Up.
    by move=> Up'; rewrite (bool_irrelevance Up' Up).
  Qed.

  Definition UPath_finMixin := Eval hnf in PcanFinMixin UPath_tupleK.
  Canonical UPath_finType := Eval hnf in FinType UPath UPath_finMixin.

  Definition UPathW (up : UPath) : Path x y := let (p, Up) := up in Sub p (upathW Up).
End Finite.

(** ** Packaged Irredundant Paths

Quantification over all paths is, a priori, undecidable. However,
quantification over irredundant paths is decidable and usually
sufficient. We define a type family of irredundant paths and endow it
with a finType structure. *)

Section IPath.
  Variables (x y : G).
  Record IPath : predArgType := { ival : Path x y; ivalP : irred ival }.

  Canonical IPath_subType := [subType for ival].
  Definition IPath_eqMixin := Eval hnf in [eqMixin of IPath by <:].
  Canonical IPath_eqType := Eval hnf in EqType IPath IPath_eqMixin.
  Definition IPath_choiceMixin := Eval hnf in [choiceMixin of IPath by <:].
  Canonical IPath_choiceType := Eval hnf in ChoiceType IPath IPath_choiceMixin.
  Definition IPath_countMixin := Eval hnf in [countMixin of IPath by <:].
  Canonical IPath_countType := Eval hnf in CountType IPath IPath_countMixin.

  Lemma upath_irred p (Up : upath x y p) : irred (Build_Path (upathW Up)).
  Proof. rewrite irredE nodesE. exact: upath_uniq Up. Qed.

  Lemma irred_upath (p : Path x y) : irred p -> upath x y (val p).
  Proof.
    move => Ip. rewrite /upath irredE nodesE in Ip *. rewrite Ip /=.
    by case: p {Ip}.
  Qed.

  Definition irred_of (p0 : UPath x y) : IPath :=
    let (p,Up) := p0 in (Sub (Build_Path (upathW Up)) (upath_irred Up)).
  Definition upath_of (p0 : IPath) : UPath x y :=
    let (p,Ip) := p0 in Sub (val p) (irred_upath Ip).

  Lemma can_irred_of : cancel upath_of irred_of.
  Proof. (do 2 case) => p ? ?. by do 2 apply: val_inj. Qed.

  Definition IPath_finMixin := Eval hnf in CanFinMixin can_irred_of.
  Canonical IPath_finType := Eval hnf in FinType IPath IPath_finMixin.

  Definition path_of_ipath (p : IPath) := ival p.
  Definition in_ipath p x := x \in path_of_ipath p.
  Canonical IPath_predType := Eval hnf in @PredType G (IPath) in_ipath.
  Coercion path_of_ipath : IPath >-> Path.
End IPath.

End DiPathTheory.
#[export]
Hint Resolve ivalP : core.

(** In some constructions a vertex can be typed as belonging to different
graphs. This makes [Path x y] or [x -- y] insufficent for understanding the
proofs. In these contexts one can open the implicit scope to display implicit
types for the most frequently used constructions *)

Declare Scope implicit_scope.
Notation "x -- y :> G" := (@edge_rel G x y) (at level 30, y at next level) : implicit_scope.
Notation "'PATH' G x y" := (@Path G x y) (at level 4) : implicit_scope.
Notation "'IPATH' G x y" := (@IPath G x y) (at level 4) : implicit_scope.

(** ** Basic Constructions on digraphs *)

(** *** Induced Subgraphs *)

Section InducedSubgraph.
  Variables (G : diGraph) (S : {set G}).

  Definition induced_type := { x | x \in S}.

  Definition induced_rel := [rel x y : induced_type | val x -- val y].

  Definition induced := DiGraph induced_rel.

End InducedSubgraph.

Lemma path_to_induced (G : diGraph) (S : {set G}) (x y : induced S) p' :
  @pathp G (val x) (val y) p' -> {subset p' <= S} ->
  exists2 p, pathp x y p & p' = map val p.
Proof.
  move=> pth_p' sub_p'.
  case: (lift_pathp _ _ pth_p' _) => //.
  - move=> z /sub_p' z_S. by apply/codomP; exists (Sub z z_S).
  - move=> p [pth_p /esym eq_p']. by exists p.
Qed.

Lemma induced_path (G : diGraph) (S : {set G}) (x y : induced S) (p : seq (induced S)) :
  pathp x y p -> @pathp G (val x) (val y) (map val p).
Proof.
  elim: p x => /= [|z p IH] x pth_p.
  - by rewrite (pathp_nil pth_p) pathpxx.
  - rewrite !pathp_cons in pth_p *.
    case/andP : pth_p => p1 p2. apply/andP; split => //. exact: IH.
Qed.

Lemma Path_to_induced (G : diGraph) (S : {set G}) (x y : induced S)
  (p : Path (val x) (val y)) : {subset p <= S} -> exists q : Path x y, map val (nodes q) = nodes p.
Proof.
  case: p => p pth_p sub_p. case: (path_to_induced pth_p).
  - move=> z z_p; apply: sub_p. by rewrite mem_path nodesE /= inE z_p.
  - move=> q pth_q eq_p. exists (Sub q pth_q). by rewrite !nodesE /= eq_p.
Qed.

Lemma Path_from_induced (G : diGraph) (S : {set G}) (x y : induced S) (p : Path x y) :
  { q : Path (val x) (val y) | {subset q <= S} & nodes q = map val (nodes p) }.
Proof.
  case: p => p pth_p.
  exists (Build_Path (induced_path pth_p)); last by rewrite !nodesE.
  move=> z; rewrite mem_path nodesE /= -map_cons => /mapP[z' _ ->]; exact: valP.
Qed.

(** *** Edge Deletion *)

Definition num_edges (G : diGraph) := #|[pred x : G * G | x.1 -- x.2]|.

Section DelEdge.

Variable (G : diGraph) (a b : G).

Definition del_rel a b := [rel x y : G | x -- y && ((x != a) || (y != b))].

Definition del_edge := DiGraph (del_rel a b).

Definition subrel_del_edge : subrel (del_rel a b) (@edge_rel G).
Proof. by move => x y /andP []. Qed.

Hypothesis ab : a -- b.

Lemma card_del_edge : num_edges del_edge < num_edges G.
Proof.
  apply: proper_card. apply/properP; split.
  - apply/subrelP. exact: subrel_del_edge.
  - exists (a,b); by rewrite !inE //= /edge_rel /= !eqxx.
Qed.

(** This is the fundamental case analysis for irredundant paths in [G] in
terms of paths in [del_edge a b] *)

(** TOTHINK: The proof below is a slighty messy induction on
[p]. Informally, one would simply check wether [nodes p] contains and
[a] followed by a [b] *)
Lemma del_edge_path_case (x y : G) (p : Path x y) (Ip : irred p) :
    (exists (p1 : @IPath del_edge x a) (p2 : @IPath del_edge b y),
        [/\ nodes p = nodes p1 ++ nodes p2, a \notin p2 & b \notin p1])
  \/ (exists p1 : @IPath del_edge x y, nodes p = nodes p1).
Proof.
  pattern x, y, p. apply irred_ind => //.
  - move => {p Ip}.
    have Ip : irred (@idp del_edge y) by apply: irred_idp. by right;exists (Sub _ Ip).
  - move => {x p Ip} x z p xz Ip xp [[p1] [p2] [A B C]|[p1] E].
    + left.
      have xyD : (x:del_edge) -- z.
      { rewrite /edge_rel/= xz (_ : x != a) //. apply: contraNneq xp => -> .
        by rewrite mem_path A mem_cat -(@mem_path del_edge) path_end. }
      have Iq : irred (pcat (edgep xyD) p1).
      { rewrite irred_edgeL (valP p1) andbT.
        rewrite mem_path A mem_cat -(@mem_path del_edge) negb_or in xp.
        by case/andP : xp. }
      exists (Sub _ Iq). exists p2. split => //.
      * by rewrite /= !nodes_pcat A [nodes p1](nodesE) /= -catA.
      * change (b \notin pcat (edgep xyD) p1).
        rewrite (@mem_pcat del_edge) (negbTE C) orbF mem_edgep negb_or.
        rewrite irred_edgeL in Iq. apply/andP; split.
        -- apply: contraNneq xp => <-.
           by rewrite mem_path A mem_cat -!(@mem_path del_edge) path_begin.
        -- apply: contraTneq Ip => ?. subst z.
           rewrite irredE A cat_uniq [has _ _](_ : _ = true) //.
           apply/hasP. by exists b => /=; rewrite -!(@mem_path del_edge) path_begin.
    + case: (boolP ((x : del_edge) -- z)) => [xzD|xzND].
      * right.
        have Iq : irred (pcat (edgep xzD) p1).
        { by rewrite irred_edgeL (valP p1) mem_path -E -(@mem_path G) xp. }
        exists (Sub _ Iq). by rewrite !nodes_pcat E.
      * left. rewrite /edge_rel/= xz /= negb_or !negbK in xzND.
        case/andP : xzND => /eqP ? /eqP ?. subst x. subst z.
        have Iq : irred (@idp del_edge a) by apply: irred_idp.
        exists (Sub _ Iq). exists p1. split => //=.
        -- by rewrite nodes_pcat E [nodes p1]nodesE /= -cat1s catA !nodesE.
        -- by rewrite (@mem_path del_edge) -E -(@mem_path G).
        -- rewrite (@mem_path del_edge) nodesE /= inE.
           apply: contraNneq xp => <-.
           by rewrite mem_path E -(@mem_path del_edge) path_begin.
Qed.

End DelEdge.

Lemma del_edge_lift_proof (G : diGraph) (a b x y : G) p :
  @pathp (del_edge a b) x y p -> @pathp G x y p.
Proof. case: G a b x y p => T e a b x y p. apply: subrel_pathp. exact: subrel_del_edge. Qed.

(** ** Interior of irredundant paths *)

(* TOTHINK: This definition really only makes sense for irredundant paths *)
Section Interior.
Variable (G : diGraph) (x y : G).
Implicit Types (p : Path x y).

Definition interior p := [set x in p] :\: [set x;y].

Lemma interior_edgep (xy : x -- y) : interior (edgep xy) = set0.
Proof. apply/setP => z. rewrite !inE mem_edgep. by do 2 (case: (_ == _)). Qed.

Lemma interiorN p z : z \in interior p -> z \notin [set x; y].
Proof. rewrite inE. by case (_ \in _). Qed.

Lemma interiorW p z : z \in interior p -> z \in p.
Proof. rewrite !inE. case: (_ \in _) => //. by rewrite andbF. Qed.

Lemma interior0E p : x != y -> irred p -> interior p = set0 -> exists xy, p = edgep xy.
Proof.
  move => xNy Ip P0.
  case: (splitL p xNy) Ip => z [xz] [p'] [E _].
  rewrite E irred_edgeL => /andP [xNp Ip'].
  suff zNy : z = y. { subst. exists xz. by rewrite (irredxx Ip') pcat_idR. }
  apply: contra_eq P0 => C. apply/set0Pn. exists z.
  rewrite !inE negb_or C eq_sym E mem_pcat mem_edgep !eqxx //= orbT !andbT.
  apply: contraNneq xNp => ?. subst z. exact: path_begin.
Qed.

Definition independent (p q : Path x y) :=
  [disjoint interior p & interior q].

Lemma independent_sym (p q : Path x y):
  independent p q -> independent q p.
Proof. by rewrite /independent disjoint_sym. Qed.

End Interior.

(** The lemma below loses the connection between [p1]/[p2] and
[p1']/[p2']. However adding [p1' \subset p1] and [p2' \subset p2]
means that we would only get [interior p1' :|: interior p2' != set0] *)
Lemma disjoint_part (G : diGraph) (x y : G) (p1 p2 : Path x y) :
  irred p1 -> irred p2 -> p1 != p2 ->
  exists (x' y' : G) (p1' p2' : IPath x' y'), independent p1' p2' /\ interior p1' != set0.
Proof.
  move def_P : (mem p1 : pred G) => P. elim/proper_ind : P x y p1 def_P p2.
  move => A IH x y p1 ? p2 Ip1 Ip2 Dp; subst A.
  have Dxy : x != y.
  { apply: contraNneq Dp => ?; subst y. by rewrite (irredxx Ip1) (irredxx Ip2). }
  case: (boolP [disjoint interior p1 & interior p2]) => [dis12|].
  - wlog int_p1 : p1 p2 Ip1 Ip2 dis12 {IH Dp} / interior p1 != set0.
    { suff/orP [N|N] : (interior p1 != set0) || (interior p2 != set0).
      - by move => S; apply: S dis12 N.
      - rewrite disjoint_sym in dis12. by move => S; apply: S dis12 N.
      - apply: contra_neqT Dp. rewrite negb_or !negbK => /andP [/eqP N1 /eqP N2].
        have [[xy ->] [xy' ->]] := (interior0E Dxy Ip1 N1,interior0E Dxy Ip2 N2).
        exact/eqP. }
    by exists x; exists y; exists (Build_IPath Ip1); exists (Build_IPath Ip2).
  - case/pred0Pn => z /= /andP [Z1 Z2].
    case/(isplitP Ip1) def_p1 : _ / (interiorW Z1) => [p1l p1r Ip1l Ip1r Iz1].
    case/(isplitP Ip2) def_p2 : _ / (interiorW Z2) => [p2l p2r Ip2l Ip2r Iz2].
    have/orP [Dl|Dr] : (p1l != p2l) || (p1r != p2r).
    { apply: contraNT Dp. by rewrite negb_or !negbK def_p1 def_p2 => /andP[/eqP->/eqP->]. }
    + apply: (IH _ _ x z p1l _ p2l) => //=. apply/properP.
      rewrite def_p1 subset_pcatL; split => //; exists y; first by rewrite !inE.
      apply: contraTN Z1 => C. by rewrite -(Iz1 y) ?inE // eqxx.
    + apply: (IH _ _ z y p1r _ p2r) => //=. apply/properP.
      rewrite def_p1 subset_pcatR; split => //; exists x; first by rewrite !inE.
      apply: contraTN Z1 => C. by rewrite -(Iz1 x) ?inE // eqxx.
Qed.

Section Transfer.
  Variables (T : finType) (e1 e2 : rel T).
  Let D1 := DiGraph e1.
  Let D2 := DiGraph e2.
  Variables (x y : T) (p p' : @Path D1 x y) (q q' : @Path D2 x y).
  Hypothesis Npq : nodes p = nodes q.
  Hypothesis Npq' : nodes p' = nodes q'.

  Lemma irred_eq_nodes : irred p = irred q.
  Proof. by rewrite !irredE Npq. Qed.

  Lemma mem_eq_nodes : p =i q.
  Proof. move => z /=. by rewrite (@mem_path D1) Npq -(@mem_path D2). Qed.

  Lemma interior_eq_nodes : interior p = interior q.
  Proof.
    rewrite /interior (_ : [set x in p] = [set x in q]) //.
    apply/setP => z. by rewrite !inE mem_eq_nodes.
  Qed.

End Transfer.

Lemma independent_nodes (T : finType) (e1 e2 : rel T) x y (p p' : @Path (DiGraph e1) x y)
  (q q' : @Path (DiGraph e2) x y) (Npq : nodes p = nodes q) (Npq' : nodes p' = nodes q') :
  independent p p' = independent q q'.
Proof. by rewrite /independent (interior_eq_nodes Npq) (interior_eq_nodes Npq'). Qed.

(** ** Isomorphisms *)

Definition is_dhom (F G: diGraph) (h: F -> G): Prop := forall x y, x -- y -> h x -- h y.

Lemma dhom_id G: @is_dhom G G id.
Proof. by []. Qed.

Lemma dhom_comp F G H h k:
  @is_dhom F G h -> @is_dhom G H k -> is_dhom (k \o h).
Proof. intros E E' => x y O. apply E', E, O. Qed.

Record diso (F G: diGraph): Type := Diso
  { diso_v:> bij F G;
    diso_hom: is_dhom diso_v;
    diso_hom': is_dhom diso_v^-1 }.

Lemma edge_diso F G (h: diso F G) x y: h x -- h y = x -- y.
Proof.
  apply/idP/idP; last exact: diso_hom.
  move/(diso_hom' h). by rewrite 2!bijK.
Qed.

(* TODO: scope ... *)
Notation "F ≃ G" := (diso F G) (at level 79).

Definition diso_id {A}: diso A A := @Diso A A bij_id (@dhom_id A) (@dhom_id A).

Definition diso_sym {A B}: diso A B -> diso B A.
Proof. move=>f. apply Diso with (bij_sym f); apply f. Defined.

Definition diso_comp {A B C}: diso A B -> diso B C -> diso A C.
Proof.
  move=> f g.
  apply Diso with (bij_comp f g); apply dhom_comp. apply f. apply g. apply g. apply f.
Defined.

#[export] Instance diso_Equivalence: Equivalence diso.
constructor. exact @diso_id. exact @diso_sym. exact @diso_comp. Defined.

Lemma edge_diso' F G (h: diso F G) x y: h^-1 x -- h^-1 y = x -- y.
Proof. apply (edge_diso (diso_sym h)). Qed.

Lemma Diso' [F G : diGraph] [f : F -> G] [g : G -> F] :
  cancel f g -> cancel g f -> {mono f : x y / x -- y} -> F ≃ G.
Proof.
move => can_f can_g mono_f.
exists (Bij can_f can_g) => /= x y; first abstract by rewrite mono_f.
abstract by rewrite -{1}[x]can_g -{1}[y]can_g mono_f.
Defined.

Lemma Diso'' (F G: diGraph) (f: F -> G) (g: G -> F):
  cancel f g -> cancel g f ->
  (forall x y, x--y -> f x -- f y) -> (forall x y, x--y -> g x -- g y) -> diso F G.
Proof.
  move=> can_f can_g H H'. apply: Diso' (can_f) can_g _.
  abstract by move => x y; apply/idP/idP => [/H'|/H //]; rewrite !can_f.
Defined.

(** *** Induced Subgraphs *)

(** A graph [G] contains a graph [F] as in induced subgraph, written
[F ⇀ G], if there exists an injection from [F] to [G] that preserves
edges in both directions. In particular, we have [induced A ⇀ G] for
every [A : {set G}]. *)

(* This is almost the same statement as the [Diso'] constructor in
digraph.v, but the {mono f: ...} assumtion is better behaved in
proofs. So this should replace the old lemma. *)

(** [G] contains [F] as an induced subgraph *)
Record isubgraph (F G : diGraph) :=
  ISubgraph { isubgraph_fun :> F -> G ;
              isubgraph_inj : injective isubgraph_fun ;
              isubgraph_mono : {mono isubgraph_fun : x y / x -- y} }.
Arguments isubgraph_inj [F G] i.
Notation "F ⇀ G" := (isubgraph F G) (at level 30).

Lemma isubgraph_iso (F G : diGraph) (i : F ⇀ G) : #|G| <= #|F| -> F ≃ G.
Proof.
move: i => [f inj_f mono_f] leqGF.
have onto_f : forall y, y \in codom f by apply: inj_card_onto.
pose g (y : G) : F := iinv (onto_f y).
have can_f : cancel f g by abstract by move => x; rewrite /g iinv_f.
have can_g : cancel g f by abstract by move => x; rewrite /g f_iinv.
exact: Diso' can_f can_g mono_f.
Defined.

Lemma isubgraph_comp (F G H : diGraph) (i : F ⇀ G) (j : G ⇀ H) : F ⇀ H.
Proof.
apply: ISubgraph (j \o i) _ _.
exact: inj_comp (isubgraph_inj j) (isubgraph_inj i).
abstract by move=> x y /=; rewrite !isubgraph_mono.
Defined.

(** ** Unindexed paths *)

(** In order to define the notion of [AB]-connector, we need to
abstract from the incices in [Path x y] *)

Section PathS.
Variable (G : diGraph).

Definition pathS := { x : G * G & Path x.1 x.2 }.
Definition PathS x y (p : Path x y) : pathS := existT (fun x : G * G => Path x.1 x.2) (x,y) p.

Definition in_pathS (p : pathS) : collective_pred G := [pred x | x \in tagged p].
Canonical pathS_predType := Eval hnf in PredType (@in_pathS).
Arguments in_pathS _ /.

(** We can override fst because MathComp uses .1 *)
Definition fst (p : pathS) := (tag p).1.
Definition lst (p : pathS) := (tag p).2.
Arguments fst _ /.
Arguments lst _ /.

Lemma pathS_eta (p : pathS) :
  p = @PathS (fst p) (lst p) (tagged p).
Proof. by case: p => [[x y] ri]. Qed.

Lemma fst_mem (p : pathS) : fst p \in p.
Proof. case: p => [[x y] p] /=. exact: path_begin. Qed.

Lemma lst_mem (p : pathS) : lst p \in p.
Proof. case: p => [[x y] p] /=. exact: path_end. Qed.

(** Concatenation on [pathS] *)

Definition castL (x' x y : G) (E : x = x') (p : Path x y) : Path x' y :=
  match E in (_ = y0) return (Path y0 y) with erefl => p end.

Definition pcatS (p1 p2 : pathS) : pathS :=
  let: (existT x p,existT y q) := (p1,p2) in
  match altP (y.1 =P x.2) with
    AltTrue E => PathS (pcat p (castL E q))
  | AltFalse _ => PathS p
  end.

Lemma pcatSE (x y z : G) (p : Path x y) (q : Path y z) :
  pcatS (PathS p) (PathS q) = PathS (pcat p q).
Proof.
  rewrite /pcatS /=. case: {-}_ /altP => [E|]; last by rewrite eqxx.
  rewrite /castL. by rewrite (eq_irrelevance E erefl).
Qed.

End PathS.

Definition del_edge_liftS (G : diGraph) (a b : G) (p : pathS (del_edge a b)) :=
  let: existT (x,y) p' := p in PathS (Build_Path (del_edge_lift_proof (valP p'))).

Lemma mem_del_edge_liftS (G : diGraph) (a b : G) (p : pathS (del_edge a b))  x :
  (x \in del_edge_liftS p) = (x \in p).
Proof. by case: p => [[u v] p]. Qed.

(** ** Neighborhoods *)

Section Neighborhood_def.

Variable G : diGraph.

Definition open_neigh (u : G) := [set v | u -- v].
Local Notation "N( x )" := (open_neigh x) (at level 0, x at level 99, format "N( x )").

Definition closed_neigh (u : G) := u |: N(u).
Local Notation "N[ x ]" := (closed_neigh x) (at level 0, x at level 99, format "N[ x ]").

Definition dominates (u v : G) : bool := (u == v) || (u -- v).

Variable D : {set G}.

Definition open_neigh_set : {set G} := \bigcup_(w in D) N(w).

Definition closed_neigh_set : {set G} := \bigcup_(w in D) N[w].

End Neighborhood_def.

Notation "x -*- y" := (dominates x y) (at level 30).

Notation "N( x )" := (@open_neigh _ x)
   (at level 0, x at level 99, format "N( x )").
Notation "N[ x ]" := (@closed_neigh _ x)
   (at level 0, x at level 99, format "N[ x ]").
Notation "N( G ; x )" := (@open_neigh G x)
   (at level 0, G at level 99, x at level 99, only parsing).
Notation "N[ G ; x ]" := (@closed_neigh G x)
   (at level 0, G at level 99, x at level 99, only parsing).

Notation "NS( G ; D )" := (@open_neigh_set G D)
   (at level 0, G at level 99, D at level 99, only parsing).
Notation "NS( D )" := (open_neigh_set D)
   (at level 0, D at level 99, format "NS( D )").
Notation "NS[ G ; D ]" := (@closed_neigh_set G D)
   (at level 0, G at level 99, D at level 99, only parsing).
Notation "NS[ D ]" := (closed_neigh_set D)
   (at level 0, D at level 99, format "NS[ D ]").

Notation "N( G ; x )" := (@open_neigh G x)
   (at level 0, G at level 99, x at level 99, format "N( G ; x )") : implicit_scope.
Notation "N[ G ; x ]" := (@closed_neigh G x)
   (at level 0, G at level 99, x at level 99, format "N[ G ; x ]") : implicit_scope.

Section Basic_Facts_Neighborhoods.

Variable G : diGraph.
Implicit Types (u v : G).

Lemma dominates_refl : reflexive (@dominates G).
Proof. by move => x; rewrite /dominates eqxx. Qed.

Lemma in_opn u v : u \in N(v) = (v -- u).
Proof. by rewrite /open_neigh in_set. Qed.

Lemma in_cln u v : u \in N[v] = (v -*- u).
Proof. by rewrite /closed_neigh in_setU1 eq_sym in_opn. Qed.

Lemma opns0 : NS(G;set0) = set0.
Proof. by rewrite /open_neigh_set big_set0. Qed.

Lemma clns0 : NS[G;set0] = set0.
Proof. by rewrite /closed_neigh_set big_set0. Qed.

Variables D1 D2 : {set G}.

Lemma opn_sub_opns v : v \in D1 -> N(v) \subset NS(D1).
Proof. move=> vinD1; exact: bigcup_sup. Qed.

Lemma cln_sub_clns v : v \in D1 -> N[v] \subset NS[D1].
Proof. move=> vinD1; exact: bigcup_sup. Qed.

Lemma v_in_clneigh v : v \in N[v].
Proof. by rewrite in_cln dominates_refl. Qed.

Lemma set_sub_clns : D1 \subset NS[D1].
Proof.
  apply/subsetP => x xinD1.
  apply/bigcupP; exists x => //. exact: v_in_clneigh.
Qed.

Lemma mem_opns u v : u \in D1 -> u -- v -> v \in NS(D1).
Proof. move=> uinD1 adjuv. apply/bigcupP ; exists u => // ; by rewrite in_opn. Qed.

Lemma opns_sub_clns : NS(D1) \subset NS[D1].
Proof.
  apply/subsetP => u /bigcupP [v vinD1 uinNv].
  apply/bigcupP; exists v => //; by rewrite /closed_neigh in_setU uinNv orbT.
Qed.

Lemma mem_clns u v : u \in D1 -> u -- v -> v \in NS[D1].
Proof.
  move=> uinD1 adjuv; apply: (subsetP opns_sub_clns).
  exact: mem_opns adjuv.
Qed.

Lemma subset_clns : D1 \subset D2 -> NS[D1] \subset NS[D2].
Proof.
  move => D1subD2.
  by rewrite -(setID D2 D1) (setIidPr _) // /closed_neigh_set bigcup_setU subsetUl.
Qed.

End Basic_Facts_Neighborhoods.


Require Import Setoid Morphisms.
From mathcomp Require Import all_ssreflect.
From GraphTheory Require Import setoid_bigop structures pttdom mgraph mgraph2.

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

Section s.
Variable X: pttdom.
Notation test := (test X).
Notation graph := (graph test X).
Notation graph2 := (graph2 test X).

(** * Rewrite System for 2p-graphs (additive presentation) *)

(** In this file we define a rewrite system for reducing 2p-graphs
labeled with elements of a 2pdom algebra.  *)

(** note:
- we need everything to be finite to get a terminating rewrite system
- elsewhere we don't care that the edge type is a finType, it could certainly just be a Type
- the vertex type has to be an eqType at various places since we regularly compare vertices (e.g., [add_vlabel])
- the vertex type has to be a finType for the [merge] operation, but only in order to express the new vertex labeling function... we could imagine a [finitary_merge] operation that would not impose this restriction
- the vertex type has to be finite also when we go to open graphs (although maybe countable would suffice) *)

Inductive step: graph2 -> graph2 -> Prop :=
  | step_v0: forall G alpha,
      step
        (G ∔ alpha)
        G
  | step_v1: forall (G: graph2) x u alpha,
      step
        (G ∔ alpha ∔ [inl x, u, inr tt])
        (G [tst x <- [dom (u·elem_of alpha)]])
  | step_v2: forall G x y u alpha v,
      step
        (G ∔ alpha ∔ [inl x, u, inr tt] ∔ [inr tt, v, inl y])
        (G ∔ [x, u·elem_of alpha·v, y])
  | step_e0: forall G x u,
      step
        (G ∔ [x, u, x])
        (G [tst x <- [1%ptt∥u]])
  | step_e2: forall G x y u v,
      step
        (G ∔ [x, u, y] ∔ [x, v, y])
        (G ∔ [x, u∥v, y]).

Inductive steps: relation graph2 :=
  | iso_step F G: iso2 F G -> steps F G
  | cons_step F G H H': iso2 F G -> step G H -> steps H H' -> steps F H'.

Global Instance PreOrder_steps: PreOrder steps.
Proof.
  split. intro. by apply iso_step.
  intros F G H S S'. induction S as [F G I|F G G' G'' I S _ IH].
  - destruct S' as [F' G' I'|F' G' G'' G''' I' S'].
    apply iso_step. etransitivity; eassumption.
    apply cons_step with G' G''=>//. etransitivity; eassumption.
  - apply cons_step with G G'=>//. by apply IH.
Qed.

Global Instance isop_step: subrelation iso2prop steps.
Proof. intros F G [H]. by apply iso_step. Qed.

Global Instance one_step: subrelation step steps.
Proof. intros F G S. now apply cons_step with F G. Qed.

Lemma steps_refl G: steps G G.
Proof. reflexivity. Qed.

End s.
#[export]
Hint Resolve steps_refl : core.


Require Import Coq.ZArith.ZArith. Open Scope Z_scope.
Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require Import coqutil.Z.BitOps.
Require Import coqutil.Tactics.Tactics.
Require Import coqutil.Tactics.rewr.
Require Import coqutil.Z.Lia.

Section Lemmas. Local Set Default Proof Using "All".
  Context {width: Z} {word: word.word width} {word_ok: word.ok word}.
  Local Hint Mode word.word - : typeclass_instances.

  Add Ring wring: (@word.ring_theory width word word_ok).

  Lemma sextend_width_nop: forall (w v: Z),
    w = width ->
    word.of_Z (BitOps.signExtend w v) = word.of_Z v.
  Proof.
    intros. subst. unfold BitOps.signExtend. apply word.unsigned_inj.
    rewrite! word.unsigned_of_Z.
    pose proof (@word.width_pos _ _ word_ok).
    pose proof (Z.pow_pos_nonneg 2 width).
    unfold word.wrap.
    remember (2 ^ width) as M.
    remember (2 ^ (width - 1)) as M2.
    rewrite Z.add_mod by blia.
    rewrite Zminus_mod by blia.
    rewrite Z.mod_mod by blia.
    rewrite <- (Z.mod_mod M2 M) at 2 by blia.
    rewrite <- Zminus_mod by blia.
    rewrite Z.add_simpl_r.
    rewrite Z.mod_mod by blia.
    reflexivity.
  Qed.

End Lemmas.

Ltac simpl_Zcsts :=
  repeat so fun hyporgoal => match hyporgoal with
         | context [Z.add ?a ?b] =>
           match isZcst a with true => idtac end;
           match isZcst b with true => idtac end;
           let r := eval cbv in (Z.add a b) in change (Z.add a b) with r in *
         | context [Z.sub ?a ?b] =>
           match isZcst a with true => idtac end;
           match isZcst b with true => idtac end;
           let r := eval cbv in (Z.sub a b) in change (Z.sub a b) with r in *
         | context [Z.mul ?a ?b] =>
           match isZcst a with true => idtac end;
           match isZcst b with true => idtac end;
           let r := eval cbv in (Z.mul a b) in change (Z.mul a b) with r in *
         | context [Z.of_nat ?x] =>
           match isnatcst x with true => idtac end;
           let r := eval cbv in (Z.of_nat x) in change (Z.of_nat x) with r in *
         end.

Ltac simpl_word_exprs_getEq OK t :=
  match t with
  | context[ @word.add ?wi ?wo (word.of_Z 0) ?x ] => constr:(@word.add_0_l wi wo OK x)
  | context[ @word.add ?wi ?wo ?x (word.of_Z 0) ] => constr:(@word.add_0_r wi wo OK x)
  | context[ @word.mul ?wi ?wo (word.of_Z 0) ?x ] => constr:(@word.mul_0_l wi wo OK x)
  | context[ @word.mul ?wi ?wo ?x (word.of_Z 0) ] => constr:(@word.mul_0_r wi wo OK x)
  | context[ @word.mul ?wi ?wo (word.of_Z 1) ?x ] => constr:(@word.mul_1_l wi wo OK x)
  | context[ @word.mul ?wi ?wo ?x (word.of_Z 1) ] => constr:(@word.mul_1_r wi wo OK x)
  | context[ word.of_Z (BitOps.signExtend ?w ?v)] => constr:(@sextend_width_nop _ _ OK w v)
  end.

#[global] Hint Rewrite
     Nat2Z.inj_succ
     Nat2Z.inj_add
     Nat2Z.inj_mul
     List.app_length
  : rew_simpl_Z_nat.

#[global] Hint Unfold
     Z.succ
  : unf_simpl_Z_nat.

Ltac simpl_Z_nat_getEq t :=
  match t with
  (* no assumptions: *)
  | context[ Z.of_nat (S ?n) ] => constr:(Nat2Z.inj_succ n)
  | context[ Z.of_nat (?n + ?m) ] => constr:(Nat2Z.inj_add n m)
  | context[ Z.of_nat (?n * ?m) ] => constr:(Nat2Z.inj_mul n m)
  | context[ length (?l1 ++ ?l2) ] => constr:(List.app_length l1 l2)
  (* only assumption: 0 <= a *)
  | context[ Z.of_nat (Z.to_nat ?a) ] => constr:(Z2Nat.id a)
  end.

Ltac simpl_Z_nat_step :=
  (* NOTE: For consistency with Coq's "rewrite", "rewr" adopts the same unintuitive
     priorities between "by" and "||", namely that "||" binds stronger than "by".
     For instance,
        rewrite ?Z.mul_assoc by fail || rewrite Z.add_assoc by fail
     is
        rewrite ?Z.mul_assoc by (fail || rewrite Z.add_assoc by fail)
     instead of
        (rewrite ?Z.mul_assoc by fail) || (rewrite Z.add_assoc by fail)
     and "rewr" does the same, so we do need parentheses here *)
  (rewr simpl_Z_nat_getEq in * by assumption) ||
  autounfold with unf_simpl_Z_nat in * ||
  cbn [List.length] in * ||
  simpl_Zcsts.

Ltac simpl_Z_nat := repeat simpl_Z_nat_step.

Ltac simpl_word_exprs OK :=
  simpl_Z_nat;
  lazymatch type of OK with
  | @word.ok ?width ?Inst =>
    rewr (simpl_word_exprs_getEq OK) in * by (reflexivity || congruence)
  | _ => fail 10000 "wordok is not of type word.ok"
  end.

Ltac solve_word_eq OK :=
  match goal with
  | |- @eq (@word.rep _ _) ?x ?y =>
    tryif (assert_succeeds (assert (word.sub x x = word.of_Z 0) by ring))
    then idtac
    else fail 10000 "ring is not available, did you forget 'Add Ring'?"
  | _ => fail 1 "wrong shape of goal"
  end;
  subst;
  try reflexivity;
  repeat match goal with
         | x: ?T |- _ => lazymatch T with
                         | word.ok _ => fail
                         | _ => clear x
                         end
         end;
  simpl;
  simpl_word_exprs OK;
  (ring || (try reflexivity)).