(* 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 ssralg fingroup finalg zmodp matrix.
Require Import Reals.
From mathcomp Require Import Rstruct.
Require Import ssr_ext ssralg_ext ssrR Reals_ext Rbigop f2 summary.
Require Import subgraph_partition tanner tanner_partition fdist channel.
Require Import checksum.

(******************************************************************************)
(*               Technical lemmas about the summary operator                  *)
(******************************************************************************)

(* OUTLINE
- Section dprojs_comb.
- Section dproj_F2.
- Section dprojs_subgraph.
- Section dprojs_subgraph_acyclic.
- Section dprojs_subsubgraph.
- Section dprojs_subsubgraph_acyclic.
*)

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

Local Open Scope vec_ext_scope.
Local Open Scope ring_scope.

Section dprojs_comb.

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

Implicit Types d t : 'rV[F]_n.
Implicit Types s : {set 'I_n}.
Implicit Types A : finType.

Definition dproj d s t :=
  locked (\row_(j < n) if j \in s then t ``_ j else d ``_ j).

Lemma sub_vec_dproj d t s' s : s \subset s' -> (dproj d s' t) \# s = t \# s.
Proof.
move=> s's.
rewrite /dproj; unlock; apply/rowP => i; rewrite !mxE; case: ifPn => //.
move/subsetP: s's => /(_ (enum_val i)); by rewrite enum_valP => ->.
Qed.

Lemma dproj_out d t s i : i \notin s -> (dproj d s t) ``_ i = d ``_i.
Proof. move=> H; by rewrite /dproj; unlock; rewrite mxE (negbTE H). Qed.

Lemma dproj_in d t s i : i \in s -> (dproj d s t) ``_ i = t ``_i.
Proof. move=> H; by rewrite /dproj; unlock; rewrite mxE H. Qed.

Lemma freeon_dproj d t s : freeon s d (dproj d s t).
Proof.
apply/forallP => n1; apply/implyP => n1s; by rewrite dproj_out.
Qed.

Lemma dprojIdef d d' t s : dproj d s (dproj d' s t) = dproj d s t.
Proof.
apply/rowP => b; case/boolP : (b \in s) => Hb; by
  [rewrite !dproj_in | rewrite dproj_out // dproj_out].
Qed.

Lemma dproj_freeon d s t : freeon s d t -> dproj d s t = t.
Proof.
move=> /= H; apply/rowP => i; case/boolP : (i \in s) => Hb; by
  [rewrite dproj_in | rewrite dproj_out // -(freeon_notin H)].
Qed.

(* family of projections with default *)
Definition dprojs d A (g : A -> {set 'I_n}) t :=
  locked [ffun a => dproj d (g a) t].

Lemma sub_vec_dprojs d t A (g : A -> {set 'I_n}) s a :
  s \subset g a -> ((dprojs d g t) a) \# s = t \# s.
Proof. rewrite /dprojs; unlock => H0; by rewrite ffunE sub_vec_dproj. Qed.

Lemma freeon_dprojs d t A (g : A -> {set 'I_n}) a : freeon (g a) d ((dprojs d g t) a).
Proof. rewrite /dprojs; unlock; rewrite ffunE; by rewrite freeon_dproj. Qed.

Lemma dprojs_in d t A (g : A -> {set 'I_n}) n0 a :
  n0 \in g a -> ((dprojs d g t) a) ``_ n0 = t ``_ n0.
Proof. move=> ?; by rewrite /dprojs; unlock; rewrite ffunE dproj_in. Qed.

Lemma dprojs_out d t A (g : A -> {set 'I_n}) n0 a :
  n0 \notin g a -> ((dprojs d g t) a) ``_ n0 = d ``_n0.
Proof. move=> ?; by rewrite /dprojs; unlock; rewrite ffunE dproj_out. Qed.

(* combination of projections *)
Definition comb d A (f : {ffun A -> 'rV[F]_n}) (g : A -> {set 'I_n}) :=
  locked (\row_(j < n) (if [pick a | j \in g a] is Some a then (f a) ``_ j else d ``_ j)).

Lemma comb_in d A (f : {ffun A -> 'rV[F]_n}) (g : A -> {set 'I_n}) n1 a :
  [pick a | n1 \in g a] = Some a -> (comb d f g) ``_ n1 = (f a) ``_ n1.
Proof. by rewrite /comb; unlock; rewrite mxE => ->. Qed.

Lemma comb_out d A (f : {ffun A -> 'rV[F]_n}) (g : A -> {set 'I_n}) n1 :
  [pick a | n1 \in g a] = None-> (comb d f g) ``_ n1 = d ``_ n1.
Proof. move=> Hn1; rewrite /comb; unlock => /=; by rewrite mxE Hn1. Qed.

Lemma comb_dprojs_not_in_partition d A (g : A -> {set 'I_n}) n0 t :
  [forall a, n0 \notin g a] ->
  (comb d (dprojs d g t) g) ``_ n0 = d ``_ n0.
Proof.
move=> /forallP H0.
rewrite comb_out //.
case: pickP => // m0.
by rewrite (negbTE (H0 _)).
Qed.

Lemma comb_dprojs d A (g : A -> {set 'I_n}) t :
  (forall n0, t ``_ n0 = d ``_ n0 \/ exists a, n0 \in g a) ->
  comb d (dprojs d g t) g = t.
Proof.
move=> K.
apply/rowP => n1.
rewrite /comb; unlock => /=; rewrite mxE.
case: pickP => [/= a Ha | ]; first by rewrite dprojs_in.
move=> /= Hpred0.
case: {K}(K n1) => [ //| [a Ha]].
exfalso.
move: (Hpred0 a); by rewrite Ha.
Qed.

End dprojs_comb.

Section dproj_F2.

Variable n : nat.

Implicit Types d t : 'rV['F_2]_n.
Implicit Types s : {set 'I_n}.

Lemma checksubsum_dproj d t s s0 : (forall i, i \in s :\: s0 -> t ``_ i = d ``_ i) ->
  \delta s (dproj d s0 t) = \delta s t.
Proof.
move=> H1.
rewrite /checksubsum; congr (_ == Zp0).
apply eq_big => n1 // Hn1.
case/boolP : (n1 \in s0) => [H|H]; first by rewrite dproj_in.
by rewrite dproj_out // H1 // in_setD H.
Qed.

Lemma checksubsum_dprojD1 d n0 t s : t ``_ n0 = d ``_ n0 ->
  \delta s (dproj d (s :\ n0) t) = \delta s t.
Proof.
move=> ?; rewrite checksubsum_dproj // => n1.
by rewrite in_setD in_setD1 negb_and negbK => /andP[] /orP[/eqP -> //|/negbTE ->].
Qed.

Lemma checksubsum_dproj_freeon d s0 s t : freeon s0 d t ->
  \delta s (dproj d s0 t) = \delta s t.
Proof.
move=> Ht.
rewrite checksubsum_dproj // => i; rewrite in_setD => /andP[H1 H2].
by rewrite (freeon_notin Ht).
Qed.

End dproj_F2.

Section dprojs_subgraph.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).
Hypothesis Hconnected : forall a b, connect (tanner_rel H) a b.
Local Notation "''V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "''F(' x ',' y ')'" := (Fgraph H x y).
Local Notation "''V'" := (Vnext H).
Local Notation "''F'" := (Fnext H).

Implicit Types d t : 'rV['F_2]_n.

Definition sgraph n0 m0 := 'V(m0, n0) :\ n0.

(* family of projections; for each m1 : 'I_m, returns a projection on `V(m1, n0) :\ n0 *)
Definition dprojs_V d n0 t : {ffun 'I_m -> 'rV_n} := dprojs d (sgraph n0) t.

Lemma pfamily_dprojs_V d n0 t : dprojs d (sgraph n0) t \in
  pfamily d ('F n0) (fun m0 => [pred t | freeon (sgraph n0 m0) d t]).
Proof.
pose pT : predType _ := [predType of simpl_pred 'rV['F_2]_n].
apply/(@pfamilyP _ _ pT); split.
  apply/supportP => m0 n0m0.
  apply/rowP => n1.
  rewrite dprojs_out //.
  apply: contra n0m0.
  rewrite FnextE; exact: mem_VgraphD1_Vnext.
move=> m0 m0n0; by rewrite inE (freeon_dprojs _ _ (sgraph n0)).
Qed.

Definition comb_V d n0 f := comb d f (sgraph n0).

Lemma comb_dprojs_V d i t : t ``_ i = d ``_ i -> comb_V d i (dprojs_V d i t) = t.
Proof.
move=> H0.
rewrite /comb_V /dprojs_V comb_dprojs // => n1.
case/boolP: (i == n1) => [/eqP <-|in1]; [by left | right].
move: (cover_Vgraph_part_vnode Hconnected i) => Hcover.
have : n1 \in cover (Vgraph_part_vnode H i) :\ i by rewrite Hcover !inE eq_sym in1.
rewrite in_setD1 eq_sym in1 /=.
case/bigcupP => /= s /imsetP[m1 Hm1 ->{s} Hn1]; by exists m1.
Qed.

Lemma comb_dprojs_V_not_in_partition d n0 t n1 : (forall m0, n1 \notin sgraph n0 m0) ->
  (comb_V d n0 (dprojs_V d n0 t)) ``_ n1 = d ``_ n1.
Proof.
move=> H0; rewrite /comb_V /dprojs_V comb_dprojs_not_in_partition //.
apply/forallP => m0; by rewrite H0.
Qed.

Lemma comb_V_support d (f : {ffun 'I_m -> 'rV_n}) n0 n1 (s : {set 'I_m}) :
  d.-support f \subset s ->
  ~~ [exists m0, (m0 \in s) && (n1 \in 'V(m0, n0))] ->
  (comb_V d n0 f) ``_ n1 = d ``_ n1.
Proof.
move=> H0 H1.
rewrite /comb_V /comb; unlock; rewrite mxE.
case: pickP => // m1 Hm1.
case/boolP : (m1 \in s) => m1s.
  move: H1; rewrite negb_exists => /forallP/(_ m1).
  rewrite m1s /=.
  by case/setD1P : Hm1 => _ ->.
by move/supportP : H0 => /(_ _ m1s) => ->.
Qed.

Lemma checksubsum_dprojs_V d n0 t m0 m1 :
  m1 \in 'F(m0, n0) -> t ``_ n0 = d ``_ n0 ->
  \delta ('V m1) ((dprojs_V d n0 t) m0) = \delta ('V m1) t.
Proof.
move=> Hm1 tn0dn0.
rewrite /dprojs_V /dprojs; unlock; rewrite ffunE. (* NB: really unlock? *)
rewrite checksubsum_dproj // => n2.
rewrite in_setD => /andP[].
rewrite in_setD1 negb_and negbK.
case/boolP : (n2 == n0) => [/eqP -> //|/= n2n0 Hn2 Hn2'].
move: (Fgraph_Vnext_Vgraph Hm1 Hn2' n2n0).
by rewrite (negbTE Hn2).
Qed.

Lemma freeon_comb_dprojs_V d t n0 : freeon (setT :\ n0) d (comb_V d n0 (dprojs_V d n0 t)).
Proof.
rewrite -freeon_all comb_dprojs_V_not_in_partition // => m0; by rewrite in_setD1 eqxx.
Qed.

End dprojs_subgraph.

Section dprojs_subgraph_acyclic.

Variables (m n : nat) (H : 'M['F_2]_(m, n)).
Hypothesis Hconnected : forall a b, connect (tanner_rel H) a b.
Local Notation "''V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "''F(' x ',' y ')'" := (Fgraph H x y).
Local Notation "''V'" := (Vnext H).
Local Notation "''F'" := (Fnext H).

Implicit Types d : 'rV['F_2]_n.

Hypothesis Hacyclic : acyclic (tanner_rel H).

Lemma comb_V_in d (f : {ffun 'I_m -> 'rV_n}) n0 m0 n1 :
  n1 \in 'V(m0, n0) :\ n0 -> (comb_V H d n0 f) ``_ n1 = (f m0) ``_ n1.
Proof.
move=> Hn1; rewrite /comb_V (@comb_in _ _ _ _ f _ _ m0) //.
case: pickP => [m1 Hm1 | ].
  case/boolP : (m0 == m1) => [/eqP -> // | m0m1].
  have {}Hm1 : n1 \in 'V(m1, n0).
    move: Hm1; rewrite in_setD1; by case/andP.
  move: Hn1; rewrite in_setD1; case/andP => n1n0 Hn1.
  move: (disjoint_Vgraph Hacyclic n1n0 m0m1 Hn1); by rewrite Hm1.
move/(_ m0); by rewrite Hn1.
Qed.

Lemma dprojs_comb_V d n0 (g : 'I_n -> {set 'I_m}) (f : {ffun 'I_m -> 'rV_n}) :
  f \in pfamily d (g n0) (fun i => freeon ('V(i, n0) :\ n0) d) ->
  dprojs_V H d n0 (comb_V H d n0 f) = f.
Proof.
rewrite inE /= => /forallP => /= Hf.
apply/ffunP => /= m0.
apply/rowP => n1.
case/boolP : (n1 \in 'V( m0, n0) :\ n0) => Hn1.
  rewrite dprojs_in //.
  by rewrite (@comb_V_in _ _ _ m0) //.
rewrite dprojs_out //.
move: (Hf m0).
case: ifP => [_ | _ /eqP -> //].
rewrite inE.
by move/freeon_notin => ->.
Qed.

Local Open Scope summary_scope.
Local Open Scope R_scope.

Lemma rmul_rsum_commute0 d n0 (B : finType) (t : 'rV[B]_n)
  (W : forall m, 'rV_m -> 'rV_m -> R) (* channel *)
  (F : 'I_m -> 'rV_n -> R)
  (HF : forall m1 m0 (t' : 'rV_n), m1 \in 'F(m0, n0) -> t' ``_ n0 = d ``_ n0 -> F m1 ((dprojs_V H d n0 t') m0) = F m1 t') :
  \prod_(m0 in 'F n0) (\sum_(t' = d [~'V(m0, n0) :\ n0])
    W _ (t \# 'V(m0, n0) :\ n0) (t' \# 'V(m0, n0) :\ n0) * \prod_(m1 in 'F(m0, n0)) F m1 t') =
  \sum_(t' = d [~ setT :\ n0]) (\prod_(m0 in 'F n0)
    (W _ (t \# 'V(m0, n0) :\ n0) (t' \# 'V(m0, n0) :\ n0) * \prod_(m1 in 'F(m0, n0)) F m1 t')).
Proof.
rewrite (big_distr_big_dep d [pred x in 'F n0] (fun i => freeon ('V(i, n0) :\ n0) d)) [LHS]/=.
rewrite (reindex_onto (dprojs_V H d n0) (comb_V H d n0)); last first.
  rewrite /= => f Hf; by apply (@dprojs_comb_V d n0 (fun n => 'F n)).
rewrite [LHS]/=.
apply/esym/eq_big.
- move=> /= t'.
  case Hlhs : (freeon _ _ t').
    apply/esym.
    rewrite comb_dprojs_V => //; last first.
      by rewrite (freeon_notin Hlhs) // !inE eqxx.
    by rewrite eqxx andbT pfamily_dprojs_V.
  apply/esym/negbTE.
  move/negbT : Hlhs; apply contra.
  case/andP => _ /eqP <-.
  by rewrite freeon_comb_dprojs_V.
- move=> /= t' Ht'.
  apply eq_bigr => m0 Hm0.
  congr (_ * _)%R.
  + by rewrite /dprojs_V sub_vec_dprojs.
  + apply eq_bigr => m1 Hm1.
    by rewrite HF // -(freeon_notin Ht') //= !inE eqxx.
Qed.

End dprojs_subgraph_acyclic.

Section dprojs_subsubgraph.

Variables (m n : nat).
Variable H : 'M['F_2]_(m, n).
Local Notation "'`V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "'`F(' x ',' y ')'" := (Fgraph H x y).
Local Notation "''V'" := (Vnext H).
Local Notation "'`F'" := (Fnext H).

Implicit Types d : 'rV['F_2]_n.

Definition ssgraph m0 n0 n1 :=
  [set n2 | (n1 \in 'V m0 :\ n0) && [exists m1, (m1 \in `F n1 :\ m0) && (n2 \in `V(m1, n1))]].

(* family of projections; for each n1 : 'I_n, returns a projection on ssgraph m0 n0 n1 *)
Definition dprojs_V2 d m0 n0 t : {ffun 'I_n -> 'rV_n} := dprojs d (ssgraph m0 n0) t.

Definition comb_V2 d m0 n0 (f : {ffun 'I_n -> 'rV_n}) := comb d f (ssgraph m0 n0).

Lemma sub_vec_dprojs_V2 d m0 n0 t n1 m1 : n1 \in 'V m0 :\ n0 -> m1 \in `F n1 :\ m0 ->
  (dprojs_V2 d m0 n0 t) n1 \# `V(m1, n1) :\ n1 = t \# `V(m1, n1) :\ n1.
Proof.
move=> Hn1 Hm1; rewrite /dprojs_V2 sub_vec_dprojs //.
apply/subsetP => n2 Hn2.
rewrite inE /ssgraph Hn1 /=; apply/existsP; exists m1; rewrite Hm1.
by move: Hn2; rewrite in_setD1 => /andP[].
Qed.

Lemma checksubsum_dprojs_V2 d m0 n0 (t' t : 'rV_n) n1 m1 m2
  (Hn1 : n1 \in 'V m0 :\ n0) (Hm1 : m1 \in `F n1 :\ m0) (Hm2 : m2 \in `F(m1, n1)) :
  dprojs_V2 d m0 n0 t \in pfamily t' ('V m0 :\ n0)
    (fun n2 => [pred t'' | (dprojs_V H d n2 t'' \in pfamily d (`F n2 :\ m0)
                             (fun m2 => freeon (`V(m2, n2) :\ n2) d)) &&
                           (comb_V H d n2 (dprojs_V H d n2 t'') == t'')]) ->
  \delta ('V m2) ((dprojs_V H d n1 ((dprojs_V2 d m0 n0 t) n1)) m1) =
  \delta ('V m2) t.
Proof.
move=> H0; rewrite /checksubsum; congr (_ == _).
apply eq_bigr => n2 n2m2.
rewrite /dprojs_V /dprojs_V2.
case/boolP : (n2 \in `V( m1, n1) :\ n1) => [Hn2|].
  rewrite dprojs_in // dprojs_in //inE /ssgraph Hn1 /=.
  apply/existsP; exists m1; rewrite Hm1.
  by case/setD1P : Hn2.
move=> Hn2; rewrite dprojs_out //; move: Hn2.
rewrite in_setD1 negb_and negbK.
case/boolP : (n2 == n1) => [/eqP ?|/=]; last first.
  by move/(Fgraph_Vnext_Vgraph Hm2 n2m2) => ->.
subst n2 => /=.
pose pT : predType _ := [predType of simpl_pred 'rV['F_2]_n].
case/(@pfamilyP _ _ pT): H0 => H0 /(_ _ Hn1).
rewrite inE => /andP[_].
move/eqP/rowP/(_ n1).
rewrite comb_dprojs_V_not_in_partition; last first.
  by move=> m3; rewrite in_setD1 eqxx.
rewrite /dprojs_V2 dprojs_in // inE Hn1 /=.
apply/existsP; exists m1; by rewrite Hm1 /= root_in_Vgraph.
Qed.

End dprojs_subsubgraph.

Section dprojs_subsubgraph_acyclic.

Variables (m n : nat).
Variable H : 'M['F_2]_(m, n).
Local Notation "'`V(' x ',' y ')'" := (Vgraph H x y).
Local Notation "'`F(' x ',' y ')'" := (Fgraph H x y).
Local Notation "''V'" := (Vnext H).
Local Notation "'`F'" := (Fnext H).

Implicit Types d : 'rV['F_2]_n.

Hypothesis Hacyclic : acyclic (tanner_rel H).

Lemma comb_dprojs_V2_in_partition d t m0 n0 n1 :
  (exists n2, n1 \in ssgraph H m0 n0 n2) ->
  (comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t)) ``_ n1 = t ``_ n1.
Proof.
case=> n2 Hn2.
have [n2' Hn2'] : exists n2', [pick a | n1 \in ssgraph H m0 n0 a] = Some n2'.
  case: pickP Hn2 => [x Hx _ | /(_ n2) -> //]; by exists x.
rewrite (@comb_in _ _ _ _ _ _ _ n2') //.
rewrite dprojs_in; first by [].
case: pickP Hn2'.
  by move=> x hx [<-].
move=> _ ?.
by exfalso.
Qed.

Lemma comb_dprojs_V2_not_in_subgraph d t n0 m0 (m0n0 : n0 \in 'V m0) n1 :
  n1 \notin `V(m0, n0) -> (comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t)) ``_ n1 = d ``_ n1.
Proof.
move=> Hn1.
rewrite /comb_V2 comb_out //.
case: pickP => [ n2 | // ].
rewrite inE => /andP[Hn2 H0].
suff : n1 \in `V(m0, n0) by rewrite (negbTE Hn1).
case/existsP : H0 => [m1 /andP[H0 H1]].
by apply: (@Vgraph_inclusion _ _ _ Hacyclic n2 m0 n0 m1).
Qed.

Lemma comb_dprojs_V2_Vnext d t n0 m0 (m0n0 : n0 \in 'V m0) :
  (comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t)) ``_ n0 = d ``_ n0.
Proof.
rewrite /comb_V2 comb_out //.
case: pickP => [ n2 | // ].
rewrite inE => /andP[Hn2 /existsP[m1 /andP[Hm1]]].
move/(notin_Vgraph Hacyclic) : m0n0.
by move/(_ _ _ Hn2 Hm1) => /negbTE => ->.
Qed.

Lemma freeon_trans d m0 n0 (m0n0 : n0 \in 'V m0) d' t (Ht : freeon ('V m0 :\ n0) d d') :
  freeon (`V(m0, n0) :\ n0) d t ->
  freeon (`V(m0, n0) :\ n0) d' t.
Proof.
move=> Hlhs2.
apply/forallP => /= n1.
rewrite in_setD1 negb_and negbK.
apply/implyP => /orP[/eqP ->{n1}|].
  rewrite -(freeon_notin Hlhs2) ?in_setD1 ?eqxx //.
  by rewrite (freeon_notin Ht) // !inE eqxx.
move=> Hn1.
rewrite -(freeon_notin Hlhs2) ?in_setD1 ?(negbTE Hn1) ?andbF //.
rewrite (freeon_notin Ht) //.
apply: contra Hn1 => Hn1.
move/Fnext_Vnext_Vgraph : m0n0.
move/subsetP/(_ _ Hn1).
rewrite in_setD1.
by case/andP.
Qed.

Lemma comb_V2_freeon d m0 n0 (m0n0 : n0 \in 'V m0) t' t (Ht : freeon ('V m0 :\ n0) d t') :
  comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t) = t ->
  freeon (`V(m0, n0) :\ n0) t' t.
Proof.
move=> <-.
apply: (freeon_trans m0n0 Ht).
apply/forallP => /= n1.
rewrite in_setD1 negb_and negbK.
apply/implyP => /orP[/eqP ->{n1}|].
  by rewrite comb_dprojs_V2_Vnext // (freeon_notin Ht) // !inE eqxx.
move=> Hn1.
by rewrite comb_dprojs_V2_not_in_subgraph.
Qed.

Hypothesis Hconnected : forall a b, connect (tanner_rel H) a b.

Lemma dprojs_V2_pfamily d m0 n0 (m0n0 : n0 \in 'V m0) t d'
  (d'td : dproj d' ('V m0 :\ n0) t = d) (d't : freeon (`V(m0, n0) :\ n0) d' t) :
  dprojs_V2 H d m0 n0 t \in pfamily d ('V m0 :\ n0)
    (fun n1 => [pred t0 | (dprojs_V H d n1 t0
      \in pfamily d (`F n1 :\ m0) (fun m1 => freeon (`V(m1, n1) :\ n1) d)) &&
        (comb_V H d n1 (dprojs_V H d n1 t0) == t0)]).
Proof.
pose pT : predType _ := [predType of simpl_pred 'rV['F_2]_n].
apply/(@pfamilyP _ _ pT); split.
  apply/supportP => n1.
  rewrite 2!inE /= negb_and negbK.
  case/orP => [ /eqP ->{n1}| m0n1].
    apply/rowP => n2 /=.
    by rewrite /dprojs_V2 dprojs_out // inE /ssgraph 2!inE eqxx.
  apply/rowP => n2 /=.
  by rewrite /dprojs_V2 dprojs_out // inE /ssgraph in_setD1 (negbTE m0n1) andbF.
move=> /= n1 Hn1.
rewrite {1}/in_mem /=.
apply/andP; split.
  apply/familyP => /= m1.
  rewrite {1}/in_mem /=.
  rewrite inE /= in_set1 /=.
  case: ifPn.
    case/andP => m1m0 m1n1.
    apply/forallP => n2.
    apply/implyP => Hn2.
    by rewrite /dprojs_V2 dprojs_out.
  rewrite negb_and negbK.
  case/orP => [ | m1n1 /=].
    move/eqP => -> {m1} /=.
    rewrite /dprojs_V /dprojs_V2.
    apply/eqP/rowP => n2.
    case/boolP : (n2 \in `V( m0, n1) :\ n1) => K; last by rewrite dprojs_out.
    rewrite dprojs_in //.
    case/boolP : (n2 \in ssgraph H m0 n0 n1) => L; last first.
      by rewrite dprojs_out.
    rewrite dprojs_in //.
    move: L; rewrite inE => /andP[L].
    case/existsP => m1 /andP[Hm1 n2m1n1].
    rewrite -d'td.
    case/boolP : (n2 \in 'V m0 :\ n0) => n2m0n0; first by rewrite dproj_in.
    rewrite dproj_out // (freeon_notin d't) //.
    rewrite in_setD1 negb_and negbK.
    rewrite /= in_setD1 negb_and negbK in n2m0n0.
    case/orP : n2m0n0 => [->// | n2m0].
    suff : n2 \notin `V(m0, n0) by move => ->; rewrite orbC.
    apply/negP.
    by apply: disjoint_Vgraph2 n2m1n1 n2m0.
  apply/eqP/rowP => n2.
  rewrite dprojs_out //.
  apply/negP.
  rewrite /= in_setD1.
  case/andP => Hn2' Hn2.
  move/negP : Hn2'; apply.
  rewrite Vgraph_set1 in Hn2.
    by rewrite in_set1 in Hn2.
  by rewrite -FnextE.
rewrite comb_dprojs_V //.
case/boolP: [exists m1, (m1 \in `F n1 :\ m0) && (n1 \in `V( m1, n1))] => X.
  rewrite /dprojs_V2 dprojs_in //; last by rewrite inE /ssgraph Hn1 X.
  by rewrite -d'td dproj_in.
by rewrite /dprojs_V2 dprojs_out // inE /ssgraph Hn1.
Qed.

Lemma comb_dprojs_V2 d m0 n0 (m0n0 : n0 \in 'V m0) d' t
  (d'td : dproj d' ('V m0 :\ n0) t = d) (d't : freeon (`V(m0, n0) :\ n0) d' t) :
  comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t) == t.
Proof.
apply/eqP/rowP => n1.
case/boolP : (n1 == n0) => [/eqP ?|n1n0].
  subst n1.
  rewrite comb_dprojs_V2_Vnext // -d'td dproj_out ?in_setD1 ?eqxx //.
  move/rowP : d'td => /(_ n0).
  by rewrite (freeon_notin d't) // in_setD1 eqxx.
case/boolP : [exists n2, n1 \in ssgraph H m0 n0 n2] => [/existsP[n2 Hn2]|].
  rewrite comb_dprojs_V2_in_partition //; by exists n2.
rewrite negb_exists => H0.
rewrite comb_out; last first.
  case: pickP => // => x.
  by move/forallP : H0 => /(_ x) /negbTE ->.
rewrite -d'td.
case/boolP : (n1 \in 'V m0 :\ n0) => K.
  by rewrite dproj_in.
rewrite dproj_out //.
move/forallP: d't => /(_ n1).
rewrite in_setD1 n1n0 /=.
have -> : n1 \notin `V(m0, n0).
  apply/negP => n1m0n0.
  rewrite in_setD1 negb_and negbK (negbTE n1n0) orFb in K.
  case: (Vgraph_decompose m0n0 n1m0n0 n1n0 K) => n2 [] Hn2 [m1 [H0' H1']].
  move/forallP in H0.
  move: (H0 n2) => /=; rewrite /ssgraph Hn2 /= inE.
  by rewrite negb_exists => /forallP/(_ m1); rewrite H0' /= H1'.
by rewrite implyTb => /eqP.
Qed.

Hypothesis tannerH_simple : simple (tanner_rel H).

Lemma comb_dprojs_V2_Vnext_dangling d m0 n0 t n1 (n1m0 : n1 \in 'V m0) :
  ~~ [exists m1, (m1 \in `F n1 :\ m0)] ->
  (comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t)) ``_ n1 = d ``_ n1.
Proof.
move=> tmp.
rewrite /comb_V2 /dprojs_V2.
rewrite /comb; unlock; rewrite mxE. (* xxx *)
case: pickP => //.
move=> n1'; rewrite inE => /andP[Hn1' /existsP[m1' Hm1']].
case/boolP : (n1 \in ssgraph H m0 n0 n1') => [|L]; last first.
  by rewrite dprojs_out.
rewrite dprojs_in; last first.
  rewrite /ssgraph Hn1' /= inE.
  apply/existsP; exists m1'; by rewrite Hm1'.
rewrite /ssgraph Hn1' /=.
case/andP: Hm1' => Hm1'.
rewrite 3!inE; case/orP => [/eqP ?|].
  subst n1'.
  move=> abs.
  rewrite inE in abs.
  exfalso.
  move/negP : tmp; apply.
  case/existsP : abs => m1 /andP[abs _].
  apply/existsP; by exists m1.
rewrite inE.
case/andP => n1'm1' /connectP [] /= p.
case/shortenP => p' Hp' Hun p'p Hlast.
exfalso.
apply (@Hacyclic [:: inl m0, inr n1', inl m1' & p'] isT).
apply: uniq_path_ucycle_extend_1 => //.
- by rewrite /= -VnextE; move: Hn1'; rewrite in_setD1 => /andP[].
- rewrite rcons_path Hp' /= -Hlast.
  rewrite exceptE /= andbT -VnextE n1m0 /= eq_sym.
  rewrite (path_except_neq _ Hp') // Hlast.
  destruct p' => //=; by rewrite mem_last.
- rewrite rcons_uniq Hun andbT inE negb_or; apply/andP; split.
    apply/eqP; case => m0m1'; by move: Hm1'; rewrite m0m1' in_setD1 eqxx.
  apply/negP => Hx.
  case/splitPr : Hx => p1 p2 in Hp' Hun p'p Hlast.
  rewrite last_cat /= in Hlast.
  apply (@Hacyclic [:: inl m0, inr n1', inl m1' & p1] isT).
  apply: uniq_path_ucycle_extend_1 => //.
  + by rewrite /= -VnextE; move: Hn1'; rewrite in_setD1 => /andP[].
  + move: Hp'; by rewrite -cat_rcons cat_path => /andP[].
  + rewrite rcons_uniq.
    move: Hun; rewrite -cat_cons cat_uniq => /andP[-> /=].
    by rewrite negb_or -andbA => /and3P[->].
Qed.

Lemma dproj_prop d m0 n0 d' t (d'd : freeon ('V m0 :\ n0) d' d)
  (Hpfamily : dprojs_V2 H d m0 n0 t
            \in pfamily d ('V m0 :\ n0)
                  (fun n1 => [pred t0 |
                   (dprojs_V H d n1 t0
                      \in pfamily d (`F n1 :\ m0)
                            (fun m1 => freeon (`V(m1, n1) :\ n1) d)) &&
                   (comb_V H d n1 (dprojs_V H d n1 t0) == t0)]))
  (Ht : comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t) = t) :
  dproj d' ('V m0 :\ n0) t == d.
Proof.
apply/eqP/rowP => n1.
case/boolP : (n1 \in 'V m0 :\ n0) => K; last first.
  by rewrite dproj_out // (freeon_notin d'd).
rewrite dproj_in //.
move: K.
rewrite /= in_setD1.
case/andP => n1n0 Hn1.
pose pT : predType _ := [predType of simpl_pred 'rV['F_2]_n].
case/(@pfamilyP _ _ pT): Hpfamily => _ /(_ n1).
rewrite inE in_set1 n1n0 /= => /(_ Hn1).
rewrite {1}/in_mem /=.
case/andP => /pfamilyP[Hlhs11 Hlhs12].
rewrite /comb_V /dprojs_V /dprojs_V2.
move/eqP/(congr1 (fun x : 'rV_n => x ``_ n1)).
rewrite /comb; unlock => /=.
rewrite mxE.
case: pickP => [m1 Hm1 | _].
  by rewrite in_setD1 eqxx in Hm1.
case/boolP : (n1 \in ssgraph H m0 n0 n1) => [L|L].
  by rewrite dprojs_in.
rewrite dprojs_out //.
move: L.
rewrite /ssgraph inE negb_and in_setD1 Hn1 andbT negbK (negbTE n1n0) orFb.
move=> tmp _.
rewrite -{}Ht comb_dprojs_V2_Vnext_dangling //.
apply: contra tmp => /existsP[m1 Hm1].
apply/existsP; exists m1; rewrite Hm1 /=; exact: root_in_Vgraph.
Qed.

Lemma dprojs_V2_in d m0 n0 t n1 (Hn1 : n1 \in 'V m0 :\ n0)
  (Ht : comb_V2 H d m0 n0 (dprojs_V2 H d m0 n0 t) = t) :
  ((dprojs_V2 H d m0 n0 t) n1) ``_ n1 = t ``_ n1.
Proof.
case/boolP : [exists m1, (m1 \in `F n1 :\ m0)] => [/existsP[m1 K]|K].
  rewrite /dprojs_V2 dprojs_in // inE /ssgraph Hn1 /=.
  by apply/existsP; exists m1; rewrite K root_in_Vgraph.
rewrite dprojs_out /=; last first.
  rewrite inE /ssgraph Hn1 /=.
  apply: contra K => /existsP[x /andP[Hx _]].
  by apply/existsP; exists x.
rewrite -Ht.
rewrite /comb_V2 /dprojs_V2 /= /comb; unlock; rewrite mxE. (* xxx *)
case: pickP => // n3.
rewrite inE => /andP[Hn3 /existsP[m1 /andP[Hm1 Hn1'']]].
rewrite negb_exists in K.
suff n31 : n3 = n1.
  move/forallP : K => /(_ m1).
  by rewrite -{1}n31 Hm1.
move: Hn1''.
rewrite inE in_set1 /= => /orP[/eqP //|].
rewrite 2!inE.
case/andP => m1n3 /connectP [] /= p.
case/shortenP => p' Hp' Hun pp' Hlast.
exfalso.
apply (@Hacyclic [:: inl m0, inr n3, inl m1 & p'] isT).
apply: uniq_path_ucycle_extend_1 => //.
- by rewrite /= -VnextE; move: Hn3; rewrite in_setD1 => /andP[].
- rewrite rcons_path Hp' /= -Hlast exceptE /= andbT -VnextE.
  move: Hn1; rewrite in_setD1 => /andP[_ -> /=].
  rewrite eq_sym (path_except_neq _ Hp') // Hlast.
  destruct p' => //=; by rewrite mem_last.
- rewrite rcons_uniq Hun andbT inE negb_or.
  apply/andP; split.
    apply/eqP; case => ?; subst m1.
    by rewrite in_setD1 eqxx in Hm1.
  apply/negP => Hx.
  case/splitPr : Hx => p1 p2 in Hp' Hun pp' Hlast.
  rewrite last_cat /= in Hlast.
  apply (@Hacyclic [:: inl m0, inr n3, inl m1 & p1] isT).
  apply: uniq_path_ucycle_extend_1 => //.
  + by rewrite /= -VnextE; move: Hn3; rewrite in_setD1 => /andP[].
  + by move: Hp'; rewrite -cat_rcons cat_path => /andP[].
  + rewrite rcons_uniq.
    move: Hun; rewrite -cat_cons cat_uniq => /andP[-> /=].
    by rewrite negb_or -andbA => /andP[ ->].
Qed.

Local Open Scope channel_scope.
Local Open Scope proba_scope.

Lemma rprod_rsum_commute d (B : finType) (x : 'rV_n) (W: `Ch('F_2, B)) m0 n0 (m0n0 : n0 \in 'V m0) :
  let pr n1 t := (dprojs_V H d n1 t \in pfamily d (`F n1 :\ m0)
                   (fun m1 => freeon (`V(m1, n1) :\ n1) d)) &&
                 (comb_V H d n1 (dprojs_V H d n1 t) == t) in
  let g := dprojs_V2 H d m0 n0 in
  let g' := comb_V2 H d m0 n0 in
  (\prod_(n1 in 'V m0 :\ n0)
    (\sum_(t | pr n1 t)
      W (t ``_ n1) (x ``_ n1) *
         \prod_(m1 in `F n1 :\ m0)
           (W ``(x \# `V(m1, n1) :\ n1 | ((dprojs_V H d n1 t) m1) \# `V(m1, n1) :\ n1) *
             \prod_(m2 in `F(m1, n1)) INR (\delta ('V m2) ((dprojs_V H d n1 t) m1)))) =
  \sum_(t | (g t \in pfamily d ('V m0 :\ n0) pr) && (g' (g t) == t))
    \prod_(n1 in 'V m0 :\ n0)
       (W ((g t n1) ``_ n1) (x ``_ n1) *
         \prod_(m1 in `F n1 :\ m0)
           (W ``(x \# `V(m1, n1) :\ n1 | ((dprojs_V H d n1 (g t n1)) m1) \# `V(m1, n1) :\ n1) *
             \prod_(m2 in `F(m1, n1)) INR (\delta ('V m2) ((dprojs_V H d n1 (g t n1)) m1)))))%R.
Proof.
move=> pr g g'.
rewrite (big_distr_big_dep d) /=.
rewrite (reindex_onto (dprojs_V2 H d m0 n0) (comb_V2 H d m0 n0)) //.
move=> /= t' Ht'.
rewrite /dprojs_V2 /comb_V2.
apply/ffunP => /= n1.
apply/rowP => n2.
case/boolP : (n2 \in ssgraph H m0 n0 n1).
  rewrite inE; case/andP => Hn1 /existsP [] m1 Hm1.
  rewrite dprojs_in => /=; last first.
    rewrite /ssgraph Hn1 /= inE.
    apply/existsP; exists m1; by rewrite Hm1.
  move H0 : [pick a | n2 \in ssgraph H m0 n0 a] => [n1'|]; last first.
    case: pickP H0 => //.
    move/(_ n1); rewrite inE Hn1 /= => /negbT; rewrite negb_exists => /forallP/(_ m1).
    by rewrite Hm1.
  have ? : n1' = n1.
    case: pickP H0 => // x0.
    rewrite inE => /andP[Hn1' H0].
    move: H0 => /existsP[m1' /andP[Hm1' Hn2']].
    case/andP : Hm1 => Hm1 Hn2 [<-].
    by rewrite (Vgraph_id Hacyclic m0n0 Hn1 Hn1' Hm1 Hm1' Hn2 Hn2').
  subst n1'.
  by rewrite (@comb_in _ _ d _ t' (ssgraph H m0 n0) _ n1).
rewrite inE negb_and.
case/orP => [Hn1|].
  rewrite dprojs_out /=; last by rewrite inE negb_and Hn1.
  case/pfamilyP : Ht' => Ht' _.
  move/supportP : Ht'.
  by move/(_ n1 Hn1) => ->.
move=> tmp.
case/boolP : (n1 \in 'V m0 :\ n0) => Hn1; last first.
  rewrite dprojs_out //; last by rewrite inE /ssgraph (negbTE Hn1).
  case/pfamilyP : (Ht').
  by move/supportP => /(_ _ Hn1) ->.
case/pfamilyP : (Ht') => _ /(_ _ Hn1).
rewrite {1}/in_mem /=.
case/andP => H1 /eqP <-.
rewrite dprojs_out //; last by rewrite inE /ssgraph Hn1.
rewrite (comb_V_support _ tmp) //; by case/pfamilyP : H1.
Qed.

End dprojs_subsubgraph_acyclic.


(* (c) Copyright 2006-2015 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import path order ssralg ssrnum ssrint div intdiv.
From fourcolor Require Import grid.

(******************************************************************************)
(* Mattes are finite sets of grid squares that are delimited by a simple grid *)
(* ring; we explicitly include the enumeration of the region and the ring.    *)
(* Mattes will be used to define conservative approximations of arbitrary     *)
(* connected open sets of points (regions). We therefore need to provide      *)
(* operations for extending a matte in order to improve the approximation.    *)
(* This involves three different operations :                                 *)
(*   - adding pixels within a specified rectangle that the matte meets, so    *)
(*     that a specific pixel is covered.                                      *)
(*   - adding the pixels surrounding a grid point of the matte boundary.      *)
(*   - refining the grid to ensure that the two previous operations are safe. *)
(* Note that we can't add a large rectangle blindly to a matte if we want to  *)
(* preserve its geometrical properties (we might end up with a disconnected   *)
(* contour). We reduce the first two operations above to two primitives that  *)
(* add a pixel that has exactly one or two consecutive sides in common with   *)
(* the matte, respectively (more precisely, 2 or 3 consecutive vertices in    *)
(* common with the matte contour vertices). We don't actually provide the     *)
(* second operation here, because it requires multiple grid refinements.      *)
(* Instead we provide a basic step that needs to be iterated to accomplish    *)
(* the operation, along with the metric ("matte_order") that decreases with   *)
(* that step.                                                                 *)
(*   The main definitions in this file are:                                   *)
(*       mrlink d1 d2 <=> the end of grid dart d1 (interpreted as a directed  *)
(*                        grid edge -- see grid.v) coincides with the start   *)
(*                        of grid dart d2. This is the successor relation for *)
(*                        the contour cycle of mattes.                        *)
(*    d \in gborder m <=> d is a border edge of the collection m of pixels    *)
(*                        (represented as a sequence of gpoints): the pixel   *)
(*                        on the left of d interpreted as a directed edge     *)
(*                        (a.k.a. the pixel of d) lies in m, while the one on *)
(*                        the right does not.                                 *)
(*               matte == the representation of a simple grid polymino. An    *)
(*                        m : matte comprises two somewhat redundant data:    *)
(*             mdisk m == a (nonempty) sequence comprising the pixels covered *)
(*                        by m : matte; m coerces to both mdisk m and the     *)
(*                        extent of mdisk m (as a collective predicate).      *)
(*             mring m == the node-simple mring-cycle of darts tracing the    *)
(*                        counterclockwise birder of m : matte.               *)
(*       point_matte p == the matte comprising the single pixel p, with mdisk *)
(*                        pmdisk p := [:: p], and mring pmring p.             *)
(*         madj m1 m2 <=> m1 and m2 are adjacent: their respective borders    *)
(*                        contain converse directed edges, separating two     *)
(*                        pixels on the periphery of m1 and m2.               *)
(*      coarse_in r m <-> within r : grect, the matte m is the binary         *)
(*                        refinement of a coarser region: for all r \in p,    *)
(*                        p \in m depends only on halfg p.                    *)
(*      refine_matte m == the matte that covers exactly the subpixels of m in *)
(*  +--+--+--+            the binary refinement of the grid pixels, with      *)
(*  |  |  |  |            mdisk refine_mdisk and mring refine_mring.          *)
(*  +--+--+--+  ehex d == the 3x2 rectangle covering the pixel of the dart d  *)
(*  |  |d |  |            and the five pixels adjacent to it that are in the  *)
(*  +--+->+--+            half-plane to the left of d interpreted as a        *)
(*                        directed edge.                                      *)
(*  +--+--+    equad d == the 2x2 square covering the pixel of the dart d     *)
(*  |  |  |               and the three pixels adjacent to it that are in     *)
(*  +--+--+               quadrant that is both left of d and of gface d      *)
(*  |  |d | gface d       (the next edge after d in the counter-clockwise     *)
(*  +--+->+               border of the pixel of d -- see grid.v).            *)
(*       ext1_hex m d <=> m contains the pixel to the right of d and none of  *)
(*                        the pixels in ehex d.                               *)
(*     ext1_matte Emd <=> the matte extending a matte m with the pixel p of a *)
(*                        dart d, given a proof Emd of ext1_hex m d, which    *)
(*                        implies p is ouside m and touches the border of m   *)
(*                        on exactly one side, at d. The mdisk of ext1_matte  *)
(*                        is ext_mdisk m d := p :: m and its mring is         *)
(*                        ext1_mring m d.                                     *)
(*      ext2_quad m d <=> m contains the pixels to the right of both d and    *)
(*                        gface d, but none of the pixels in equad d.         *)
(*     ext2_matte Emd <=> the matte extending a matte m with the pixel p of a *)
(*                        dart d, given a proof Emd of ext2_quad m d, which   *)
(*                        implies p is ouside m and touches the border of m   *)
(*                        on exactly two consecutive sides, at d and gface d. *)
(*                        The mdisk ext2_matte is ext_mdisk m d and its mring *)
(*                        is ext1_mring m d.                                  *)
(*  matte_extension m xm <-> inductive (indexed) predicate asserting that     *)
(*                        there is a sequence of mattes from m to xm in which *)
(*                        each matte differs from the next by the addition of *)
(*                        exactly ONE adjacent pixel. We use induction on     *)
(*                        this predicate to obtain an extension that is       *)
(*                        adjacent to a given matte.                          *)
(*   extends_in m r p <-> there is some matte_extension xm of m that contains *)
(*                        p and only extends m inside rectangle r; we show    *)
(*                        this holds whenever m is coarse in r, m meets r,    *)
(*                        and p is strictly inside r (i.e., in inset r).      *)
(*         mcorner m q == the number of pixels incident to grid node q that   *)
(*                        are NOT in matte m, other than (upper right) pixel  *)
(*                        q, with the upper left and lower right pixels       *)
(*                        counted twice and the lower left pixel counted only *)
(*                        once. The assymmetry of this definition reflects    *)
(*                        the assymetry of the extent of a pixel in the real  *)
(*                        plane, which includes only the lower left corner    *)
(*                        and edges. Thus, when p \in m and mcorner m p == 0  *)
(*                        all of the pixel p, including the grid point p and  *)
(*                        edges incident to p, lie in the interior of the     *)
(*                        extent of the matte m. If mcorner m p > 0, for any  *)
(*                        dart q of p, viewed as a subpixel of p, we can      *)
(*                        construct an extension xm of refine_matte m such    *)
(*                        that mcorner xm q < mcorner m p.                    *)
(******************************************************************************)

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

Import Order.TTheory GRing.Theory Num.Theory.
Local Open Scope ring_scope.

Definition mrlink := [rel d1 d2 | end1g d1 == end0g d2].

Definition gborder (m : seq gpoint) :=
  [pred d | halfg d \in m & halfg (gedge d) \notin m].

Record matte := Matte {
  mdisk :> seq gpoint;
  mring : seq gpoint;
  matte_ne : ~~ nilp mdisk;
  mring_cycle : cycle mrlink mring;
  mring_simple : uniq (map end0g mring);
  in_mring : mring =i gborder mdisk
}.

Coercion in_matte m := [pred p | p \in mdisk m].

Lemma mring_edge m p : p \in mring m -> gedge p \notin mring m.
Proof. by rewrite !in_mring !inE => /andP[_ /negPf->]. Qed.

Lemma mring_uniq m : uniq (mring m).
Proof. exact: map_uniq (mring_simple m). Qed.

(* Matte adjacency. *)

Definition madj m1 m2 := has [preim gedge of mring m1] (mring m2).

Lemma madj_sym : symmetric madj.
Proof.
apply/symmetric_from_pre=> m1 m2 /hasP[d m2d m1ed].
by apply/hasP; exists (gedge d); rewrite ?inE ?gedge2.
Qed.

Lemma madj_irrefl : irreflexive madj.
Proof.
by move=> m; apply/hasPn=> d; rewrite !inE !in_mring !inE => /andP[_ /negPf->].
Qed.

(* Initial single_square matte. *)

Section PointMatte.

Variable p : gpoint.

Definition pmdisk : seq gpoint := [:: p].
Definition pmring : seq gpoint := traject gface (p *+ 2) 4.

Lemma pmatte_ne : ~~ nilp pmdisk. Proof. by []. Qed.

Lemma pmring_cycle : cycle mrlink pmring.
Proof. by rewrite /= /mrlink -!end0g_face gface4 !eqxx. Qed.

Lemma pmring_simple : uniq (map end0g pmring).
Proof.
rewrite [map _ _]/= /end0g !halfg_face !oddg_face oddg_double.
by rewrite (map_inj_uniq (addrI _) [:: _; _; _; _]).
Qed.

Lemma in_pmring : pmring =i [pred d | halfg d == p].
Proof.
move=> d; rewrite -[p]halfg_double [RHS]eq_sym.
by apply/idP/eqP=> [/trajectP[i _ ->] | /same_halfg]; rewrite ?halfg_iter_face.
Qed.

Lemma pmring_def : pmring =i gborder pmdisk.
Proof.
move=> x; rewrite in_pmring !inE andb_idr // => /eqP<-.
by rewrite eq_sym neq_halfg_edge.
Qed.

Definition point_matte := Matte pmatte_ne pmring_cycle pmring_simple pmring_def.

End PointMatte.

(* Grid refinement for mattes.                                                *)

Section RefineMatte.

Definition coarse_in (r : gregion) (m : matte) :=
  forall p q, r p -> halfg q = halfg p -> (q \in m) = (p \in m).

Variable m : matte.

Definition refine_mring (mr : seq gpoint) : seq gpoint :=
  flatten [seq [seq p *+ 2 + oddg d | p <- [:: d; gface d]] | d <- mr].

Definition refine_mdisk (md : seq gpoint) : seq gpoint :=
  flatten [seq pmring p | p <- md].

Lemma in_refine_mdisk md p : (p \in refine_mdisk md) = (halfg p \in md).
Proof.
apply/flatten_mapP/idP=> [[x] | ] md_x; first by rewrite in_pmring => /eqP->.
by exists (halfg p); last rewrite in_pmring inE.
Qed.

Lemma refine_matte_ne : ~~ nilp (refine_mdisk m).
Proof. by case: (mdisk m) (matte_ne m). Qed.

Lemma refine_mring_cycle : cycle mrlink (refine_mring (mring m)).
Proof.
case: (mring m) (mring_cycle m) => // [d0 mr0]; rewrite !(cycle_path d0).
rewrite [last _ _]/=; set d := last d0 mr0; set mr := d0 :: mr0.
have ->: last d0 (refine_mring mr) = gface d *+ 2 + oddg d.
  by rewrite [mr]lastI /refine_mring -cats1 map_cat flatten_cat last_cat.
elim: {d0 mr0}mr d => //= d2 _ IHmr d1 /andP[/eqP-Ed12 /IHmr{IHmr}->].
rewrite -!subr_eq /end1g !halfg_eq ?oddg_eq ?eqxx // andbC -addrA eqxx /=.
by rewrite -[gface d1]end0g_eq oddg_face subrK end0g_face Ed12 end0g_eq.
Qed.

Lemma in_refine_mring (mr : seq gpoint) d :
 reflect (exists2 d0, d0 \in mr /\ oddg d = oddg d0
                & halfg d = d0 \/ halfg d = gface d0)
         (d \in refine_mring mr).
Proof.
apply: (iffP flatten_mapP) => [[d0 mr_d0 /mapP[p]] | [d0 [mr_d0 Dd] /pred2P]].
  by rewrite !inE => /pred2P-Dp ->; rewrite !oddg_eq ?halfg_eq //; exists d0.
by exists d0 => //; apply/mapP; exists (halfg d); rewrite ?inE // -Dd halfgK.
Qed.

Lemma refine_mring_simple : uniq (map end0g (refine_mring (mring m))).
Proof.
have /hasPn := @mring_edge m; move: (mring m) (mring_simple m).
elim=> //= d r IHr /andP[r'd Ur] /norP[_]; rewrite has_predU => /norP[r'E /IHr].
move=> -> {Ur}//; rewrite !/(end0g _) !halfg_eq ?oddg_eq // inE -addrA subrK.
rewrite (inj_eq (addrI _)) eq_sym neq_ccw /= andbC.
rewrite !(contra _ r'd) /end0g // => /mapP[d1 /in_refine_mring[d0 [r_d0 ->]]].
  case=> -> Dd; first by rewrite -[_ + _]halfg_add_odd Dd halfg_add_odd map_f.
  have /eqP/idPn[]:= congr1 oddg Dd; rewrite oddg_add oddg_double.
  by rewrite oddg_add oddg_face; case: (oddgP d0).
case=> -> Dd; last rewrite -addrA subrK in Dd.
  have:= congr1 oddg Dd; rewrite [RHS]oddg_add oddg_double.
  by rewrite oddg_add; case: (oddgP d).
suff Dd0: oddg d0 = oddg d by move: Dd; rewrite Dd0 => /addIr->; apply: map_f.
have:= congr1 oddg Dd; rewrite oddg_add [RHS]oddg_add.
have{r'E r_d0}: gedge d0 != d := hasPn r'E d0 r_d0.
by rewrite /gedge 2!addrA -Dd -!addrA -subr_eq0 addrC addKr; do 2!case: oddgP.
Qed.

Lemma refine_mring_def : refine_mring (mring m) =i gborder (refine_mdisk m).
Proof.
move: (mdisk m) (in_mring m) => md Dmr d.
rewrite inE !in_refine_mdisk halfg_edge halfg_add; set p := halfg d.
apply/in_refine_mring/andP=> [[d1 [mr_d1 Dd] Dp] | [md_p md'ep]].
  rewrite Dmr !inE halfg_edge -/p in mr_d1 Dp; have [md_d1] := andP mr_d1.
  by case: Dp => ->; rewrite ?halfg_face ?oddg_face -Dd; case: oddgP.
have Dd: pred2 (oddg d) (ccw (oddg d)) (oddg p).
  by have/(memPn md'ep):= md_p; rewrite addrC -subr_eq subrr; do 2!case: oddgP.
exists (halfg p *+ 2 + oddg d).
  rewrite Dmr !inE halfg_edge halfg_eq ?oddg_eq ?md_p //.
  by case: (oddgP d) (oddgP p) Dd md'ep => -[] //.
rewrite gface_def oddg_eq ?halfg_eq //.
by case/pred2P: Dd => <-; [left | right]; rewrite halfgK.
Qed.

Definition refine_matte :=
  Matte refine_matte_ne refine_mring_cycle refine_mring_simple refine_mring_def.

Lemma in_refine_matte p : (p \in refine_matte) = (halfg p \in m).
Proof. exact: in_refine_mdisk. Qed.

Lemma refine_matte_coarse r : coarse_in r refine_matte.
Proof. by move=> p q _ Dq; rewrite /= !in_refine_matte Dq. Qed.

End RefineMatte.

Section ExtendMatte.

Variable m : matte.

Definition ext_mdisk d : seq gpoint := halfg d :: m.

Lemma ext_mdisk_ne d : ~~ nilp (ext_mdisk d).
Proof. by []. Qed.

Definition ehex d := gchop_rect (gtouch (halfg d)) d.

Definition equad d := gchop_rect (ehex d) (gface d).

Lemma ehexF d : subpred (equad d) (ehex (gface d)).
Proof.
by move=> p; rewrite !(inE, in_gchop_rect) halfg_face andbAC => /andP[].
Qed.

Lemma end0g_equad d : ~~ has (equad (gface d)) m -> m (end0g d) = false.
Proof.
move/hasPn/(_ _)/contraTF; apply; rewrite !(inE, in_gchop_rect) /gchop.
rewrite !halfg_face !oddg_face /end0g; case: (halfg d) => x y.
by case: oddgP; rewrite /= !lter_add2 /= ?ler_addl ?ger_addl.
Qed.

Lemma mring_equad d :
  ~~ has (equad (gface d)) m -> (end0g d \in map end0g (mring m)) = false.
Proof.
move=> m'fd; apply/mapP => -[d1 m_d1 Dp].
rewrite in_mring inE (contraTF (hasPn m'fd _)) {m'fd}// in m_d1.
rewrite !(inE, in_gchop_rect) /gchop !halfg_face !oddg_face /end0g.
rewrite -{Dp}(canLR (addrK _) Dp) -addrA; case: (halfg d) => x y.
by do 2!case: oddgP; rewrite /= !lter_add2 ?ger_addl ?ler_addl.
Qed.

Section Extend1.

Variable d : gpoint.

Definition ext1_hex := m (halfg (gedge d)) && ~~ has (ehex d) m.

Hypothesis ext1d : ext1_hex.

Let m'd : (halfg d \in m) = false.
Proof.
have [_] := andP ext1d; apply: contraNF => m_d; apply/hasP.
by exists (halfg d); rewrite // in_gchop_rect /= gtouch_refl gchop_halfg.
Qed.

Let rm_ed : gedge d \in mring m.
Proof. by rewrite in_mring inE gedge2 m'd andbT; case/andP: ext1d. Qed.

Let m'f3d : ~~ has (equad (iter 3 gface d)) m.
Proof.
have [_] := andP ext1d; apply: contra => /hasP[p m_p /ehexF].
by rewrite gface4 => d_p; apply/hasP; exists p.
Qed.

Let m'f4d : ~~ has (equad (iter 4 gface d)) m.
Proof.
have [_] := andP ext1d; apply: contra => /hasP[p m_p].
by rewrite /= gface4 in_gchop_rect => /andP[d_p _]; apply/hasP; exists p.
Qed.

Let ext1_loop := traject gface (gface d) 3.
Definition ext1_mring := let: RotToSpec _ r _ := rot_to rm_ed in ext1_loop ++ r.

Lemma ext1_mring_cycle : cycle mrlink ext1_mring.
Proof.
rewrite /ext1_mring; case: (rot_to _) => i r Dr.
have:= mring_cycle m; rewrite -(rot_cycle i) {i}Dr !(cycle_path d) /=.
rewrite /mrlink !end0g_face !eqxx /= end0g_edge.
by case: r => [|d1 r]; rewrite /= end1g_edge -!end0g_face gface4.
Qed.

Lemma ext1_mring_simple : uniq (map end0g ext1_mring).
Proof.
rewrite /ext1_mring; case: (rot_to _) => i r Dr.
case: (mring_equad m'f4d, mring_simple m); rewrite -(rot_uniq i) -(mem_rot i).
move: (mring_equad m'f3d); rewrite -[LHS](mem_rot i) -map_rot {i}Dr.
rewrite !map_cons !inE !end0g_edge -!end0g_face.
move: {r}(map _ r) (gface d) => r d1 /=; rewrite !inE ![_ == end0g d1]eq_sym.
move=> /norP[/negPf-> /negPf->] /norP[/negPf-> /negPf->] /andP[-> ->] /=.
by rewrite eq_sym end0g_face (inj_eq (addrI _)) neq_ccw.
Qed.

Let m'Eloop : all (fun f => halfg (gedge f) \notin m) ext1_loop.
Proof.
apply/allP=> _ /trajectP[i lti3 ->]; set p := halfg _.
have [_] := andP ext1d; apply/contra=> m_p; apply/hasP; exists p => {m_p}//.
rewrite in_gchop_rect /= /gchop {}/p -iterSr halfg_edge halfg_iter_face.
case: (halfg d) => x y; rewrite oddg_iter_face.
by case: oddgP i lti3 => -[|[|[]]] //=; rewrite ?lter_add2 ?ler_addl ?ger_addl.
Qed.

Lemma ext1_mring_def : ext1_mring =i gborder (ext_mdisk d).
Proof.
move=> p; rewrite /ext1_mring; case: (rot_to _) => i r Dr.
have [m'ef1d m'ef2d m'ef3d _] := and4P m'Eloop; rewrite !inE !(eq_sym p).
have [<- | p'f1d] := altP eqP.
  by rewrite halfg_face eqxx m'd /= eq_sym -halfg_face neq_halfg_edge.
have [<- | p'f2d] := altP eqP.
  by rewrite !halfg_face eqxx m'd /= eq_sym -2!halfg_face neq_halfg_edge.
have [<- | p'f3d] := altP eqP.
  by rewrite !halfg_face eqxx m'd /= eq_sym -3!halfg_face neq_halfg_edge.
rewrite /= negb_or andbCA andb_orl -[rhs in _ || rhs]in_mring orbC andbC.
have [mr_p | mr'p] /= := boolP (p \in mring m).
  have [/andP[r'ed _]]: uniq (gedge d :: r) /\ p \in gedge d :: r.
    by rewrite -Dr rot_uniq mem_rot (map_uniq (mring_simple m)).
  rewrite inE => /predU1P[->|r_p]; first by rewrite gedge2 eqxx (negPf r'ed).
  move: mr_p; rewrite in_mring => /andP[/contraTneq->//] /esym/same_halfg.
  by rewrite !inE !(inv_eq gedge2) -implyNb (memPn r'ed) //= => /or3P[]/eqP->.
apply/negb_inj; have /norP[_ ->]: p \notin gedge d :: r by rewrite -Dr mem_rot.
apply/esym/nandP; left; apply: contraL rm_ed => /andP[/eqP/esym/same_halfg].
rewrite !inE in_mring negb_and => /predU1P[-> -> //|/norP[]].
by rewrite !(eq_sym p) negb_or p'f2d.
Qed.

Definition ext1_matte :=
  Matte (ext_mdisk_ne d) ext1_mring_cycle ext1_mring_simple ext1_mring_def.

End Extend1.

Section Extend2.

Variable d : gpoint.

Definition ext2_quad :=
  [&& halfg (gedge d) \in m, halfg (gedge (gface d)) \in m
    & ~~ has (equad d) m].

Hypothesis ext2d : ext2_quad.

Let m'd : (halfg d \in m) = false.
Proof.
have [_ _] := and3P ext2d; apply: contraNF => m_d; apply/hasP.
exists (halfg d); rewrite // !(inE, in_gchop_rect) gtouch_refl.
by rewrite gchop_halfg -halfg_face gchop_halfg.
Qed.

Let m'f4d : ~~ has (equad (iter 4 gface d)) m.
Proof. by have [_ _] := and3P ext2d; rewrite /= gface4. Qed.

Let mr_efd : gedge (gface d) \in mring m.
Proof.
by rewrite in_mring inE gedge2 halfg_face m'd; have [_ ->] := and3P ext2d.
Qed.

Let mr_ed : gedge d \in mring m.
Proof. by rewrite in_mring inE gedge2 m'd; have [->] := andP ext2d. Qed.

Fact ext2_P : {ir | rot ir.1 (mring m) = [:: gedge (gface d), gedge d & ir.2]}.
Proof.
have [i [|d1 r] Dr] := rot_to mr_efd.
  have /idPn[] := mring_cycle m; rewrite -(rot_cycle i) Dr /= /mrlink.
  by rewrite (inj_eq (addrI _)) neq_ccw.
exists (i, r); rewrite Dr; congr [:: _, _ & _].
move: (mring_cycle m) mr_ed (mring_simple m).
rewrite -(rot_cycle i) -(mem_rot i) -(rot_uniq i) -map_rot Dr.
case/andP=> /eqP-Dd1 _; rewrite end1g_edge end0g_face -end0g_edge in Dd1.
rewrite -(mem_rot 1) -(rot_uniq 1) -map_rot rot1_cons /= inE.
by case/predU1P=> // r_ed; rewrite -Dd1 map_f.
Qed.

Let ext2_loop := traject gface (gface (gface d)) 2.
Definition ext2_mring := let: exist (_, r) _ := ext2_P in ext2_loop ++ r.

Lemma ext2_mring_cycle : cycle mrlink ext2_mring.
Proof.
rewrite /ext2_mring; case: ext2_P (mring_cycle m) => -[i r] /= Dr.
rewrite -(rot_cycle i) {i}Dr /= !rcons_path /= end1g_edge !end0g_edge.
rewrite !end0g_face !eqxx /= -[d in gedge d]gface4.
by case: r => [|d1 r] /=; rewrite end1g_edge end0g_face.
Qed.

Lemma ext2_mring_simple : uniq (map end0g ext2_mring).
Proof.
rewrite -(rot_uniq 1) /ext2_mring; case: ext2_P => -[i r] Dr; rewrite /= in Dr.
have:= mring_simple m; rewrite -(rot_uniq i) -(rot_uniq 1).
have:= mring_equad m'f4d; rewrite -(mem_rot i) -(mem_rot 1) -!map_rot {i}Dr.
rewrite !rot1_cons !map_rcons end0g_edge -end0g_face /= inE => /norP[_ ->].
by case/andP.
Qed.

Let m'Eloop : all (fun fd => halfg (gedge fd) \notin m) ext2_loop.
Proof.
apply/allP=> _ /trajectP[i lti2 ->]; rewrite -!iterSr.
have [_ _ /hasPn/(_ _)/contraL] := and3P ext2d; apply.
rewrite halfg_edge halfg_iter_face oddg_iter_face !(inE, in_gchop_rect).
rewrite /gchop halfg_face oddg_face; case: (halfg d) => x y.
by case: oddgP i lti2 => -[|[]] //= _; rewrite !lter_add2 ?ler_addl ?ger_addl.
Qed.

Lemma ext2_mring_def : ext2_mring =i gborder (ext_mdisk d).
Proof.
rewrite /ext2_mring; case: ext2_P => -[i r] /= Dr p; rewrite !inE.
have [m'ef2d m'ef3d _] := and3P m'Eloop.
have [-> | f2d'p] /= := altP eqP.
  by rewrite andbC eq_sym -2!halfg_face eqxx neq_halfg_edge andbT.
have [-> | f3d'p] /= := altP eqP.
  by rewrite andbC eq_sym -3!halfg_face eqxx neq_halfg_edge andbT.
rewrite negb_or andbCA andb_orl -[rhs in _ || rhs]in_mring orbC andbC.
have [mr_p | mr'p] /= := boolP (p \in mring m).
  apply/esym; apply/eqP/idP=> [|[/esym/same_halfg/(map_f gedge)Dp r_p]].
    have:= mr_p; rewrite -(mem_rot i) Dr !inE orbA.
    by case/orP; [case/pred2P=> ->; left; rewrite gedge2 ?halfg_face | right].
  have:= map_uniq (mring_simple m); rewrite -(rot_uniq i) Dr.
  rewrite (cat_uniq [:: _; _]) andbCA andbC => /andP[_] /hasPn/(_ p r_p).
  rewrite !inE orbC => p'efd; rewrite gedge2 !inE orbA (negPf p'efd) /= in Dp.
  by have:= mr_p; rewrite in_mring => /nandP[]; left; case/pred2P: Dp => ->.
have:= mr'p; rewrite -(mem_rot i) Dr !inE orbA => /norP[_ /negPf->].
apply/esym/nandP; left; apply: contraL mr_efd => /andP[/eqP/esym/same_halfg].
rewrite !inE (negPf f2d'p) (negPf f3d'p) !orbF in_mring negb_and gedge2.
by rewrite halfg_face m'd orbF => /pred2P[->|<-//]; have [->] := andP ext2d.
Qed.

Definition ext2_matte :=
  Matte (ext_mdisk_ne d) ext2_mring_cycle ext2_mring_simple ext2_mring_def.

End Extend2.

End ExtendMatte.

Section MatteExtension.

Variable m : matte.

Inductive matte_extension : matte -> Type :=
  | Mext_nil : matte_extension m
  | Mext_add d (xm0 xm : matte) of
      matte_extension xm0 & gedge d \in mring xm0 & xm =i ext_mdisk xm0 d :
    matte_extension xm.

Arguments Mext_add : clear implicits.

Lemma in_extension xm : matte_extension xm -> {subset m <= xm}.
Proof.
elim: xm / => [|d xm0 xm _ IHxm _ Dxm] p m_p //.
by rewrite Dxm mem_behead /= ?IHxm.
Qed.

Variant extends_in (r : grect) (p : gpoint) :=
  ExtendsIn xm of matte_extension xm & {subset xm <= predU r m} & p \in xm.

Lemma extends_in_sub (r1 r2 : grect) :
  subpred r1 r2 -> forall p, extends_in r1 p -> extends_in r2 p.
Proof.
move=> sr12 p [xm xmP sxmr xm_p]; exists xm => {p xm_p}// p /sxmr.
by rewrite !inE -(orb_idl (sr12 p)) orbAC => ->.
Qed.

Lemma coarse_extends_in (r : grect) :
  coarse_in r m -> has r m -> forall p, inset r p -> extends_in r p.
Proof.
move=> r0Emh m_r p r0p; set r0 := r in r0Emh r0p; pose m0 := predI r0 m.
have [r_m0 r0_r]: subpred m0 r /\ subpred r r0 by split=> [q /andP[]|].
have r_p: r p := insetW r0p; move: {2}_.+1 (ltnSn (garea r)) => n le_r_n.
elim: n => // n IHn in r (r0) p m0 le_r_n m_r r_p r_m0 r0_r r0p r0Emh *.
have [m_p | m'p] := boolP (p \in m).
  by exists m => // [|q m_q]; [left | apply/orP; right].
have ext_hex d (ed := gedge d) :
    halfg d = p -> ~~ has (ehex d) m ->
  extends_in (gchop_rect r ed) (halfg ed) -> extends_in r p.
- move=> Dp d'm [xm xmP rm_xm xm_ed].
  have ext1d: ext1_hex xm d.
    rewrite /ext1_hex !inE xm_ed; apply/hasPn=> q /rm_xm/orP[|/(hasPn d'm)//].
    by rewrite !in_gchop_rect /= gchop_edge negb_and orbC => /andP[_ ->].
  do [exists (ext1_matte ext1d); rewrite ?inE ?Dp ?eqxx //] => [|q].
    right with d xm; rewrite // in_mring inE gedge2 Dp xm_ed.
    apply/(contra (rm_xm p)); rewrite inE in_gchop_rect /= gchop_edge.
    by rewrite -Dp gchop_halfg andbF Dp.
  rewrite !inE => /predU1P[->|/rm_xm]; first by rewrite Dp r_p.
  by rewrite inE in_gchop_rect orb_andl => /andP[].
have{IHn} IHp d: halfg d = p -> has (predD r0 (gchop1 d)) m -> extends_in r p.
  move=> Dp m_r0d; pose r01 := gchop1_rect r0 d.
  have r01p: inset r01 p.
    apply/insetP=> q p1q; rewrite in_gchop1_rect /= (insetP r0p) //=.
    by have:= p1q; rewrite -Dp gtouch_chop1 => /andP[].
  have [m_r01 | r01'm] := boolP (has r01 m).
    pose r1 := gchop1_rect r d; have r_r1: subpred r1 r := @gchop_rect_sub r _.
    apply/(extends_in_sub r_r1)/(IHn r1 r01)=> //.
    - have [q m_q /andP[d'q r0q]] := hasP m_r0d.
      apply: leq_trans (n) _ le_r_n; apply: (@ltn_garea_subrect q) => //=.
      by rewrite in_gchop1_rect /= r_m0 ?d'q //= r0q.
    - have [q m_q] := hasP m_r01; rewrite in_gchop1_rect => /andP[r0q d_q].
      by apply/hasP; exists q; rewrite // in_gchop1_rect /= r_m0 //= r0q.
    - by rewrite in_gchop1_rect /= r_p -Dp gchop_chop1 ?gchop_halfg.
    - by move=> q; rewrite !(inE, in_gchop1_rect) andbAC => /andP[/r_m0->].
    - by move=> q; rewrite !in_gchop1_rect /= => /andP[/r0_r->].
    by move=> q1 q2 /gchop_rect_sub; apply: r0Emh.
  apply: ext_hex (Dp) (contra _ r01'm) _.
    by apply/sub_has=> q; rewrite in_gchop_rect Dp => /andP[/(insetP r01p)].
  set r1 := gchop_rect r _; have r_r1: subpred r1 r := @gchop_rect_sub r _.
  have m_r1: has r1 m.
    have [q m_q /andP[d'q r0q]] := hasP m_r0d.
    apply/hasP; exists q; rewrite ?in_gchop_rect //= r_m0 /= ?r0q //.
    by rewrite gchop_edge (contra _ d'q) => // /gchop_chop1.
  apply (IHn _ r0) => //; last 2 [by move=> q /r_r1/r0_r].
  - apply: leq_trans (n) _ le_r_n; apply: (@ltn_garea_subrect p) => //=.
    by rewrite in_gchop_rect /= r_p gchop_edge -Dp gchop_halfg.
  - by have [q _] := hasP m_r1; apply: gchop_rect_edge; rewrite gedge2 Dp.
  - move=> q m0q; rewrite in_gchop_rect /= r_m0 // gchop_edge.
    case/andP: m0q => r0q /(hasPn r01'm); apply: contra => d_q.
    by rewrite in_gchop1_rect /= r0q gchop_chop1.
  set ed := gedge d; case Ded: (halfg ed) => [x y].
  case Dr0: r0 => [x0 x1 y0 y1] /=; rewrite -!ler_subr_addr !ltr_subr_addr.
  have r0efd i: r0 (halfg (gedge (iter i gface (gedge ed)))).
    by rewrite (insetP r0p) // -Dp -(halfg_iter_face i) gedge2 gtouch_edge.
  have /= (d2 := gedge (gface (gface ed))): gchop_rect r0 d2 (halfg d2).
    have [q m_q /andP[d'q r0q]] := hasP m_r0d; apply: gchop_rect_edge (q) _.
      by rewrite gedge2 (insetP r0p) // !halfg_face -Dp gtouch_edge.
    by rewrite in_gchop_rect /= r0q gchop_edge.
  rewrite in_gchop_rect /= gchop_halfg andbT; have [] := (r0efd 1, r0efd 3)%N.
  rewrite !(Ded, halfg_edge, halfg_face, oddg_edge, oddg_face) -!addrA Dr0.
  by case: oddgP; do ![case/andP | move-> | clear 1].
(* nd q is the dart of q whose edge separates q from gnode q *)
pose nd (q : gpoint) : gpoint := q *+ 2 + iter 3 ccw (oddg q).
have h_nd q: halfg (nd q) = q by rewrite halfg_eq //= !ccw_odd.
have o_nd q: oddg (nd q) = ccw (ccw (ccw (oddg q))).
  by rewrite oddg_eq //= !ccw_odd.
have hEnd q: halfg (gedge (nd q)) = gnode q.
  by rewrite halfg_edge h_nd o_nd ccw4.
have ndN q: nd (gnode q) = gedge (gnode (gedge (nd q))).
  rewrite -[gedge (nd q)]halfgK hEnd -[gnode q in RHS]h_nd.
  by rewrite oddg_edge o_nd -oddg_node -o_nd -gface_def gfaceK.
have ndFE q: nd (gface (gedge q)) = gedge (gface (nd q)).
  by rewrite -[q in RHS]gedgeK ndN gnodeK gedge2.
have m_nd4 q: r0 q -> has (equad (nd q)) m -> q \in m.
  move=> r0q /hasP[q1 m_q1 q4q1]; rewrite -[_ \in m](r0Emh _ q1) {m_q1}//.
  apply/esym/eqP; rewrite -[_ == _]/(_ && _) !eq_le -andbA; apply/and4P.
  move: q4q1; rewrite !(inE, in_gchop_rect) /gchop halfg_face -[halfg _]halfgK.
  rewrite h_nd oddg_face o_nd ccw4; case: (halfg q) q1 => x y [x1 y1] /=.
  rewrite -!(ltz_addr1 (_ %/ _)%Z) !ltz_divLR ?lez_divRL // !mulrDl !mulz2.
  by case: oddgP; rewrite /= ?addr0 ?addrK !(addrA _ 1 1) !ltz_addr1;
     do ![case/andP | move-> | clear 1].
have gchop1F3E d: gchop1 (iter 3 gface (gedge d)) = gchop1 (gface d).
  by rewrite -gchop1_shift gface4 gedge2.
have ehex_shift_quad q q' (efq := gedge (gface q)):
  ehex q q' || ehex (gface efq) q' ==> equad q q' || equad efq q'.
- have chop1idl q1 q2 b: gchop1 q1 q2 && b && gchop q1 q2 = gchop q1 q2 && b.
    by rewrite andbAC (andb_idl (@gchop_chop1 _ _)).
  rewrite !(inE, in_gchop_rect) !gtouch_chop1 /= !andbT gface4 !chop1idl.
  do 2!rewrite [in _ && _ && _]andbCA chop1idl; rewrite gchop_shift gchop1F3E.
  case: (gchop q _); rewrite //= orbC andbC andbCA; case: (gchop1 _ _) => //=.
  rewrite andbT gchop_edge -[gface q as fq in gface (gface fq)]gedge2.
  by case: (gchop _ _); rewrite ?orbF; case: orP => //= -[]/andP[/gchop_chop1].
have r0_np: r0 (gnode p).
  by rewrite (insetP r0p) // -hEnd -[p in gtouch p]h_nd gtouch_edge.
have r0_fep: r0 (gface (gedge p)).
  rewrite -[gface _]h_nd -[nd _]gedge2 (insetP r0p) //.
  by rewrite -[p in gtouch p]gedgeK -hEnd gtouch_edge.
have p4'm: ~~ has (equad (nd p)) m by apply/(contra _ m'p)/m_nd4/r0_r.
have [m_p6 | p6'm] := boolP (has (ehex (nd p)) m).
  have{m_p6} m_efp: halfg (gedge (gface (nd p))) \in m.
    have [q m_q p6_q] := hasP m_p6; apply/m_nd4/hasP; rewrite -ndFE h_nd //.
    have:= ehex_shift_quad (nd p) q; rewrite p6_q /= ndFE.
    by rewrite (negPf (hasPn p4'm q m_q)); exists q.
  have [m_fp6 | /ext_hex] := boolP (has (ehex (gface (nd p))) m); last first.
    rewrite halfg_face; apply=> //.
    by exists m => // [|q m_q]; [left | apply/orP; right].
  have m_ep: halfg (gedge (nd p)) \in m.
    have [q m_q p6_q] := hasP m_fp6; apply/m_nd4/hasP; rewrite hEnd //.
    have:= ehex_shift_quad (nd (gnode p)) q; rewrite -ndFE gnodeK /= p6_q orbT.
    by rewrite (negPf (hasPn p4'm q m_q)) orbF; exists q.
  have ext2p: ext2_quad m (nd p) by apply/and3P.
  exists (ext2_matte ext2p); last by rewrite inE h_nd eqxx.
    right with (nd p) m => //; first by left.
    by rewrite in_mring inE gedge2 h_nd m_ep.
  by move=> q /predU1P[->|m_q]; [rewrite h_nd inE r_p | apply/orP; right].
have [m_p | {}m'p] := boolP (has (gtouch p) m); last first.
  suffices: has [pred q | has (predD r0 (gchop1 q)) m] (traject gface (nd p) 4).
    case/hasP/sig2W=> _ /trajectP/sig2_eqW[i _ ->].
    by apply: IHp; rewrite halfg_iter_face.
  have [q m_q r_q] := hasP m_r; apply: contraR m'p; rewrite -all_predC => m'p.
  apply/hasP; exists q => //; rewrite -[p]h_nd gtouch_chop1.
  by apply: sub_all m'p => ? /hasPn/(_ q m_q); rewrite negb_and negbK orbC r0_r.
apply: ext_hex (h_nd p) (p6'm) _.
have [m_nd | m'nd] := boolP (gnode p \in m).
  by exists m => [|q m_q|]; [left | rewrite !inE m_q orbT | rewrite hEnd].
have nd4'm: ~~ has (equad (nd (gnode p))) m by apply: contra m'nd => /m_nd4->.
have r0_n2p: r0 (gnode (gnode p)).
  rewrite -[gnode _]addrA oddg_node (insetP r0p) //.
  by case: oddgP; case: (p) => x y; rewrite /= !lter_add2.
have m_n2p: gnode (gnode p) \in m.
  have [q m_q p9q] := hasP m_p; apply/m_nd4/hasP=> //; exists q => //.
  have ep_q: gchop (gedge (nd p)) q.
    rewrite gchop_edge; apply: contra p6'm => p_q.
    by apply/hasP; exists q; rewrite // in_gchop_rect /= h_nd p9q.
  have /implyP := ehex_shift_quad (nd (gnode (gnode p))) q.
  rewrite ndN gnodeK gedge2 (negPf (hasPn nd4'm q m_q)) orbF => -> //.
  apply/orP; right; rewrite in_gchop_rect /= ndN gnodeK ep_q gtouch_chop1 /=.
  rewrite gchop1F3E gchop_chop1 //= -gchop1F3E gedge2 !andbT andbC.
  by rewrite -[p]h_nd gtouch_chop1 in p9q; case/and5P: p9q => /gchop_chop1-> ->.
have r_np: r (gnode p).
  have: r (gnode (gnode p)) by rewrite r_m0 //= r0_n2p.
  rewrite /gnode oddg_node -addrA; case: (p) (r) r_p => x y [x0 x1 y0 y1].
  by case: oddgP; rewrite /= !addr0; do ![case/andP | move-> | clear 1].
have ext1nd: ext1_hex m (nd (gnode p)).
  rewrite /ext1_hex !inE hEnd m_n2p; apply/hasP => -[q m_q nd4q].
  have := ehex_shift_quad (nd (gnode p)) q; rewrite -ndFE gnodeK nd4q /=.
  by case/norP; rewrite (hasPn nd4'm) ?(hasPn p4'm).
exists (ext1_matte ext1nd) => [|q|]; last by rewrite inE h_nd hEnd eqxx.
  right with (nd (gnode p)) m => //; first by left.
  by rewrite in_mring inE hEnd m_n2p gedge2 h_nd m'nd.
rewrite !inE => /predU1P[] ->; last by rewrite orbT.
by rewrite h_nd in_gchop_rect /= r_np -hEnd gchop_halfg.
Qed.

(* We will use refined_extends_in to show directly that the union of set of   *)
(* extensions of a mattte included in a region is closed (relatively to the   *)
(* region). To show that this union is open we will need the MatteOrder       *)
(* lemmas below. We use the refined_extend_meet lemma to extend the mattes of *)
(* adjacent regions so that their contours have a common edge.                *)

Lemma extend_madj (m1 : matte) (r : grect) :
    coarse_in r m -> has r m -> has (inset r) m1 -> ~~ has m m1 ->
  let m2 := [predD predU r m & m1] in
  {xm : matte | {subset m <= xm} /\ {subset xm <= m2} & madj m1 xm}.
Proof.
rewrite (has_sym m) => rEmh r_m /hasP/sig2W[p m1_p r_p] /negP-m1'm m2.
have{rEmh r_m r_p} [xm xmP sxmr xm_p] := coarse_extends_in rEmh r_m r_p.
have{p m1_p xm_p} m1_xm: has m1 xm by apply/hasP; exists p.
elim: {xm}xmP => {m1'm}// p xm0 xm xm0P IHxm xm0ep Dxm in sxmr m1_xm.
have sxm0r: {subset xm0 <= predU r m}.
  by move=> q xm0q; rewrite sxmr // !inE Dxm inE xm0q orbT.
have [m1_xm0 | m1'xm0] := boolP (has m1 xm0); first exact: IHxm.
exists xm0; first do [split; first exact: in_extension].
  by move=> q xm1q; rewrite inE (hasPn m1'xm0) //= sxm0r.
apply/hasP; exists (gedge p); rewrite //= gedge2 in_mring inE.
rewrite andbC (hasPn m1'xm0); last by move: xm0ep; rewrite in_mring => /andP[].
by have [q] := hasP m1_xm; rewrite Dxm => /predU1P[-> | /(hasPn m1'xm0)/negP].
Qed.

End MatteExtension.

Section MatteOrder.

Implicit Types m xm : matte.

Definition mcorner m q : nat :=
  let m'q i := q - iter i ccw 0 \notin m in (m'q 2 + (m'q 1 + m'q 3).*2)%N.

Lemma mcorner0 m q : q \in m -> mcorner m q = 0%N -> subpred (ltouch q) m.
Proof.
have negb_Ngt0 b: ~~ (~~ b > 0)%N = b by case: b.
move=> mq /eqP; rewrite eqn0Ngt !(addn_gt0, double_gt0) !negb_or !{}negb_Ngt0.
case: q => x y in mq *; rewrite /+%R /= !subr0 => /and3P[mq11 mq01 mq10] p.
by rewrite -mem_enum_grect /= !zspan_dec_inc; apply/allP/and5P.
Qed.

Lemma refine_mcorner m r q (p := halfg q):
   p \in m -> inset r p -> (0 < mcorner m p)%N ->
   let ext_m_r xm := {subset [preim halfg of m] <= xm}
                  /\ {subset xm <= [preim halfg of predU r m]} in
  {xm | ext_m_r xm & mcorner xm q < mcorner m p}%N.
Proof.
move=> m_p r_p mp_gt0 ext_m_r; pose m_pc c := p + halfg (- c + oddg q) \in m.
pose xmE xm c0 c := (q - c \notin xm) = ~~ [|| c == c0, m_pc c | q - c \in xm].
have ext_along d: {xm : matte | ext_m_r xm & forall c, xmE xm (oddg d) c}.
  pose xr := refine_rect r; pose xm := refine_matte m.
  have xrExmh: coarse_in xr xm by apply: refine_matte_coarse.
  have xr_xm: has xr xm.
    by apply/hasP; exists q; rewrite ?in_refine_matte ?in_refine_rect 1?insetW.
  have xr_qd: inset xr (q - oddg d).
    rewrite -in_refine_rect refine_inset in r_p; apply/(insetP r_p).
    by case: oddgP (q) => -[x y] /=; rewrite !lter_add2.
  have[xm1 xm1P xrm_xm1 xm1c1] := coarse_extends_in xrExmh xr_xm xr_qd.
  exists xm1 => [|c].
    split=> p1 xm1p1; first by rewrite (in_extension xm1P) ?in_refine_matte.
    by rewrite !inE -in_refine_rect -in_refine_matte [_ || _]xrm_xm1.
  rewrite /xmE orbA orb_idl // => /predU1P[->|] //.
  by rewrite /m_pc -halfg_add -in_refine_matte => /in_extension->.
have [oq0 | o_q] := eqVneq (oddg q) 0; last first.
  have [xm mr_xm Dxm] := ext_along (ccw (ccw (oddg q))); exists xm => {mr_xm}//.
  rewrite /mcorner !{}Dxm /m_pc; rewrite -[p]addr0 in m_p.
  by case: oddgP o_q; rewrite ?m_p //=; have [[->]|] := norP; rewrite ?addnS.
have{mp_gt0} [d o_d /negPf-m'pd]: {d | oddg d != 0 & p - oddg d \notin m}.
  have:= mp_gt0; rewrite /mcorner.
  by do ![set d := (d in p - d); case m'd: (~~ _); [by exists d | clear d m'd]].
have [xm mr_xm Dxm] := ext_along d; exists xm => {mr_xm}//.
rewrite /mcorner !inE !{}Dxm /m_pc oq0.
by case: oddgP o_d m'pd => //= _ ->; do !have [[->]|] := norP; rewrite ?addnS.
Qed.

End MatteOrder.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal83.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_2  := ( Cons (Succ Zero) (Cons Zero (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_3  := ( Cons (Succ (Succ (Succ Zero)))         (Cons Zero            (Cons Zero               (Cons Zero                  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) Nil)))))).
Definition lfind_example_4  := ( Cons Zero Nil).
Definition lfind_example_5  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_6  := ( Cons Zero         (Cons (Succ Zero)            (Cons (Succ Zero)               (Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons Zero Nil)))))).
Definition lfind_example_7  := ( Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_8  := ( Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_9  := ( Cons Zero Nil).
Definition lfind_example_10  := ( Cons (Succ (Succ (Succ (Succ (Succ Zero))))) (Cons Zero Nil)).
Definition lfind_example_11  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_12  := ( Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_13  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_14  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_15  := ( Cons (Succ Zero) Nil).
Definition lfind_example_16  := ( Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_17  := ( Cons (Succ (Succ Zero))         (Cons (Succ Zero) (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))))).
Definition lfind_example_18  := ( Cons Zero Nil).
Definition lfind_example_19  := ( Cons (Succ (Succ Zero)) (Cons (Succ (Succ (Succ (Succ Zero)))) Nil)).
Definition lfind_example_20  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_21  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_22  := ( Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_23  := ( Cons (Succ Zero) Nil).
Definition lfind_example_24  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_25  := ( Cons Zero Nil).
Definition lfind_example_26  := ( Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil)).
Definition lfind_example_27  := ( Cons Zero Nil).
Definition lfind_example_28  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal83_theorem0_50_append_assoc/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 .


Inductive BT (A : Type) : Type :=
| Empty    : BT A
| NonEmpty : NonEmptyBT A -> BT A

with NonEmptyBT (A : Type) : Type :=
| Nnode    : A -> BT A -> BT A -> NonEmptyBT A.

Arguments Empty    {A}.
Arguments NonEmpty {A} _.
Arguments Nnode    {A} _ _ _.

(** Niczym się to nie różni od zwykłych drzew. *)

From Typonomikon Require Import BT.

Fixpoint f {A : Type} (t : BT A) : BTree A :=
match t with
| Empty       => E
| NonEmpty t' => f' t'
end

with f' {A : Type} (t : NonEmptyBT A) : BTree A :=
match t with
| Nnode x l r => N x (f l) (f r)
end.

Fixpoint g {A : Type} (t : BTree A) : BT A :=
match t with
| E       => Empty
| N x l r => NonEmpty (Nnode x (g l) (g r))
end.

Lemma fg :
  forall {A : Type} (t : BT A),
    g (f t) = t.
Proof.
  fix IH 2.
  destruct t as [| [x l r]]; cbn.
    reflexivity.
     rewrite !IH. reflexivity.
Qed.

Lemma gf :
  forall {A : Type} (t : BTree A),
    f (g t) = t.
Proof.
  induction t as [| x l IHl r IHr]; cbn.
    reflexivity.
    rewrite IHl, IHr. reflexivity.
Qed.


Require Import String.
Require Import Coq.Structures.Equalities.
Require Import Coq.MSets.MSetInterface.
Require Import Arith.
Require Import Setoid.
Require Import SystemF.
Require Import Coq.Program.Equality.
Require Export Subtyping.

Module MDisjointness
       (Import VarTyp : UsualDecidableTypeFull)
       (Import set : MSetInterface.S).

Module MSubtyping := MSubtyping(VarTyp)(set).
Export MSubtyping.

(* Disjointness: Implementation *)

Definition hd (p : PTyp) : nat :=
  match p with
  | PInt       => 0
  | Fun t1 t2  => 1
  | ForAll d t => 2
  | Top        => 3
  | PBVarT n   => 4
  | PFVarT v   => 5
  | And t1 t2  => 6
  end.

Definition OrthoAx (t1 t2 : PTyp) : Prop :=
  (hd t1 < 3 /\ hd t2 < 3 /\ not (hd t1 = hd t2)).

Inductive Ortho : context TyEnvSource -> PTyp -> PTyp -> Prop :=
  | OAnd1 : forall Gamma t1 t2 t3, Ortho Gamma t1 t3 -> Ortho Gamma t2 t3 -> Ortho Gamma (And t1 t2) t3
  | OAnd2 : forall Gamma t1 t2 t3, Ortho Gamma t1 t2 -> Ortho Gamma t1 t3 -> Ortho Gamma t1 (And t2 t3)
  | OFun  : forall Gamma t1 t2 t3 t4, Ortho Gamma t2 t4 -> Ortho Gamma (Fun t1 t2) (Fun t3 t4)
  | OForAll : forall L Gamma d t1 t2,
                (forall x, not (In x L) -> Ortho (extend x (TyDis d) Gamma)
                                           (open_typ_source t1 (PFVarT x))
                                           (open_typ_source t2 (PFVarT x))) ->
                Ortho Gamma (ForAll d t1) (ForAll d t2)
  | OVar : forall Gamma x ty A, List.In (x,TyDis A) Gamma ->
                       usub A ty ->
                       PType ty ->
                       Ortho Gamma (PFVarT x) ty
  | OVarSym : forall Gamma x ty A, List.In (x,TyDis A) Gamma ->
                          usub A ty ->
                          PType ty ->
                          Ortho Gamma ty (PFVarT x)
  | OTop1 : forall Gamma t, Ortho Gamma Top t
  | OTop2 : forall Gamma t, Ortho Gamma t Top
  | OAx : forall Gamma t1 t2, OrthoAx t1 t2 -> Ortho Gamma t1 t2.

Hint Constructors Ortho.

(* Disjointness: Specification *)

Definition OrthoS (A B : PTyp) := not (exists C, Sub A C /\ Sub B C).

Ltac orthoax_inv H :=
  let H' := fresh in
  let m := fresh in
  let H1 := fresh in
  let H2 := fresh in
  inversion H as [H' | m H1 H2 ]; orthoax_inv H1.

(* Solving goals by inversion, with the form OrthoAx t1 t2,
   where t1 is not part of OrthoAx *)
Ltac orthoax_inv_l :=
  match goal with
    | H: OrthoAx _ _ |- _ => let H1 := fresh in
                           destruct H as [H1 _]; orthoax_inv H1
  end.

(* Solving goals by inversion, with the form OrthoAx t1 t2,
   where t2 is not part of OrthoAx *)
Ltac orthoax_inv_r :=
  match goal with
    | H: OrthoAx _ _ |- _ => let H1 := fresh in
                           destruct H as [_ [H1 _]]; orthoax_inv H1
  end.

(** Ortho environment properties **)

Lemma ortho_weaken :
  forall G E F t1 t2, Ortho (E ++ G) t1 t2 ->
                 Ortho (E ++ F ++ G) t1 t2.
Proof.
  intros.
  remember (E ++ G) as H'.
  generalize dependent HeqH'.
  generalize dependent E.
  dependent induction H; intros; eauto; subst.
  - apply_fresh OForAll as x.
    unfold open in *; simpl in *.
    subst.
    unfold extend; simpl.
    rewrite app_comm_cons.
    apply H0.
    not_in_L x.
    rewrite <- app_comm_cons.
    unfold extend; simpl; reflexivity.
  - apply OVar with (A := A); auto.
    apply in_app_or in H; inversion H; apply in_or_app; auto.
    right; apply in_or_app; auto.
  - apply OVarSym with (A := A); auto.
    apply in_app_or in H; inversion H; apply in_or_app; auto.
    right; apply in_or_app; auto.
Qed.

Lemma ortho_strengthen : forall z U E F ty1 ty2,
  not (In z (union (fv_ptyp ty1) (fv_ptyp ty2))) ->
  Ortho (E ++ ((z,U) :: nil) ++ F) ty1 ty2 ->
  Ortho (E ++ F) ty1 ty2.
Proof.
  intros.
  remember (E ++ ((z,U) :: nil) ++ F).

  generalize dependent Heql.
  generalize dependent E.

  induction H0; intros; auto.
  - apply OAnd1; [ apply IHOrtho1 | apply IHOrtho2 ];
    simpl in H; not_in_L z; apply Heql.
  - apply OAnd2; [ apply IHOrtho1 | apply IHOrtho2 ];
    simpl in H; not_in_L z; apply Heql.
  - apply OFun;
    apply IHOrtho; simpl in H; not_in_L z; auto.
  - apply_fresh OForAll as x.
    subst; unfold extend; simpl.
    rewrite app_comm_cons.
    eapply H1.
    not_in_L x.
    unfold not; intro HH.
    apply MSetProperties.Dec.F.union_1 in HH.
    destruct HH as [HH | HH]; apply fv_open_rec_typ_source in HH.
    apply MSetProperties.Dec.F.union_1 in HH; simpl in HH; simpl in H.
    destruct HH as [HH | HH].
    apply H.
    apply MSetProperties.Dec.F.union_2.
    apply MSetProperties.Dec.F.union_3.
    assumption.
    not_in_L x.
    apply H14.
    not_in_L z.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in HH.
    now symmetry.
    apply MSetProperties.Dec.F.union_1 in HH; simpl in HH; simpl in H.
    destruct HH as [HH | HH].
    apply H.
    apply MSetProperties.Dec.F.union_3.
    apply MSetProperties.Dec.F.union_3.
    assumption.
    not_in_L x.
    apply H14.
    not_in_L z.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in HH.
    now symmetry.
    unfold extend; now simpl.
  - subst.
    apply OVar with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H0; destruct H0; auto.
    destruct H0; auto.
    inversion H0; subst; simpl in H.
    not_in_L x.
    exfalso; apply H3.
    now apply MSetProperties.Dec.F.singleton_2.
  - subst.
    apply OVarSym with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H0; destruct H0; auto.
    destruct H0; auto.
    inversion H0; subst; simpl in H.
    not_in_L x.
    exfalso; apply H4.
    now apply MSetProperties.Dec.F.singleton_2.
Qed.

Hint Resolve ortho_weaken ortho_strengthen.

Lemma ortho_extend_comm :
  forall F E x v ty1 ty2,
    Ortho (F ++ E ++ (x, v) :: nil) ty1 ty2 ->
    Ortho (F ++ (x, v) :: nil ++ E) ty1 ty2.
Proof.
  intros F E x v ty1 ty2 HOrtho.
  remember (F ++ E ++ (x, v) :: nil).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  dependent induction HOrtho; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl.
    change ((y, TyDis d) :: F ++ (x, v) :: E) with
           (((y, TyDis d) :: F) ++ ((x, v) :: nil) ++ E).
    apply H0.
    not_in_L y.
    unfold extend; now simpl.
  - apply OVar with (A := A); auto.
    apply in_or_app; rewrite app_comm_cons.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
  - apply OVarSym with (A := A); auto.
    apply in_or_app; rewrite app_comm_cons.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
Qed.

Lemma ortho_extend_comm' :
  forall F E x v ty1 ty2,
    Ortho (F ++ (x, v) :: nil ++ E) ty1 ty2 ->
    Ortho (F ++ E ++ (x, v) :: nil) ty1 ty2.
Proof.
  intros F E x v ty1 ty2 HOrtho.
  remember (F ++ (x, v) :: nil ++ E).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  dependent induction HOrtho; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl.
    change ((y, TyDis d) :: F ++ E ++ (x, v) :: nil) with
           (((y, TyDis d) :: F) ++ E ++ (x, v) :: nil).
    apply H0.
    not_in_L y.
    unfold extend; now simpl.
  - apply OVar with (A := A); auto.
    rewrite app_comm_cons in H.
    apply in_or_app.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
  - apply OVarSym with (A := A); auto.
    rewrite app_comm_cons in H.
    apply in_or_app.
    repeat (apply in_app_or in H; destruct H as [H | H]).
    auto.
    right; apply in_or_app; auto.
    right; apply in_or_app; auto.
Qed.

Lemma ortho_app_comm :
  forall E F ty1 ty2, Ortho (F ++ E) ty1 ty2 -> Ortho (E ++ F) ty1 ty2.
Proof.
  intros E F ty1 ty2 HOrtho.
  remember (F ++ E).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  dependent induction HOrtho; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl.
    assert (Ha : not (In x L)) by not_in_L x.
    apply H0 with (F0 := extend x (TyDis d) F) (E0 := E) in Ha.
    apply ortho_extend_comm' in Ha.
    change ((x, TyDis d) :: E ++ F) with (nil ++ (x, TyDis d) :: E ++ F).
    apply ortho_extend_comm with (E := E ++ F).
    simpl in *.
    rewrite <- app_assoc.
    apply Ha.
    unfold extend; now simpl.
  - apply OVar with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H; destruct H; auto.
  - apply OVarSym with (A := A); auto.
    apply in_or_app.
    apply in_app_or in H; destruct H; auto.
Qed.

Lemma ortho_middle_comm : forall H E F G ty1 ty2,
              Ortho (E ++ F ++ G ++ H) ty1 ty2 ->
              Ortho (E ++ G ++ F ++ H) ty1 ty2.
Proof.
  induction H; intros.
  - rewrite app_nil_r in *.
    rewrite app_assoc.
    apply ortho_app_comm.
    generalize dependent E.
    generalize dependent F.
    induction G; intros.
    + intros; rewrite app_nil_r in *; now apply ortho_app_comm.
    + intros.
      change (F ++ E ++ a :: G) with (F ++ E ++ (a :: nil) ++ G).
      destruct a.
      assert ((F ++ E ++ ((v, t0) :: nil) ++ G) = (F ++ (E ++ ((v, t0) :: nil)) ++ G))
             by now rewrite <- app_assoc.
      rewrite H0; clear H0.
      apply IHG.
      rewrite <- app_assoc.
      apply ortho_extend_comm.
      change (E ++ F ++ (v, t0) :: G) with (E ++ F ++ ((v, t0) :: nil) ++ G) in H.
      rewrite app_assoc in H.
      apply ortho_extend_comm' in H.
      now rewrite <- app_assoc in *.
  - change (E ++ G ++ F ++ a :: H) with (E ++ G ++ F ++ (a :: nil) ++ H).
    destruct a.
    assert ((E ++ G ++ F ++ ((v, t0) :: nil) ++ H) =
            (E ++ G ++ (F ++ ((v, t0) :: nil)) ++ H)) by
    now rewrite <- app_assoc.
    rewrite H1; clear H1.
    apply IHlist.
    rewrite <- app_assoc.
    rewrite app_assoc.
    apply ortho_extend_comm.
    rewrite <- app_assoc.
    rewrite <- app_assoc.
    rewrite app_assoc in H0.
    rewrite app_assoc in H0.
    change (((E ++ F) ++ G) ++ (v, t0) :: H) with
           (((E ++ F) ++ G) ++ ((v, t0) :: nil) ++ H).
    apply ortho_extend_comm' in H0.
    repeat rewrite <- app_assoc in H0.
    apply H0.
Qed.

Hint Resolve in_or_app.
Hint Resolve in_app_or.

Lemma ortho_env_comm :
  forall E F G H ty1 ty2, Ortho (E ++ F ++ G ++ H) ty1 ty2 ->
                     Ortho (E ++ G ++ F ++ H) ty1 ty2.
Proof.
  intros.
  remember (E ++ F ++ G ++ H).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  generalize dependent G.
  dependent induction H0; intros; subst; auto.
  - apply_fresh OForAll as x.
    unfold extend; simpl; rewrite app_comm_cons; apply H1.
    not_in_L x.
    reflexivity.
  - apply OVar with (A := A); auto.
    repeat (apply in_app_or in H0; destruct H0); auto 10.
  - apply OVarSym with (A := A); auto.
    repeat (apply in_app_or in H0; destruct H0); auto 10.
Qed.

Lemma Ortho_sym : forall Gamma t1 t2, Ortho Gamma t1 t2 -> Ortho Gamma t2 t1.
Proof.
  intros Gamma t1 t2 HOrtho.
  induction HOrtho; eauto.
  apply OAx; auto.
  destruct H as [H1 [H2 H3]].
  unfold OrthoAx; auto.
Qed.

Lemma Ortho_usub_trans :
  forall Gamma u ty d,
    PType ty ->
    Ortho Gamma u d ->
    usub d ty ->
    Ortho Gamma u ty.
Proof.
  intros Gamma u ty d HWFty HOrtho HSub.
  generalize dependent ty.
  induction HOrtho; intros; eauto.
  - induction ty; try now (inversion HSub; subst; auto);
    inversion HWFty; inversion HSub; subst; auto.
  - induction ty; try now (inversion HSub; subst; auto);
    inversion HWFty; inversion HSub; subst; auto.
  - induction ty; try now (inversion HSub; subst; auto);
    inversion HWFty; inversion HSub; subst; auto.
    inversion HWFty; subst.
    inversion HSub; subst.
    apply_fresh OForAll as x.
    apply H0.
    not_in_L x.
    apply H4.
    not_in_L x.
    apply H6.
    not_in_L x.
  - pose (usub_trans _ _ _ HWFty H0 HSub).
    apply OVar with (A := A) ; auto.
  - induction ty0; try (now inversion HSub).
    inversion HSub; subst; inversion HWFty; auto.
    inversion HSub; subst; eauto.
  - dependent induction HSub.
    inversion HWFty.
    apply OAnd2; auto.
    auto.
  - destruct t1; destruct t2;
    try (destruct H0 as [_ [_ H0]]; exfalso; now apply H0);
    try (now orthoax_inv_r H0); try (now orthoax_inv_l H0);
    try now (induction ty; inversion HSub; subst; inversion HWFty; auto).
Qed.

(* Properties concerning substitution and sub/ortho/wf *)

Lemma ortho_subst_not_in :
  forall Gamma z u t1 t2,
    not (In z (union (fv_ptyp t1) (fv_ptyp t2))) ->
    PType u ->
    Ortho Gamma t1 t2 ->
    Ortho (subst_env Gamma z u) t1 t2.
Proof.
  intros Gamma z u t1 t2 HNotIn HWFu HOrtho.
  generalize dependent z.
  induction HOrtho; intros z HNotIn; simpl in HNotIn; auto.
  - apply OAnd1; [ apply IHHOrtho1 | apply IHHOrtho2 ]; auto; not_in_L z;
    now inversion HWFt1.
  - apply OAnd2; [ apply IHHOrtho1 | apply IHHOrtho2 ]; auto; not_in_L z;
    now inversion HWFt2.
  - apply OFun; apply IHHOrtho; auto; not_in_L z.
  - assert (Ha : Ortho (subst_env Gamma z u) (ForAll (subst_typ_source z u d) t1)
                       (ForAll (subst_typ_source z u d) t2)).
    apply_fresh OForAll as x; apply H0. not_in_L x.
    unfold not; intros HH; rewrite union_spec in HH; destruct HH as [HH | HH];
    apply fv_open_rec_typ_source in HH; simpl in HH; rewrite union_spec in HH;
    destruct HH as [HH | HH]; try (now not_in_L z);
    not_in_L x; apply H9; apply MSetProperties.Dec.F.singleton_iff;
    apply MSetProperties.Dec.F.singleton_iff in HH; auto.
    assert (Ha1 : d = subst_typ_source z u d).
    rewrite subst_typ_source_fresh; auto.
    not_in_L z.
    now rewrite Ha1.
  - apply OVar with (A := subst_typ_source z u A); auto.
    apply in_persists_subst_env; auto.
    apply usub_subst_not_in; auto.
    not_in_L z.
  - apply OVarSym with (A := subst_typ_source z u A); auto.
    apply in_persists_subst_env; auto.
    apply usub_subst_not_in; auto.
    not_in_L z.
Qed.

Lemma ortho_subst :
  forall z u Gamma d t1 t2,
    not (In z (fv_ptyp u)) ->
    WFEnv (subst_env Gamma z u) ->
    WFEnv Gamma ->
    MapsTo Gamma z d ->
    Ortho Gamma u d ->
    Ortho Gamma t1 t2 ->
    PType u ->
    PType t1 ->
    PType t2 ->
    Ortho (subst_env Gamma z u) (subst_typ_source z u t1) (subst_typ_source z u t2).
Proof.
  intros z u Gamma d t1 t2 HNotIn HWFEnvS HWFEnv HMapsTo HOrthoud HOrthot1t2 HWFu HWFt1 HWFt2.
  induction HOrthot1t2.
  - simpl; inversion HWFt1; auto.
  - simpl; inversion HWFt2; auto.
  - simpl; inversion HWFt1; inversion HWFt2; subst; auto.
  - simpl; inversion HWFt1; inversion HWFt2; subst.
    apply_fresh OForAll as x.
    repeat rewrite subst_typ_source_open_source_var.
    simpl in H0.
    apply H0.
    not_in_L x.
    apply WFPushV; auto.
    unfold not; intro HH; apply fv_subst_source in HH;
    rewrite union_spec in HH; destruct HH; not_in_L x.
    rewrite dom_subst_id; not_in_L x.
    apply WFPushV; auto; not_in_L x.
    apply MapsTo_extend; auto.
    not_in_L x.
    rewrite <- app_nil_l with (l := (extend x (TyDis d0) Gamma)).
    apply ortho_weaken.
    now simpl.
    apply H4.
    not_in_L x.
    apply H8.
    not_in_L x.
    not_in_L x.
    assumption.
    not_in_L x.
    assumption.
  - assert (Ha : sumbool (x = z) (not (x = z))) by apply VarTyp.eq_dec.
    destruct Ha as [Ha | Ha].
    + assert (HWFEnv' : WFEnv Gamma) by assumption.
      assert (Ha1 : A = d) by (subst; eapply MapsTo_In_eq with (Gamma := Gamma); eauto).
      subst; simpl; rewrite EqFacts.eqb_refl.
      assert (Ha2 : not (In z (fv_ptyp d))) by
          (apply not_in_wfenv with (Gamma := Gamma); auto).
      apply Ortho_usub_trans with (d := subst_typ_source z u d).
      now apply subst_source_lc.
      rewrite subst_typ_source_fresh; auto.
      apply ortho_subst_not_in; auto.
      not_in_L z.
      apply usub_subst; auto.
    + simpl; apply EqFacts.eqb_neq in Ha; rewrite Ha.
      apply OVar with (A := subst_typ_source z u A); auto.
      apply in_persists_subst_env; auto.
      apply usub_subst; auto.
      now apply subst_source_lc.
  - assert (Ha : sumbool (x = z) (not (x = z))) by apply VarTyp.eq_dec.
    destruct Ha as [Ha | Ha].
    + assert (HWFEnv' : WFEnv Gamma) by assumption.
      assert (Ha1 : A = d) by (subst; eapply MapsTo_In_eq with (Gamma := Gamma); eauto).
      subst; simpl; rewrite EqFacts.eqb_refl.
      apply Ortho_sym.
      assert (Ha2 : not (In z (fv_ptyp d))) by
          (apply not_in_wfenv with (Gamma := Gamma); auto).
      apply Ortho_usub_trans with (d := subst_typ_source z u d).
      now apply subst_source_lc.
      rewrite subst_typ_source_fresh; auto.
      apply ortho_subst_not_in; auto.
      not_in_L z.
      apply usub_subst; auto.
    + simpl; apply EqFacts.eqb_neq in Ha; rewrite Ha.
      apply OVarSym with (A := subst_typ_source z u A); auto.
      apply in_persists_subst_env; auto.
      apply usub_subst; auto.
      now apply subst_source_lc.
  - simpl; apply OTop1.
  - simpl; apply OTop2.
  - apply OAx; auto.
    assert (Ha : OrthoAx t1 t2) by assumption.
    destruct t1; destruct t2; auto; simpl; try (now orthoax_inv_r H0);
    try now orthoax_inv_l H0.
Qed.

End MDisjointness.


(** Coq coding by choukh, Aug 2021 **)

Require Import ZFC.Lib.ChoiceFacts.
Require Import ZFC.Lib.FuncFacts.
Require Import ZFC.Elements.EST8_7.
Require Export ZFC.Lib.OrdFacts.

Local Hint Resolve ordAdd_ran ordMul_ran ordExp_ran : core.

(*** 序数的可数性 ***)

(* 可数非零极限序数是可数无穷 *)
Theorem countable_limord_cntinf :
  ∀𝜆 ⋵ 𝐎𝐍ˡⁱᵐ, 𝜆 ≠ ∅ → countable 𝜆 → 𝜆 ≈ ω.
Proof with auto.
  intros 𝜆 H𝜆 Hne Hcnt.
  apply limord_is_inford in H𝜆 as [H𝜆 Hinf]...
  apply countable_iff in Hcnt as []... exfalso...
Qed.

(* 可数集除去任意多个元素仍是可数集 *)
Lemma remove_members_from_cnt :
  ∀ A B, countable A → countable (A - B).
Proof.
  intros A B Hcnt. eapply dominate_trans. 2: apply Hcnt.
  apply dominate_sub. auto.
Qed.

(* 序数可数如果其后继可数 *)
Corollary ord_cnt_if_suc_cnt :
  ∀α ⋵ 𝐎𝐍, countable α⁺ → countable α.
Proof with auto.
  intros α Hα Hcnt. rewrite <- (add_one_member_then_remove α α).
  apply remove_members_from_cnt... apply ord_irrefl...
Qed.

(* 往可数无穷加入可数多个元素仍是可数无穷 *)
Lemma add_countably_many_members_to_cntinf :
  ∀ A B, |A| = ℵ₀ → countable B → |A ∪ B| = ℵ₀.
Proof with nauto.
  intros A B Hcinf Hcnt. rewrite <- ex2_11_2.
  apply CardAx1, cardAdd_disjoint_iff.
  apply binter_comp_empty. rewrite Hcinf.
  apply cardLe_antisym.
  - rewrite <- cardAdd_aleph0_aleph0 at 2.
    apply cardAdd_preserve_le'. apply cardLe_iff.
    apply remove_members_from_cnt...
  - rewrite <- cardAdd_0_r at 1. 2: exists ω...
    apply cardAdd_preserve_le'. repeat split...
    apply dominate_sub. intros x Hx. exfalso0.
Qed.

(* 可数无穷除去一个元素仍是可数无穷 *)
Lemma remove_one_member_from_cntinf :
  ∀ a A, |A| = ℵ₀ → |A - {a,}| = ℵ₀.
Proof with eauto; try congruence.
  intros a A Hcinf.
  destruct (classic (a ∈ A)) as [|Ha'].
  2: rewrite remove_no_member...
  symmetry. apply CardAx1.
  symmetry in Hcinf. apply CardAx1 in Hcinf as [f Hbi].
  assert (H' := Hbi). apply bijection_is_func in H' as [Hf [Hi Hr]].
  assert (H' := Hf). destruct H' as [_ [Hd _]].
  set (Func ω (A - {a,}) (λ n, match (ixm (n ∈ f⁻¹[a])) with
    | inl _ => f[n]
    | inr _ => f[n⁺]
  end)) as g.
  exists g. apply meta_bijection.
  - intros n Hn. destruct (ixm (n ∈ f⁻¹[a])).
    + apply SepI. eapply ap_ran...
      apply SingNI. intros Hfn.
      rewrite <- Hfn, inv_dom_reduction in i...
      apply (nat_irrefl n)...
    + apply SepI. eapply ap_ran... apply ω_inductive...
      apply SingNI. intros Hfn.
      rewrite <- Hfn, inv_dom_reduction in n0...
      rewrite Hd. apply ω_inductive...
  - intros n1 H1 n2 H2 Heq.
    destruct (ixm (n1 ∈ f⁻¹[a]));
    destruct (ixm (n2 ∈ f⁻¹[a])).
    + apply injectiveE in Heq...
    + apply injectiveE in Heq... 2: rewrite Hd; apply ω_inductive...
      exfalso. rewrite Heq in i. apply n. eapply nat_trans.
      eapply ap_ran... apply bijection_is_func, inv_bijection...
      2: apply i. apply BUnionI2...
    + apply injectiveE in Heq... 2: rewrite Hd; apply ω_inductive...
      exfalso. rewrite <- Heq in i. apply n. eapply nat_trans.
      eapply ap_ran... apply bijection_is_func, inv_bijection...
      2: apply i. apply BUnionI2...
    + apply injectiveE in Heq... 2-3: rewrite Hd; apply ω_inductive...
      apply suc_injective in Heq...
  - intros y Hy. apply SepE in Hy as [Hy Hy']. apply SingNE in Hy'.
    assert (Hyw: (f⁻¹)[y] ∈ ω). {
      eapply ap_ran... apply bijection_is_func, inv_bijection...
    }
    assert (Haw: (f⁻¹)[a] ∈ ω). {
      eapply ap_ran... apply bijection_is_func, inv_bijection...
    }
    destruct (classic (f⁻¹[y] ∈ f⁻¹[a])).
    + exists (f⁻¹[y]). split... destruct (ixm (f⁻¹[y] ∈ f⁻¹[a]))...
      rewrite inv_ran_reduction...
    + set (f⁻¹[y]) as n. assert (Hn: n ∈ ω)...
      ω_destruct n. {
        apply le_iff_not_gt in H0 as []...
        - rewrite H1 in H0. exfalso0.
        - apply injectiveE in H0... apply inv_injective.
          apply Hbi. 1-2: rewrite inv_dom...
      }
      exists n. split... destruct (ixm (n ∈ f⁻¹[a])).
      * apply le_iff_not_gt in H0 as []...
        rewrite Heq in H0. exfalso. apply (ω_not_dense n)...
        apply injectiveE in H0... apply inv_injective.
        apply Hbi. 1-2: rewrite inv_dom...
      * rewrite <- Heq. rewrite inv_ran_reduction...
Qed.

(* 往作为可数无穷的集族并中加入一个替代目标后仍是可数无穷 *)
Lemma add_one_member_to_funion : ∀ a F A, countable (F a) →
  |⋃ {F x | x ∊ A - {a,}}| = ℵ₀ → |⋃ {F x | x ∊ A}| = ℵ₀.
Proof with auto.
  intros * Hcnt Heq.
  destruct (classic (a ∈ A)) as [|Ha'].
  2: rewrite <- (remove_no_member A a)...
  rewrite <- (remove_one_member_then_return A a)...
  rewrite repl_bunion_distr, union_bunion_distr.
  rewrite repl_single, union_single.
  apply add_countably_many_members_to_cntinf...
Qed.

(* 可数集的替代可数 *)
Lemma repl_of_cnt_cnt : AC_II → ∀ F A, countable A → countable {F x | x ∊ A}.
Proof with auto.
  intros AC2 F A Hcnt. eapply dominate_trans. 2: apply Hcnt.
  set (Func A {F x | x ∊ A} F) as f.
  apply AC_II_to_IV, AC_IV_to_III, AC_III_to_I in AC2.
  apply (domain_of_surjection_dominate_range AC2 _ _ f).
  apply meta_surjection.
  - intros x Hx. eapply ReplI...
  - intros y Hy. apply ReplAx...
Qed.

(* 可数无穷序数非空 *)
Lemma cntinf_ord_neq_0 : ∀α ⋵ 𝐎𝐍, |α| = ℵ₀ → α ≠ 0.
Proof.
  intros α Hα Hcinf H0. subst. symmetry in Hcinf.
  rewrite pred, card_of_empty, card_eq_0 in Hcinf; nauto.
Qed.
Local Hint Resolve cntinf_ord_neq_0 : core.

(* 比可数序数小的序数可数 *)
Lemma ord_lt_cnt_cnt :
  ∀α ⋵ 𝐎𝐍, countable α → ∀β ∈ α, countable β.
Proof with eauto.
  intros α Hoα Hcnt β Hβ.
  assert (Hoβ: β ⋵ 𝐎𝐍). apply (ord_is_ords α)...
  eapply dominate_trans. apply dominate_sub.
  apply ord_lt_iff_psub; revgoals... apply Hcnt.
Qed.

(* 可数无穷序数的后继是可数无穷 *)
Theorem ord_suc_cntinf : AC_II → ∀α ⋵ 𝐎𝐍, |α| = ℵ₀ → |α⁺| = ℵ₀.
Proof with neauto.
  intros AC2 α Hα Hcinf.
  apply add_countably_many_members_to_cntinf...
  apply countableI1. apply single_finite.
Qed.

(* 可数无穷序数的可数次后继是可数无穷 *)
Theorem ord_sum_cntinf : AC_II → ∀α ⋵ 𝐎𝐍, |α| = ℵ₀ →
  ∀β ⋵ 𝐎𝐍, countable β → |α + β| = ℵ₀.
Proof with neauto.
  intros AC2 α Hα Hcinf. ord_induction.
  intros β Hβ IH Hcnt. ord_destruct β.
  - subst. rewrite ordAdd_0_r...
  - destruct Hsuc as [γ [Hγ Heq]]. subst.
    destruct (classic (γ = 0)) as [|Hγ0]. {
      subst. rewrite ordAdd_1_r... apply ord_suc_cntinf...
    }
    rewrite ordAdd_suc... apply ord_suc_cntinf...
    apply IH... rewrite <- (add_one_member_then_remove γ γ).
    apply remove_members_from_cnt... apply ord_irrefl...
  - rewrite ordAdd_limit...
    apply countable_union_of_cntinf...
    + exists α. apply ReplAx. exists 0. split.
      apply ord_neq_0_gt_0... rewrite ordAdd_0_r...
    + apply repl_of_cnt_cnt...
    + intros A H. apply ReplAx in H as [γ [Hγ H]]. subst.
      apply IH... eapply ord_lt_cnt_cnt...
Qed.

(* 可数无穷序数的非零可数乘积是可数无穷 *)
Theorem ord_prd_cntinf : AC_II → ∀α ⋵ 𝐎𝐍, |α| = ℵ₀ →
  ∀β ⋵ 𝐎𝐍, β ≠ 0 → countable β → |α ⋅ β| = ℵ₀.
Proof with neauto.
  intros AC2 α Hα Hcinf. ord_induction.
  intros β Hβ IH Hβ0 Hcnt. ord_destruct β.
  - exfalso...
  - destruct Hsuc as [γ [Hγ Heq]]. subst.
    destruct (classic (γ = 0)) as [|Hγ0]. {
      subst. rewrite ordMul_1_r...
    }
    rewrite ordMul_suc... apply ord_sum_cntinf...
    + apply IH... rewrite <- (add_one_member_then_remove γ γ).
      apply remove_members_from_cnt... apply ord_irrefl...
    + apply countableI2. apply CardAx1...
  - clear H0. rewrite ordMul_limit...
    apply (add_one_member_to_funion 0). rewrite ordMul_0_r...
    apply countableI1...
    apply countable_union_of_cntinf...
    + exists α. apply ReplAx.
      exists 1. split. 2: rewrite ordMul_1_r...
      apply SepI... apply sucord_in_limord... apply SingNI...
    + apply repl_of_cnt_cnt, remove_members_from_cnt...
    + intros A H. apply ReplAx in H as [γ [Hγ H]]. subst.
      apply SepE in Hγ as [Hγ Hγ0]. apply SingNE in Hγ0.
      apply IH... eapply ord_lt_cnt_cnt...
Qed.

(* 可数无穷序数的非零可数次方是可数无穷 *)
Theorem ord_pow_cntinf : AC_II → ∀α ⋵ 𝐎𝐍, |α| = ℵ₀ →
  ∀β ⋵ 𝐎𝐍, β ≠ 0 → countable β → |α ^ β| = ℵ₀.
Proof with neauto.
  intros AC2 α Hα Hcinf. ord_induction.
  intros β Hβ IH Hβ0 Hcnt. ord_destruct β.
  - exfalso...
  - destruct Hsuc as [γ [Hγ Heq]]. subst.
    destruct (classic (γ = 0)) as [|Hγ0]. {
      subst. rewrite ordExp_1_r...
    }
    rewrite ordExp_suc... apply ord_prd_cntinf...
    + apply IH... rewrite <- (add_one_member_then_remove γ γ).
      apply remove_members_from_cnt... apply ord_irrefl...
    + apply countableI2. apply CardAx1...
  - clear H0. rewrite ordExp_limit...
    apply (add_one_member_to_funion 0). rewrite ordExp_0_r...
    apply countableI1. apply nat_finite...
    apply countable_union_of_cntinf...
    + exists α. apply ReplAx.
      exists 1. split. 2: rewrite ordExp_1_r...
      apply SepI... apply sucord_in_limord... apply SingNI...
    + apply repl_of_cnt_cnt, remove_members_from_cnt...
    + intros A H. apply ReplAx in H as [γ [Hγ H]]. subst.
      apply SepE in Hγ as [Hγ Hγ0]. apply SingNE in Hγ0.
      apply IH... eapply ord_lt_cnt_cnt...
Qed.