Require Import all_ssreflect core.

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

(******************************************************************************)
(* Union-find                                                                 *)
(******************************************************************************)

Section union_find.

Variable (R : eqType) (Ridx : R) (Rop : Monoid.com_law Ridx) (cmp : rel R)
         (T : finType).
Definition G := {ffun T -> T + R}.

Section static.

Variable (g : G).

Definition succ x := if g x is inl x' then x' else x.
Definition classval x := if g x is inr a then a else Ridx.
Definition repr x := g x == inr (classval x).

Definition path := path (fun x y => g x == inl y).
Definition connect := fconnect succ.

Lemma path_ind (P : T -> seq T -> Prop)
  (Hnil : forall x, P x [::])
  (Hcons : forall x xs, ~~ repr x -> path (succ x) xs ->
                        P (succ x) xs -> P x (succ x :: xs))
  x xs : path x xs -> P x xs.
Proof.
elim: xs x => //= x' xs IH x /andP [] /eqP H H0.
have Hx': x' = succ x by rewrite /succ H.
by subst x'; apply: Hcons; auto; rewrite /repr H /eq_op.
Qed.

Lemma connectP (x y : T) :
  reflect (exists2 p : seq T, path x p & y = last x p) (connect x y).
Proof.
apply: (iffP idP); last by case=> xs Hxs ->; apply/connectP; exists xs => //;
                           elim/path_ind: x xs / Hxs => //= ?; rewrite eqxx.
rewrite /connect fconnect_orbit => H; apply/connectP.
move: (orbit_uniq succ x) H; rewrite /orbit.
move: (order _ _) => n; elim: n x => //= n IH x.
case/andP => H H0; rewrite inE => /orP [/eqP -> | H1]; first exact: connect0.
case: n IH H H0 H1 => // n IH H H0 H1.
apply/connect_trans/(IH (succ x)); rewrite // /succ.
by case_eq (g x) => x' Hx'; [ apply/connect1/eqP | apply: connect0 ].
Qed.

Lemma connectP' (x y : T) :
  reflect (exists2 i : nat, i < order succ x & y = iter i succ x) (connect x y).
Proof.
apply: (iffP idP); last by case=> i H -> {y}; apply: fconnect_iter.
by rewrite /connect fconnect_orbit /orbit => /trajectP [] i H -> {y}; exists i.
Qed.

Arguments connectP [x y].
Arguments connectP' [x y].

Definition find := iter #|T| succ.
Definition findeq x y := find x == find y.

Definition lacycle x := repr (find x).
Definition acycle := forall x, lacycle x.

Lemma connect0 x : connect x x. Proof. exact: connect0. Qed.

Lemma connect1 x : connect x (succ x). Proof. exact: fconnect1. Qed.

Lemma connect_trans x y z : connect x y -> connect y z -> connect x z.
Proof. exact: connect_trans. Qed.

Lemma connectE x y : connect x y = (x == y) || connect (succ x) y.
Proof.
apply/idP/idP => [/connectP [xs Hxs ->] | /orP []].
- by case: xs Hxs; rewrite ?eqxx //= => x' xs /andP [] /eqP H H0;
     rewrite /succ H; apply/orP/or_intror; apply/connectP; exists xs.
- by move/eqP => ->; apply: connect0.
- by apply/connect_trans/connect1.
Qed.

Lemma connect_iter n x : connect x (iter n succ x).
Proof. exact: fconnect_iter. Qed.

Lemma connect_find x : connect x (find x).
Proof. by rewrite connect_iter. Qed.

Lemma connect_succL x y : connect (succ x) y -> connect x y.
Proof. by apply/connect_trans/connect1. Qed.

Lemma connect_succR x y : connect x y -> connect x (succ y).
Proof. by move=> H; apply/(connect_trans H)/connect1. Qed.

Lemma reprP x : reflect (exists x', g x = inr x') (repr x).
Proof.
by rewrite /repr /classval; case: (g x) => x'; rewrite ?eqxx /eq_op /=;
   constructor; [case=> ?; congruence | exists x'].
Qed.

Lemma repr_succ x : repr x -> repr (succ x).
Proof. by move/eqP => H; rewrite /repr /succ !H. Qed.

Lemma repr_iter n x : repr x -> repr (iter n succ x).
Proof. by move=> H; elim: n => //= n; apply: repr_succ. Qed.

Lemma path_traject x xs : path x xs -> x :: xs = traject succ x (size xs).+1.
Proof. by move=> H; elim/path_ind: x xs / H => //= x xs H Hxs [] {1}->. Qed.

Lemma full_path_connect x xs :
  path x xs -> repr (last x xs) -> x :: xs =i connect x.
Proof.
move=> H H0 y; apply/esym.
rewrite unfold_in -/(fingraph.connect _ _ _) -/(connect _ _).
elim/path_ind: x xs / H H0 => /= [x H | x xs H Hxs IH H0];
  last by rewrite inE -IH // connectE eq_sym.
rewrite !inE; apply/idP/eqP => [| ->]; last exact: connect0.
 by case/connectP => -[| x' xs] //= /andP []; rewrite (eqP H) eqE.
Qed.

Section lacycle.

Variables (x : T) (Hx : lacycle x).

Lemma find_succ : succ (find x) = find x.
Proof. by rewrite {1}/succ; case/reprP: Hx => x' ->. Qed.

Lemma succ_find : find (succ x) = find x.
Proof. by rewrite /find -iterSr /= find_succ. Qed.

Lemma find_iter n : iter n succ (find x) = find x.
Proof. by elim: n => // n IH; rewrite iterSr find_succ IH. Qed.

Lemma iter_find n : find (iter n succ x) = find x.
Proof. by rewrite /find -iter_add addnC iter_add find_iter. Qed.

Lemma findI : find (find x) = find x. Proof. by rewrite /find find_iter. Qed.

Lemma iter_invariance n : 0 < n -> (x == iter n succ x) = (x == succ x).
Proof.
case: n => // n _; apply/eqP/eqP => H; last by elim: n => //= n <-.
suff ->: x = iter (#|T| * n.+1) succ x by
  rewrite -iterS mulnS -addnS !(addnC #|T|) !iter_add !find_iter.
by elim: #|T| => // c IH; rewrite mulSn iter_add -IH -H.
Qed.

Lemma find_invariance : (x == find x) = (x == succ x).
Proof. by rewrite iter_invariance //; apply/card_gt0P; exists x. Qed.

Lemma reprE : repr x = (x == succ x).
Proof.
apply/idP/idP; first by rewrite /succ; case/reprP => x' ->.
by rewrite -find_invariance => /eqP H; move: Hx; rewrite /lacycle -H.
Qed.

Lemma path_notin xs : path x xs -> x \notin xs.
Proof.
move=> Hxs; have ->: xs = [seq iter i succ x | i <- iota 1 (size xs)] by
  elim/path_ind: x xs / Hxs => //= x' xs H Hxs {1}->; congr cons;
  rewrite (iota_addl 1 1) -map_comp; apply/eq_in_map => i /=; rewrite -iterSr.
apply/mapP => /= -[] [| i]; rewrite mem_iota add1n // => H /eqP.
rewrite iter_invariance // -find_invariance => /eqP H0.
by move: Hx; rewrite /lacycle -H0 {H0}; apply/negP; elim/path_ind: x xs / Hxs H.
Qed.

Lemma connect_findeq y : connect x y -> find x = find y.
Proof. by move=> /iter_findex <-; rewrite iter_find. Qed.

End lacycle.

Lemma lacycle_repr x : repr x -> lacycle x.
Proof.
rewrite /lacycle => H; suff <-: x = find x by [].
by rewrite /find; elim: #|T| => //= n <-; move/eqP: H; rewrite /succ => ->.
Qed.

Lemma lacycle_succ x : lacycle (succ x) = lacycle x.
Proof.
apply/reprP/reprP; case=> x' H; exists x';
  [ move: H; rewrite /find -iterSr | by rewrite /find -iterSr /= {1}/succ !H].
case/connectP': (connect_iter #|T|.+1 x) => i Hi -> H.
have/subnK <- : i <= #|T| by apply/ltnW/(leq_trans Hi)/subset_leq_card/subsetP.
by rewrite iter_add; elim: (#|T| - i) => //= i' IH; rewrite {1}/succ IH.
Qed.

Lemma lacycle_iter n x : lacycle (iter n succ x) = lacycle x.
Proof. by elim: n => //= n <-; rewrite lacycle_succ. Qed.

Lemma lacycle_find x : lacycle (find x) = lacycle x.
Proof. by rewrite /find lacycle_iter. Qed.

Lemma lacycle_connect x y : connect x y -> lacycle x = lacycle y.
Proof. by move/iter_findex <-; rewrite lacycle_iter. Qed.

Lemma findeq_connect x y : lacycle x -> findeq x y = connect x (find y).
Proof.
move=> H; apply/eqP/idP => [<- |]; first exact: connect_find.
by move/(connect_findeq H) => H0; move: H0 H; rewrite /lacycle => ->;
   rewrite -/(lacycle _) lacycle_find => H; rewrite findI.
Qed.

Lemma path_uniq x xs : lacycle x -> path x xs -> uniq (x :: xs).
Proof.
move=> H H0; elim/path_ind: x xs / H0 H => //= x xs H Hxs IH Hx.
by rewrite IH ?lacycle_succ // path_notin //= Hxs; move: H;
   rewrite /repr /classval /succ; case (g x) => x'; rewrite !eqxx.
Qed.

Lemma iter_findeq x y m n :
  lacycle x -> iter m succ x = iter n succ y -> find x = find y.
Proof.
by move=> Hx Hy; move: (Hx);
  rewrite -(lacycle_iter m x) -(iter_find Hx m) {}Hy lacycle_iter => /iter_find.
Qed.

Lemma path_size x xs : lacycle x -> path x xs -> size xs < #|T|.
Proof. by move=> H /(path_uniq H) /card_uniqP /= <-; apply: max_card. Qed.

End static.

Arguments connectP [g x y].
Arguments connectP' [g x y].

Section dynamic.

Variable (g : G).

Definition compress x :=
  [ffun y => if connect g x y && (y != find g x)
             then inl (find g x) else g y].

Lemma succ_subst x y z :
  succ (dffun_set y z g) x =
  if x == y then (if z is inl z' then z' else x) else succ g x.
Proof. by rewrite /succ ffun_setE eq_sym; case: ifP. Qed.

Lemma find_subst_separated x y y' :
  ~~ connect g x y -> find (dffun_set y y' g) x = find g x.
Proof.
by rewrite /find; elim: #|T| x => //= n IH x Hxy;
rewrite succ_subst IH //; case: (_ =P y) Hxy => // <-; rewrite connect_iter.
Qed.

Lemma lacycle_subst_separated x y y' :
  ~~ connect g x y -> lacycle (dffun_set y y' g) x = lacycle g x.
Proof.
move=> Hxy; rewrite /lacycle find_subst_separated // /repr /classval ffun_setE.
by case: (_ =P y) Hxy => //= <-; rewrite connect_iter.
Qed.

Lemma lacycle_substR x y a :
  lacycle (dffun_set x (inr a) g) y = connect g y x || lacycle g y.
Proof.
case: (altP connectP) => /=; last apply: lacycle_subst_separated.
case=> ys Hys Hx; subst x.
elim/path_ind: y ys / Hys => [y | y ys H Hys] /=;
  first by apply/repr_iter/reprP; rewrite ffun_setE eqxx; exists a.
rewrite -(lacycle_succ _ y) succ_subst; case: eqP H Hys => //.
rewrite /repr /classval /succ; case: (g y) => // y' H H0 H1 _; subst y.
by apply: lacycle_repr; rewrite /repr /classval ffun_setE eqxx.
Qed.

Lemma lacycle_substL x y z :
  lacycle (dffun_set x (inl y) g) z =
  if connect g z x then ~~ connect g y x && lacycle g y else lacycle g z.
Proof.
case: (altP connectP) => [ [] zs Hzs -> {x} | /lacycle_subst_separated -> // ].
apply eq_trans with (lacycle (dffun_set (last z zs) (inl y) g) y);
  first by elim/path_ind: z zs / Hzs => /= [z | z zs H Hzs H0];
           rewrite -lacycle_succ succ_subst ?eqxx //; case: ifP.
move: (last _ _) => {z zs Hzs} x; case: (altP connectP);
  last exact: lacycle_subst_separated.
case=> ys' /shortenP [] ys; rewrite -/(path _) => Hys H _ Hx;
  subst x => {ys'} /=; apply/negbTE.
suff Hys': path (dffun_set (last y ys) (inl y) g) y (rcons ys y) by
  apply/negP => /path_uniq /(_ Hys') /=; rewrite mem_rcons inE eqxx.
rewrite -cats1 /path cat_path -/(path _) /= ffun_setE !eqxx !andbT.
elim/path_ind: y ys / Hys (inl y) H => // y ys H Hys IH a /andP [H0 H1] /=.
by rewrite IH // andbT ffun_setE; case: (altP (y =P _)) H0 => [{1}-> | _];
   [ rewrite mem_last | rewrite inE /succ; case (g y) => b; rewrite eqxx ].
Qed.

Lemma lacycle_subst x y z :
  lacycle (dffun_set x y g) z =
  if y is inl y'
    then (if connect g z x
          then ~~ connect g y' x && lacycle g y' else lacycle g z)
    else connect g z x || lacycle g z.
Proof. by case: y => y; rewrite (lacycle_substL, lacycle_substR). Qed.

Lemma find_substR x y a :
  lacycle g x ->
  find (dffun_set y (inr a) g) x = if connect g x y then y else find g x.
Proof.
move=> H; case: (boolP (connect _ _ _)) => H0;
  last by rewrite find_subst_separated.
case/connectP: H0 => xs' /shortenP [xs]; rewrite -/(path _) => Hxs H0 _ ->.
have {H0 Hxs xs'} Hxs: path (dffun_set (last x xs) (inr a) g) x xs by
  elim/path_ind: x xs / Hxs H0 {H} => // x xs H0 Hxs IH /andP [H1 H2] /=;
  rewrite {}IH // andbT ffun_setE; move: H0 H1; rewrite /repr /classval /succ;
  case: (x =P _); case: (g x) => x'; rewrite ?eqxx //= => ->; rewrite mem_last.
elim: xs x Hxs H => [x _ _ | x' xs IH x /andP []] //=;
  first by rewrite /find; elim: #|T| => //= n ->; rewrite succ_subst eqxx.
rewrite ffun_setE; case: (altP (x =P _)) => //= H /eqP H0 H1 H2; move: (H2).
rewrite -lacycle_succ /succ H0 => H2'.
by rewrite -{2}IH // -succ_find ?lacycle_subst ?H2 ?orbT //
           succ_subst (negbTE H) /succ H0.
Qed.

Lemma connect_substL x y z :
  connect (dffun_set y (inl z) g) x z = connect g x y || connect g x z.
Proof.
apply/idP/idP =>
  [/connectP [] xs Hxs Hz | /orP [] /connectP [] xs' /shortenP [xs]].
- by subst z; elim: xs x Hxs => /= [x _ | x' xs IH x /andP []];
     rewrite ?(connect0, orbT) // ffun_setE; case: (altP (x =P y)) => [-> |];
     rewrite ?connect0 // => H /eqP H0 /IH /orP [] H1; apply/orP;
     [left | right]; apply: connect_succL; rewrite /succ H0.
- rewrite -/(path _) => Hxs Hxs' _ -> {y xs'}.
  apply/connect_trans/(connect_succL (x := last x xs));
    last by rewrite succ_subst eqxx connect0.
  elim/path_ind: x xs / Hxs Hxs' => [* | x xs _ _ IH /andP [H] /IH {IH} /=];
    first exact: connect0.
  by apply: connect_trans; apply: connect_succL; rewrite succ_subst;
    case: eqP H => [{1}-> | *]; rewrite (mem_last, connect0).
- rewrite -/(path _) => Hxs Hxs' _ -> {z xs'}.
  elim/path_ind: x xs / Hxs Hxs' => [* | x xs H _ IH /andP [H0] /IH {IH} H1];
    first exact: connect0.
  by apply: connect_succL; rewrite succ_subst; case: eqP => *;
    [ apply: connect0 | apply: H1 ].
Qed.

Lemma path_subst_separated x y z xs :
  ~~ connect g x y -> path (dffun_set y z g) x xs = path g x xs.
Proof.
elim: xs x => //= x' xs IH x H; rewrite ffun_setE.
have/negbTE ->: x != y by apply/contra: H => /eqP ->; apply: connect0.
case: eqP => //= H0; apply: IH; apply/contra/connect_trans/connectP: H.
by exists [:: x']; rewrite //= H0 eqxx.
Qed.

Lemma path_subst_graft x y xs :
  lacycle g x -> ~~ connect g x y ->
  path g x xs -> path (dffun_set (last x xs) (inl y) g) x (rcons xs y).
Proof.
move=> H H0 H1.
elim/path_ind: x xs / H1 H H0 => /= [x H H0 | x xs H H0 H1 H2 H3];
  rewrite ffun_setE ?eqxx //.
have H4: g x == inl (succ g x) by
  move: H; rewrite /repr /classval /succ; case: (g x) => x'; rewrite ?eqxx.
have/(path_notin H2): path g x (succ g x :: xs) by rewrite /= H0 andbT.
case: (x =P last _ _) => [{1}-> | _ _]; first by rewrite mem_last.
by rewrite H4 /= H1 ?lacycle_succ //; apply/contra/connect_trans/connect1: H3.
Qed.

Lemma repr_compress x y : repr g y = repr (compress x) y.
Proof.
rewrite /repr /classval /compress !ffunE /(succ _ _).
case: ifP; case_eq (g y) => // b Hy' /andP [] /connectP' [i Hi Hy] /negP [].
rewrite /find; move/ltnW/subnK: (leq_trans Hi (max_card _)) => <-.
by rewrite iter_add -Hy; apply/eqP;
   elim: (#|T| - i) => //= {i Hi Hy} i <-; rewrite /succ Hy'.
Qed.

Lemma path_compress x y xs :
  lacycle g x -> path g x xs -> ~~ connect g y (last x xs) ->
  path (compress y) x xs.
Proof.
move=> H H0; elim/path_ind: x xs / H0 H => //= x xs H Hxs IH H0 H1.
rewrite {}IH // ?lacycle_succ // andbT ffunE.
case: (altP andP) => [[] H2 |];
  last by move: H; rewrite /repr /classval /(succ _ _);
          case: (g x) => x'; rewrite eqxx.
case/connectP': H2 Hxs H H0 H1 => i Hi ->; rewrite lacycle_iter => Hxs H H0 H1.
by case/negP: H1; apply connect_trans with (iter i.+1 (succ g) y);
   rewrite ?connect_iter //=; apply/connectP; exists xs.
Qed.

Lemma succ_compress x y :
  lacycle g x ->
  succ (compress y) x = if connect g y x then find g y else succ g x.
Proof.
by move=> H; rewrite /succ ffunE;
   case: (boolP (connect g y x)) => //=; case: eqP => //= H0;
   rewrite -/(succ _ _) H0; rewrite find_succ // -lacycle_find -H0.
Qed.

Lemma compress_repr x y : repr g x -> compress y x = inr (classval g x).
Proof.
rewrite /repr /classval ffunE /find; case: andP;
  case_eq (g x) => // a H [] /connectP' [i] /ltnW /leq_trans /(_ (max_card _))
                   /subnK <- Hx /eqP []; subst x.
by rewrite iter_add; elim: (#|T| - i) => //= j <-; rewrite /(succ _ _) H.
Qed.

Lemma find_compress x y : lacycle g x -> find (compress y) x = find g x.
Proof.
move=> H.
suff [i /subnK <- ->]:
  exists2 i, #|T| <= i & find (compress y) x = iter i (succ g) x
  by rewrite iter_add /= find_iter.
rewrite /find; elim: #|T|; [ exists 0 | ] => //= i [j Hj] ->;
  rewrite succ_compress ?lacycle_iter //; case: ifP => H0; last by exists j.+1.
exists (maxn #|T| j.+1); first by rewrite leq_max ltnS Hj orbT.
by rewrite maxnE iter_add -/(find _ _) iter_find // (connect_findeq _ H0)
           ?iter_find // (lacycle_connect H0) lacycle_iter.
Qed.

Lemma connect_compress x y z : connect (compress z) x y -> connect g x y.
Proof.
case/connectP => xs Hxs ->;
  elim/path_ind: x xs / Hxs => [| x xs H]; first exact: connect0.
rewrite /(succ _ _) ffunE /=; case: (altP andP);
  last by rewrite -/(succ g x) => H0 H1; apply: connect_succL.
by case: xs => [[] H0 _ | x' xs [] H0] _ _ /=; [ | apply: connect_trans ];
   case/connectP': H0 => i /ltnW /leq_trans /(_ (max_card _)) /subnK Hi ->;
   rewrite /find -Hi iter_add; elim: (#|T| - i); try apply: connect0;
   move=> n H0; apply/(connect_trans H0)/connect1.
Qed.

Lemma lacycle_compress x y : lacycle g x -> lacycle (compress y) x.
Proof.
by move=> H; rewrite /lacycle /repr /classval find_compress // compress_repr.
Qed.

Variable (Hg : acycle g).

Lemma acycle_substL x y z :
  lacycle (dffun_set x (inl y) g) z = ~~ (connect g z x && connect g y x).
Proof. by rewrite lacycle_subst !Hg andbT; case: connect. Qed.

Lemma acycle_substR x a : acycle (dffun_set x (inr a) g).
Proof. by move=> y; rewrite lacycle_subst Hg orbT. Qed.

Lemma find_substL_graft x y :
  ~~ connect g y (find g x) ->
  find (dffun_set (find g x) (inl y) g) x = find g y.
Proof.
case/connectP: (connect_find g x) => xs' /shortenP [xs];
  rewrite -/(path _) => Hxs H _ -> H0 {xs'}.
elim/path_ind: x xs / Hxs H H0 => /= [x _ H0 | x xs H Hxs IH /andP [] H0 H1 H2];
  first by rewrite -succ_find ?lacycle_subst ?connect0 ?H0 //=
                   /succ ffun_setE eqxx find_subst_separated.
rewrite -{}IH // -succ_find; last by rewrite lacycle_subst H2 andTb; case: ifP.
by rewrite !/(succ _ _) ffun_setE; case: eqP H0 => [{1}-> | _ H0];
  [ rewrite mem_last | case: (g x) ].
Qed.

Lemma find_substL x y z :
  ~~ connect g y (find g x) -> find (dffun_set (find g x) (inl y) g) z =
                               find g (if findeq g z x then y else z).
Proof.
by rewrite /findeq; case: (altP (find g z =P _)) => [<- Hzy | Hzx Hxy];
   rewrite (find_substL_graft, find_subst_separated) //;
   apply/contra: Hzx => /connect_findeq -> //; rewrite findI.
Qed.

Lemma acycle_compress x : acycle (compress x).
Proof. by move=> y; apply: lacycle_compress. Qed.

End dynamic.

(* Monadic definition of union-find and its properties *)
Section monadic.

Section find.

Variable (g : G) (Hg : acycle g).

Fixpoint mfind_rec n x : AState {ffun T -> T + R} (T * R) :=
  if n is n'.+1
  then mlet x' := astate_get x in
       match x' with
         | inl x'' =>
           mlet '((rep, _) as r) := mfind_rec n' x'' in
           astate_set x (inl rep);;
           astate_ret r
         | inr a => astate_ret (x, a)
       end
  else astate_ret (x, Ridx).

Definition mfind := mfind_rec $|T|.

Lemma run_mfind_rec n x xs :
  let x' := last x xs in
  path g x xs -> size xs < n -> repr g x' ->
  run_AState (mfind_rec n x) g =
  (x', classval g x',
   [ffun z => if (z \in x :: xs) && (z != x') then inl x' else g z]).
Proof.
move=> /= H /subnK <-; move: {n} (n - _) => n; rewrite addnC.
elim/path_ind: x xs / H (path_uniq (Hg _) H) => [x /= _ H | x xs];
  first by rewrite !(run_AStateE, eqP H); congr (_, _);
           apply/ffunP => z; rewrite ffunE inE andbN.
rewrite reprE // /(succ g x); case_eq (g x) => x';
  rewrite ?eqxx //= inE !run_AStateE negb_or -andbA
    => H H0 H1 H2 /and4P [_ H3 H4 H5] H6.
rewrite H !run_AStateE {}H2 ?H4 //= !run_AStateE.
congr (_, _); apply/ffunP => y; rewrite ffun_setE !ffunE.
move/eqP: H6 => H6; rewrite !inE; do !case: eqP => //=; congruence.
Qed.

Lemma run_mfind x :
  run_AState (mfind x) g = (find g x, classval g (find g x), compress g x).
Proof.
case/connectP: (connect_find g x) => xs Hxs H.
have Hrepr: repr g (last x xs) by rewrite -H; apply: Hg.
rewrite H /mfind raw_cardE (run_mfind_rec Hxs) // ?(path_size (Hg _) Hxs) //.
congr (_, _, _); apply/ffunP => y; rewrite !ffunE H /connect fconnect_orbit.
congr (if (_ \in _) && _ then _ else _).
rewrite /orbit /order -/(connect _) -(eq_card (full_path_connect Hxs _)) //.
by move/card_uniqP: (path_uniq (Hg _) Hxs) {y Hrepr} => ->;
   congr cons; elim/path_ind: x xs / Hxs {H} => //= x xs _ _ <-.
Qed.

End find.

Section union.

Variable (g : G) (Hg : acycle g).

Definition union x y :=
  let x' := find g x in let y' := find g y in
  let v  := Rop (classval g x') (classval g y') in
  let g' := compress (compress g x) y in
  if findeq g x y then g' else
    if cmp (classval g x') (classval g y')
    then dffun_set y' (inr v) (dffun_set x' (inl y') g')
    else dffun_set x' (inr v) (dffun_set y' (inl x') g').

Definition munion x y : AState {ffun T -> T + R} unit :=
  mlet '(xr, xv) := mfind x in
  mlet '(yr, yv) := mfind y in
  if xr == yr then astate_ret tt else
  if cmp xv yv
    then astate_set xr (inl yr);; astate_set yr (inr (Rop xv yv))
    else astate_set yr (inl xr);; astate_set xr (inr (Rop xv yv)).

Lemma run_munion x y : run_AState (munion x y) g = (tt, union x y).
Proof.
rewrite /union /findeq !(run_AStateE, run_mfind) //;
  last exact: acycle_compress.
by rewrite find_compress // /(classval (compress _ _)) compress_repr;
  [ do ?case: ifP; rewrite !run_AStateE | apply: Hg ].
Qed.

Lemma union_findeq x y a b :
 findeq (union x y) a b =
  [||findeq g a b, findeq g a x && findeq g b y | findeq g a y && findeq g b x].
Proof.
rewrite /union /findeq; case: ifP => [| /negbT H];
  first by rewrite !find_compress ?lacycle_compress // => /eqP ->;
           apply/idP/idP => [-> | /or3P []] // /andP [] /eqP -> /eqP ->.
set g' := compress (compress g x) y.
have Hg1: acycle g' by move=> z; rewrite !lacycle_compress.
have Hg2 z: find g z = find g' z by rewrite !(find_compress, lacycle_compress).
have Hxy: ((~~ connect g' (find g x) (find g y)) *
           (~~ connect g' (find g y) (find g x)))%type by
  split; apply/contra: H => /connect_findeq;
  rewrite !(lacycle_compress, find_compress, findI) // => ->.
case: ifP => _;
  rewrite !find_substR ?Hg2 ?find_substL
          ?(lacycle_subst, (fun z => esym (Hg2 z)), Hg1, Hxy, if_same) //
          !Hg2 !connect_substL -!findeq_connect // /findeq;
  do !case: (find _ _ =P find _ _) => //=; congruence.
Qed.

End union.

End monadic.

End union_find.

(******************************************************************************)
(* Weighted union-find                                                        *)
(******************************************************************************)

Module WUF.

Definition R := [eqType of nat].
Definition Ridx := 0.
Definition Rop := addn_comoid.
Definition cmp := leq.

Definition mfind n := mfind Ridx (T := [finType of 'I_n]).
Definition munion n := munion Rop cmp (T := [finType of 'I_n]).

End WUF.

Require Import extraction_ocaml.

Extraction Inline
  mfind_rec mfind munion WUF.R WUF.Ridx WUF.Rop WUF.cmp
  Monoid.operator Monoid.com_operator addn_comoid addn_monoid.

Set Extraction Flag 2031.
Extract Type Arity AState 0.

Extraction "../../ocaml/wuf_o0.ml" WUF.

Set Extraction Flag 8175.
Extract Type Arity AState 1.

Extraction "../../ocaml/wuf.ml" WUF.


Require Export Ensembles.
Require Import EnsemblesImplicit.
Require Export Image.
Require Import ImageImplicit.
Require Export Finite_sets.
Require Export FunctionProperties.
Require Import DecidableDec.
Require Import ProofIrrelevance.
Require Import Description.

Set Asymmetric Patterns.
Unset Standard Proposition Elimination Names.

Inductive FiniteT : Type -> Prop :=
  | empty_finite: FiniteT False
  | add_finite: forall T:Type, FiniteT T -> FiniteT (option T)
  | bij_finite: forall (X Y:Type) (f:X->Y), FiniteT X ->
    invertible f -> FiniteT Y.

Lemma True_finite: FiniteT True.
Proof.
apply bij_finite with (option False)
  (fun _ => I).
constructor; constructor.
exists (True_rect None).
destruct x as [[]|].
remember (True_rect (@None False) I) as LHS.
destruct LHS as [[]|].
reflexivity.

exact (fun y:True => match y with
  | I => refl_equal I
  end).
Qed.

Lemma finite_dec_exists: forall (X:Type) (P:X->Prop),
  FiniteT X -> (forall x:X, {P x} + {~ P x}) ->
  { exists x:X, P x } + { forall x:X, ~ P x }.
Proof.
intros.
apply exclusive_dec.
red; intro.
destruct H0.
destruct H0.
contradiction (H1 x).

revert P X0.
induction H.
right.
destruct x.
intros.
case (IHFiniteT (fun x:T => P (Some x))
  (fun x:T => X0 (Some x))).
left.
destruct H0.
exists (Some x).
assumption.
intro.
case (X0 None).
left.
exists None.
assumption.
right.
destruct x.
apply H0.
assumption.
destruct H0.
intros.
case (IHFiniteT (fun x:X => P (f x))
  (fun x:X => X0 (f x))).
left.
destruct H2.
exists (f x).
assumption.
right.
intro.
rewrite <- H1 with x.
apply H2.
Qed.

Lemma finite_dec_forall: forall (X:Type) (P:X->Prop),
  FiniteT X -> (forall x:X, { P x } + { ~ P x }) ->
  { forall x:X, P x } + { exists x:X, ~ P x }.
Proof.
intros.
apply exclusive_dec.
intuition.
destruct H2.
contradiction (H1 x).

revert P X0.
induction H.
left.
destruct x.
intros.
case (IHFiniteT (fun x:T => P (Some x))
  (fun x:T => X0 (Some x))).
intro.
case (X0 None).
left.
destruct x.
apply H0.
assumption.
right.
exists None.
assumption.
right.
destruct H0.
exists (Some x).
assumption.

intros.
destruct H0.
case (IHFiniteT (fun x:X => P (f x))
  (fun x:X => X0 (f x))).
left.
intro y.
rewrite <- H1.
apply H2.
right.
destruct H2.
exists (f x).
assumption.
Qed.

Lemma finite_eq_dec: forall X:Type, FiniteT X ->
  forall x y:X, {x=y} + {x<>y}.
Proof.
intros.
apply decidable_dec.
induction H.
destruct x.
decide equality.

destruct H0.
case (IHFiniteT (g x) (g y)).
left.
rewrite <- H1.
rewrite <- H1 with x.
rewrite H2.
reflexivity.
right.
contradict H2.
rewrite H2.
reflexivity.
Qed.

Lemma finite_dep_choice: forall (A:Type) (B:forall x:A, Type)
  (R:forall x:A, B x->Prop),
  FiniteT A -> (forall x:A, exists y:B x, R x y) ->
  exists f:(forall x:A, B x), forall x:A, R x (f x).
Proof.
intros.
revert B R H0.
induction H.
intros.
exists (fun x:False => False_rect (B x) x).
destruct x.
intros.
pose proof (IHFiniteT (fun x:T => B (Some x))
  (fun x:T => R (Some x))
  (fun x:T => H0 (Some x))).
destruct H1.
pose proof (H0 None).
destruct H2.
exists (fun y:option T =>
  match y return (B y) with
  | Some y0 => x y0
  | None => x0
  end).
destruct x1.
apply H1.
assumption.

intros.
destruct H0.
pose proof (IHFiniteT (fun x:X => B (f x))
  (fun x:X => R (f x))
  (fun x:X => H1 (f x))).
destruct H3.
pose (f0 := fun y:Y => x (g y)).
pose (conv := fun (y:Y) (a:B (f (g y))) =>
  eq_rect (f (g y)) B a y (H2 y)).

exists (fun y:Y => conv y (x (g y))).
intro.
unfold conv; simpl.
generalize (H2 x0).
pattern x0 at 2 3 6.
rewrite <- H2.
intro.
rewrite <- eq_rect_eq.
apply H3.
Qed.

Lemma finite_choice : forall (A B:Type) (R:A->B->Prop),
  FiniteT A -> (forall x:A, exists y:B, R x y) ->
  exists f:A->B, forall x:A, R x (f x).
Proof.
intros.
apply finite_dep_choice.
assumption.
assumption.
Qed.

Lemma Finite_ens_type: forall {X:Type} (S:Ensemble X),
  Finite _ S -> FiniteT { x:X | In S x }.
Proof.
intros.
induction H.
apply bij_finite with False (False_rect _).
constructor.
assert (g:{x:X | In Empty_set x}->False).
intro.
destruct X0.
destruct i.
exists g.
destruct x.
destruct y.
destruct g.

assert (Included A (Add A x)).
auto with sets.
assert (In (Add A x) x).
auto with sets.
pose (g := fun (y: option {x:X | In A x}) =>
  match y return {x0:X | In (Add A x) x0} with
  | Some (exist y0 i) => exist (fun x2:X => In (Add A x) x2) y0 (H1 y0 i)
  | None => exist (fun x2:X => In (Add A x) x2) x H2
  end).
apply bij_finite with _ g.
apply add_finite.
assumption.

assert (h:forall x0:X, In (Add A x) x0 ->
  { In A x0 } + { x0 = x }).
intros; apply exclusive_dec.
intuition.
destruct H6; auto.
destruct H3.
left; assumption.
right; destruct H3; reflexivity.

pose (ginv := fun s:{x0:X | In (Add A x) x0} =>
  match s return option {x:X | In A x} with
  | exist x0 i => match (h x0 i) with
                  | left iA => Some (exist _ x0 iA)
                  | right _ => None
                  end
  end).
exists ginv.
intro; destruct x0.
destruct s.
simpl.
remember (h x0 (H1 x0 i)) as sum; destruct sum.
destruct (proof_irrelevance _ i i0).
reflexivity.
contradiction H0.
rewrite <- e; assumption.
simpl.
remember (h x H2) as sum; destruct sum.
contradiction H0.
reflexivity.

intro.
unfold ginv.
destruct y.
destruct (h x0 i).
simpl.
generalize (H1 x0 i0); intro.
destruct (proof_irrelevance _ i i1).
reflexivity.
simpl.
destruct e.
destruct (proof_irrelevance _ H2 i).
reflexivity.
Qed.

Lemma FiniteT_img: forall (X Y:Type) (f:X->Y),
  FiniteT X -> (forall y1 y2:Y, y1=y2 \/ y1<>y2) ->
  Finite _ (Im Full_set f).
Proof.
intros.
induction H.
assert (Im Full_set f = Empty_set).
apply Extensionality_Ensembles.
red; split.
red; intros.
destruct H.
destruct x.
auto with sets.
rewrite H.
constructor.

assert ({exists x:T, f (Some x) = f None} +
        {forall x:T, f (Some x) <> f None}).
apply finite_dec_exists.
assumption.
intro.
apply decidable_dec.
apply H0.
case H1.
intro.
pose (g := fun (x:T) => f (Some x)).
assert (Im Full_set f =
        Im Full_set g).
apply Extensionality_Ensembles.
red; split.
red; intros.
destruct H2.
destruct x.
exists t.
constructor.
assumption.
destruct e.
exists x.
constructor.
transitivity (f None).
assumption.
symmetry; assumption.
red; intros.
destruct H2.
exists (Some x).
constructor.
assumption.
rewrite H2.
apply IHFiniteT.

intros.
pose (g := fun x:T => f (Some x)).
assert (Im Full_set f =
  Add (Im Full_set g) (f None)).
apply Extensionality_Ensembles.
red; split.
red; intros.
destruct H2.
destruct x.
left.
exists t.
constructor.
assumption.
right.
auto with sets.
red; intros.
destruct H2.
destruct H2.
exists (Some x).
constructor.
assumption.
destruct H2.
exists None.
constructor.
reflexivity.
rewrite H2.
constructor.
apply IHFiniteT.
red; intro.
destruct H3.
contradiction (n x).
symmetry; assumption.

pose (g := fun (x:X) => f (f0 x)).
assert (Im Full_set f = Im Full_set g).
apply Extensionality_Ensembles.
red; split.
red; intros.
destruct H2.
destruct H1.
rewrite H3.
rewrite <- H4 with x.
exists (g0 x).
constructor.
unfold g.
reflexivity.
red; intros.
destruct H2.
exists (f0 x).
constructor.
assumption.

rewrite H2.
apply IHFiniteT.
Qed.

Lemma surj_finite: forall (X Y:Type) (f:X->Y),
  FiniteT X -> surjective f ->
  (forall y1 y2:Y, y1=y2 \/ y1<>y2) ->
  FiniteT Y.
Proof.
intros.
apply bij_finite with {y:Y | In (Im Full_set f) y}
  (@proj1_sig _ (fun y:Y => In (Im Full_set f) y)).
apply Finite_ens_type.
apply FiniteT_img.
assumption.
assumption.
assert (forall y:Y, In (Im Full_set f) y).
intro.
destruct (H0 y).
exists x; auto with sets.
constructor.

pose (proj1_sig_inv := fun y:Y =>
  exist (fun y0:Y => In (Im Full_set f) y0) y (H2 y)).
exists proj1_sig_inv.
destruct x.
simpl.
unfold proj1_sig_inv.
destruct (proof_irrelevance _ (H2 x) i); trivial.
intros; simpl; reflexivity.
Qed.

Lemma finite_subtype: forall (X:Type) (P:X->Prop),
  FiniteT X -> (forall x:X, P x \/ ~ P x) ->
  FiniteT {x:X | P x}.
Proof.
intros.
induction H.
apply bij_finite with False (False_rect _).
constructor.
exists (@proj1_sig _ _).
destruct x.
intro s; destruct s; destruct x.

destruct (H0 None).
pose (g := fun (x:option {x:T | P (Some x)}) =>
  match x return {x:option T | P x} with
  | Some (exist x0 i) => exist (fun x:option T => P x) (Some x0) i
  | None => exist (fun x:option T => P x) None H1
  end).
apply bij_finite with _ g.
apply add_finite.
apply IHFiniteT.
intro; apply H0.
pose (ginv := fun (s:{x0:option T | P x0}) =>
  match s return option {x:T | P (Some x)} with
  | exist (Some x0) i => Some (exist (fun y:T => P (Some y)) x0 i)
  | exist None _ => None
  end).
exists ginv.
destruct x as [[x0]|].
simpl.
reflexivity.
simpl.
reflexivity.
destruct y as [[x0|]].
simpl.
reflexivity.
simpl.
destruct (proof_irrelevance _ H1 p).
reflexivity.

pose (g := fun (x:{x:T | P (Some x)}) =>
  match x return {x:option T | P x} with
    | exist x0 i => exist (fun x:option T => P x) (Some x0) i
  end).
apply bij_finite with _ g.
apply IHFiniteT.
intro; apply H0.
pose (ginv := fun s:{x0:option T | P x0} =>
  match s return {x:T | P (Some x)} with
    | exist (Some x0) i => exist (fun x:T => P (Some x)) x0 i
    | exist None i => False_rect _ (H1 i)
  end).
exists ginv.
destruct x; simpl.
reflexivity.
destruct y as [[x0|]].
simpl.
reflexivity.
contradiction H1.

pose (g := fun (x:{x:X | P (f x)}) =>
  match x with
  | exist x0 i => exist (fun x:Y => P x) (f x0) i
  end).
apply bij_finite with _ g.
apply IHFiniteT.
intro; apply H0.
destruct H1.
assert (forall y:Y, P y -> P (f (g0 y))).
intros; rewrite H2; assumption.
pose (ginv := fun (y:{y:Y | P y}) =>
  match y with
  | exist y0 i => exist (fun x:X => P (f x)) (g0 y0) (H3 y0 i)
  end).
exists ginv.
destruct x; simpl.
generalize (H3 (f x) p).
rewrite H1.
intro; destruct (proof_irrelevance _ p p0).
reflexivity.

destruct y; simpl.
generalize (H3 x p).
rewrite H2.
intro; destruct (proof_irrelevance _ p p0).
reflexivity.
Qed.

Lemma inj_finite: forall (X Y:Type) (f:X->Y),
  FiniteT Y -> FunctionProperties.injective f ->
  (forall y:Y, (exists x:X, f x = y) \/
               (~ exists x:X, f x = y)) ->
  FiniteT X.
Proof.
intros.
assert (forall y:{y:Y | exists x:X, f x = y}, {x:X | f x = proj1_sig y}).
intro.
destruct y.
simpl.

apply constructive_definite_description.
destruct e.
exists x0.
red; split.
assumption.
intros.
apply H0.
transitivity x.
assumption.
symmetry; assumption.

pose (g := fun y:{y:Y | exists x:X, f x = y} =>
  proj1_sig (X0 y)).
apply bij_finite with _ g.
apply finite_subtype.
assumption.
assumption.

pose (ginv := fun (x:X) => exist (fun y:Y => exists x:X, f x = y)
  (f x) (ex_intro _ x (refl_equal _))).
exists ginv.
destruct x as [y [x e]].
unfold g; simpl.
match goal with |- context [X0 ?arg] => destruct (X0 arg) end.
simpl.
unfold ginv; simpl.
simpl in e0.
repeat match goal with |- context [ex_intro ?f ?x ?e] =>
  generalize (ex_intro f x e) end.
rewrite <- e0.
intros; destruct (proof_irrelevance _ e1 e2).
reflexivity.

intro; unfold ginv.
unfold g; simpl.
match goal with |- context [X0 ?arg] => destruct (X0 arg) end.
simpl.
simpl in e.
auto.
Qed.

Lemma finite_inj_surj: forall (X:Type) (f:X->X),
  FiniteT X -> injective f -> surjective f.
Proof.
intros.
induction H.
red.
destruct y.

remember (f None) as f0; destruct f0 as [a|].
assert (forall x:T, f (Some x) <> Some a).
unfold not; intros.
assert (Some x = None).
apply H0.
congruence.
discriminate H2.
pose (g := fun x:T => match f (Some x) with
  | Some y => y
  | None => a
end).
assert (surjective g).
apply IHFiniteT.
red; intros.
remember (f (Some x1)) as fx1; destruct fx1;
remember (f (Some x2)) as fx2; destruct fx2.
unfold g in H2.
rewrite <- Heqfx1 in H2; rewrite <- Heqfx2 in H2.
destruct H2; assert (f (Some x1) = f (Some x2)).
congruence.
apply H0 in H2.
injection H2; trivial.

unfold g in H2; rewrite <- Heqfx1 in H2; rewrite <- Heqfx2 in H2.
destruct H2.
contradiction (H1 x1).
symmetry; assumption.

unfold g in H2; rewrite <- Heqfx1 in H2; rewrite <- Heqfx2 in H2.
destruct H2.
contradiction (H1 x2).
symmetry; assumption.

assert (Some x1 = Some x2).
apply H0.
congruence.
injection H3; trivial.

red; intro.
destruct y.
case (finite_eq_dec _ H t a).
exists None.
congruence.
destruct (H2 t).
exists (Some x).
unfold g in H3.
destruct (f (Some x)).
congruence.
contradiction n.
symmetry; assumption.
destruct (H2 a).
exists (Some x).
unfold g in H3.
remember (f (Some x)) as fx; destruct fx.
destruct H3.
contradiction (H1 x).
symmetry; assumption.
reflexivity.

assert (forall x:T, { y:T | f (Some x) = Some y }).
intros.
remember (f (Some x)) as fx; destruct fx.
exists t; reflexivity.
assert (Some x = None).
apply H0.
congruence.
discriminate H1.
pose (g := fun x:T => proj1_sig (X x)).
assert (surjective g).
apply IHFiniteT.
red; intros.
unfold g in H1.
repeat destruct X in H1.
simpl in H1.
assert (Some x1 = Some x2).
apply H0.
congruence.
injection H2; trivial.

red; intro.
destruct y.
destruct (H1 t).
unfold g in H2; destruct X in H2.
simpl in H2.
exists (Some x).
congruence.
exists None.
symmetry; assumption.

destruct H1.

pose (f' := fun (x:X) => g (f (f0 x))).
assert (surjective f').
apply IHFiniteT.
red; intros.
unfold f' in H3.
assert (f (f0 x1) = f (f0 x2)).
congruence.
apply H0 in H4.
congruence.

red; intro.
destruct (H3 (g y)).
unfold f' in H4.
exists (f0 x).
congruence.
Qed.

Lemma finite_surj_inj: forall (X:Type) (f:X->X),
  FiniteT X -> surjective f -> FunctionProperties.injective f.
Proof.
intros.
assert (exists g:X->X, forall x:X, f (g x) = x).
apply finite_choice with (R:=fun (x y:X) => f y = x).
assumption.
assumption.
destruct H1 as [g].
assert (surjective g).
apply finite_inj_surj.
assumption.
red; intros.
rewrite <- H1 with x1.
rewrite <- H1 with x2.
rewrite H2; reflexivity.
red; intros.
destruct (H2 x1).
destruct (H2 x2).
rewrite <- H4 in H3.
rewrite <- H5 in H3.
repeat rewrite H1 in H3.
rewrite <- H4.
rewrite <- H5.
rewrite H3.
reflexivity.
Qed.

Lemma finite_sum: forall X Y:Type, FiniteT X -> FiniteT Y ->
  FiniteT (X+Y).
Proof.
intros.
induction H0.
apply bij_finite with _ inl.
assumption.
pose (g := fun (x:X+False) => match x with
  | inl x => x
  | inr f => False_rect X f
end).
exists g.
intro; simpl.
reflexivity.
destruct y.
simpl.
reflexivity.
destruct f.

pose (g := fun (x:option (X+T)) => match x with
  | Some (inl x) => inl _ x
  | Some (inr t) => inr _ (Some t)
  | None => inr _ None
  end).
apply bij_finite with _ g.
apply add_finite.
assumption.
pose (ginv := fun (x:X + option T) => match x with
  | inl x => Some (inl _ x)
  | inr (Some t) => Some (inr _ t)
  | inr None => None
  end).
exists ginv.
destruct x as [[x|t]|]; trivial.
destruct y as [x|[t|]]; trivial.

pose (g := fun (x:X+X0) => match x with
  | inl x0 => inl _ x0
  | inr x0 => inr _ (f x0)
  end).
destruct H1.
pose (ginv := fun (x:X+Y) => match x with
  | inl x0 => inl _ x0
  | inr y0 => inr _ (g0 y0)
  end).
apply bij_finite with _ g.
assumption.
exists ginv.
destruct x as [x0|x0]; trivial.
simpl.
rewrite H1; reflexivity.
destruct y as [x|y0]; trivial.
simpl.
rewrite H2; reflexivity.
Qed.

Lemma finite_prod: forall (X Y:Type), FiniteT X -> FiniteT Y ->
  FiniteT (X*Y).
Proof.
intros.
induction H0.
apply bij_finite with _ (False_rect _).
constructor.
exists (@snd X False).
destruct x.
destruct y.
destruct f.

pose (g := fun (x:X*T + X) => match x with
  | inl (pair x0 t) => pair x0 (Some t)
  | inr x0 => pair x0 None
  end).
pose (ginv := fun (x:X * option T) => match x with
  | (x0, Some t) => inl _ (x0, t)
  | (x0, None) => inr _ x0
  end).
apply bij_finite with _ g.
apply finite_sum.
assumption.
assumption.
exists ginv.
destruct x as [[x0 t]|x0]; trivial.
destruct y as [x0 [t|]]; trivial.

pose (g := fun (y:X*X0) => match y with
  | pair x x0 => pair x (f x0)
  end).
destruct H1.
pose (ginv := fun (y:X*Y) => let (x,y0) := y in
  (x, g0 y0)).
apply bij_finite with _ g.
assumption.
exists ginv.
destruct x as [x x0]; unfold ginv, g; try rewrite H1; trivial.
destruct y as [x y]; unfold ginv, g; try rewrite H2; trivial.
Qed.

Require Import FunctionalExtensionality.

Lemma finite_exp: forall X Y:Type, FiniteT X -> FiniteT Y ->
  FiniteT (X->Y).
Proof.
intros.
induction H.
pose (g := fun (x:True) (f:False) => False_rect Y f).
pose (ginv := fun (_:False->Y) => I).
apply bij_finite with _ g.
apply True_finite.
exists ginv.
destruct x as [].
trivial.
intro; extensionality f.
destruct f.

pose (g := fun (p:(T->Y)*Y) (x:option T) =>
  let (f,y0) := p in
  match x with
  | Some x0 => f x0
  | None => y0
  end).
pose (ginv := fun (f:option T->Y) =>
  (fun x:T => f (Some x), f None)).
apply bij_finite with _ g.
apply finite_prod.
assumption.
assumption.
exists ginv.
destruct x as [f y0]; try extensionality t;
try destruct t as [t0|]; trivial.
intro.
extensionality t; destruct t as [t0|]; trivial.

destruct H1.
pose (g0 := fun (h:X->Y) (y:Y0) => h (g y)).
apply bij_finite with _ g0.
assumption.
pose (g0inv := fun (h:Y0->Y) (x:X) => h (f x)).
exists g0inv.
intro.
extensionality x0; unfold g0; unfold g0inv; simpl.
rewrite H1; reflexivity.
intro.
extensionality y0; unfold g0; unfold g0inv; simpl.
rewrite H2; reflexivity.
Qed.

Lemma FiniteT_has_nat_cardinal: forall X:Type, FiniteT X ->
  exists! n:nat, cardinal _ (@Full_set X) n.
Proof.
intros.
apply -> unique_existence; split.
apply finite_cardinal.
pose (idX := fun x:X => x).
assert (Im Full_set idX = Full_set).
apply Extensionality_Ensembles.
red; split.
red; intros; constructor.
red; intros.
exists x.
constructor.
trivial.

rewrite <- H0.
apply FiniteT_img with (f:=fun x:X => x).
assumption.
intros.
case (finite_eq_dec X H y1 y2); tauto.

red; intros.
apply cardinal_unicity with X Full_set; trivial.
Qed.

Definition FiniteT_nat_cardinal (X:Type) (H:FiniteT X) : nat :=
  proj1_sig (constructive_definite_description _
              (FiniteT_has_nat_cardinal X H)).
Lemma FiniteT_nat_cardinal_def: forall (X:Type) (H:FiniteT X),
  cardinal _ (@Full_set X) (FiniteT_nat_cardinal X H).
Proof.
intros; unfold FiniteT_nat_cardinal.
destruct constructive_definite_description.
assumption.
Qed.
Lemma FiniteT_nat_cardinal_cond: forall (X:Type) (H:FiniteT X)
  (n:nat),
  cardinal _ (@Full_set X) n ->
  FiniteT_nat_cardinal X H = n.
Proof.
intros.
pose proof (FiniteT_has_nat_cardinal X H).
destruct H1.
red in H1.
destruct H1.
transitivity x.
symmetry; apply H2.
apply FiniteT_nat_cardinal_def.
apply H2; trivial.
Qed.

Lemma FiniteT_nat_cardinal_False:
  FiniteT_nat_cardinal False empty_finite = 0.
Proof.
apply FiniteT_nat_cardinal_cond.
assert (@Full_set False = @Empty_set False).
apply Extensionality_Ensembles; red; split; auto with sets.
red; intros.
destruct x.
rewrite H.
constructor.
Qed.

Lemma injection_preserves_cardinal: forall (X Y:Type)
  (f:X->Y) (n:nat) (S:Ensemble X), cardinal _ S n ->
  injective f -> cardinal _ (Im S f) n.
Proof.
intros.
induction H.
assert (Im Empty_set f = Empty_set).
apply Extensionality_Ensembles; split; auto with sets.
red; intros.
destruct H.
destruct H.
rewrite H; constructor.
assert (Im (Add A x) f = Add (Im A f) (f x)).
apply Extensionality_Ensembles; split.
red; intros.
destruct H2.
symmetry in H3; destruct H3.
destruct H2.
left; exists x0; auto with sets.
destruct H2; right; auto with sets.
red; intros.
destruct H2.
destruct H2.
exists x0.
left; auto with sets.
assumption.
destruct H2.
exists x; trivial; right; auto with sets.
rewrite H2.
constructor; trivial.
red; intro H3; inversion H3.
apply H0 in H5; destruct H5.
contradiction H1.
Qed.

Lemma FiniteT_nat_cardinal_option:
  forall (X:Type) (H:FiniteT X),
  FiniteT_nat_cardinal (option X) (add_finite X H) =
  S (FiniteT_nat_cardinal X H).
Proof.
intros.
apply FiniteT_nat_cardinal_cond.
assert (Full_set =
        Add (Im Full_set (@Some X)) None).
apply Extensionality_Ensembles; split.
red; intros.
destruct x.
left; exists x; constructor.
right; constructor.
red; intros; constructor.
rewrite H0.
constructor.
apply injection_preserves_cardinal.
apply FiniteT_nat_cardinal_def.
red; intros x1 x2 Heq; injection Heq; trivial.
red; intro.
inversion H1.
discriminate H3.
Qed.

Lemma FiniteT_nat_cardinal_bijection:
  forall (X Y:Type) (H:FiniteT X) (g:X->Y) (Hinv:invertible g),
    FiniteT_nat_cardinal Y (bij_finite X Y g H Hinv) =
    FiniteT_nat_cardinal X H.
Proof.
intros.
apply FiniteT_nat_cardinal_cond.
apply invertible_impl_bijective in Hinv.
destruct Hinv as [g_inj g_surj].
assert (Full_set = Im Full_set g).
apply Extensionality_Ensembles; split; red; intros;
  try constructor.
destruct (g_surj x).
exists x0; try constructor; auto.
rewrite H0; apply injection_preserves_cardinal; trivial.
apply FiniteT_nat_cardinal_def.
Qed.

Lemma unique_FiniteT_nat_cardinal:
  exists! f: (forall (X:Type), FiniteT X -> nat),
  f False empty_finite = 0 /\
  (forall (X:Type) (H:FiniteT X),
     f (option X) (add_finite X H) = S (f X H)) /\
  (forall (X Y:Type) (H:FiniteT X) (g:X->Y) (Hinv:invertible g),
     f Y (bij_finite X Y g H Hinv) = f X H).
Proof.
match goal with |- @ex ?T (@unique ?T ?f) =>
  apply -> (@unique_existence T f) end.
split.
exists FiniteT_nat_cardinal.
repeat split.
exact FiniteT_nat_cardinal_False.
exact FiniteT_nat_cardinal_option.
exact FiniteT_nat_cardinal_bijection.
red; intros f g Hf Hg.
destruct Hf as [HFalse_f [Hoption_f Hbijection_f]].
destruct Hg as [HFalse_g [Hoption_g Hbijection_g]].
extensionality X; extensionality HFinite.
generalize HFinite.
induction HFinite.
intro.
destruct (proof_irrelevance _ empty_finite HFinite).
congruence.
intro.
destruct (proof_irrelevance _ (add_finite T HFinite) HFinite0).
rewrite Hoption_f. rewrite Hoption_g. rewrite IHHFinite. reflexivity.
intro.
destruct (proof_irrelevance _ (bij_finite _ _ f0 HFinite H) HFinite0).
now rewrite Hbijection_f, Hbijection_g, IHHFinite.
Qed.


From Hammer Require Import Hammer.

Global Set Automatic Coercions Import.
Set Implicit Arguments.

Require Import Arith.
Require Compare_dec.
Require EqNat.
Require Import Omega.

Fixpoint cond_eq (T: nat -> Set) n m {struct n}: forall c, T (c + n) -> T (c + m) -> Prop :=
match n, m return forall c, T (c + n) -> T (c + m) -> Prop with
| 0, 0 => fun c x y => x = y
| S n', S m' => fun c x y => cond_eq T n' m' (S c)
(eq_rec_r T x (plus_n_Sm c n'))
(eq_rec_r T y (plus_n_Sm c m'))
| _, _ => fun _ _ _ => True
end.

Lemma cond_eq_eq (T: nat -> Set) n c (x y: T (c + n)): cond_eq T n n c x y = (x = y).
Proof with auto. hammer_hook "nat_below" "nat_below.cond_eq_eq".
induction n in c, x, y |- *...
simpl.
intros.
rewrite IHn.
unfold eq_rec_r.
unfold eq_rec.
unfold eq_rect.
simpl plus.
case (sym_eq (plus_n_Sm c n))...
Qed.

Lemma cond_eq_neq (T: nat -> Set) n m c (x: T (c + n)) (y: T (c + m)): n <> m -> cond_eq T n m c x y = True.
Proof with auto. hammer_hook "nat_below" "nat_below.cond_eq_neq".
induction n in m, c, x, y |- *...
destruct m...
intros.
elimtype False...
destruct m...
intros.
simpl.
apply IHn.
intro.
apply H.
subst...
Qed.

Inductive natBelow: nat -> Set := mkNatBelow (v p: nat): natBelow (S (v + p)).

Definition nb_val {n: nat} (nb: natBelow n): nat := match nb with mkNatBelow m _ => m end.

Coercion nb_val: natBelow >-> nat.

Lemma natBelow_unique n (x y: natBelow n): nb_val x = nb_val y -> x = y.
Proof with auto. hammer_hook "nat_below" "nat_below.natBelow_unique".
cut (forall n (x: natBelow n) m (y: natBelow m), nb_val x = nb_val y -> cond_eq natBelow n m 0 x y); [|clear x y]; intros.
set (H n x n y H0).
rewrite cond_eq_eq in c...
destruct x.
destruct y.
simpl in H.
subst.
destruct (eq_nat_dec p p0).
subst.
rewrite cond_eq_eq...
rewrite cond_eq_neq...
intro.
omega.
Qed.

Lemma natBelow_uneq n (x y: natBelow n): nb_val x <> nb_val y -> x <> y.
Proof. hammer_hook "nat_below" "nat_below.natBelow_uneq". intros. intro. subst. auto. Qed.

Lemma natBelow_eq_dec n (x y: natBelow n): { x = y } + { x <> y }.
Proof with auto. hammer_hook "nat_below" "nat_below.natBelow_eq_dec".
intros. destruct (eq_nat_dec x y); [left | right].
apply natBelow_unique...
apply natBelow_uneq...
Qed.

Definition nb0 n: natBelow (S n) := mkNatBelow 0 n.

Definition Snb n (nb: natBelow n): natBelow (S n) :=
match nb in (natBelow n0) return (natBelow (S n0)) with
| mkNatBelow v p => mkNatBelow (S v) p
end.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal50.

Set Printing Depth 1000.
Definition lfind_eval  x y:=
count y x.

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))).

Compute lfind_eval  (Zero) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Succ (Succ Zero)) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero (Cons (Succ Zero) Nil)))).

Compute lfind_eval  (Succ Zero) (Cons Zero (Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))))).

Compute lfind_eval  (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Zero) (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ (Succ Zero)) Nil))).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil))).

Compute lfind_eval  (Succ Zero) (Cons Zero (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))))).

Compute lfind_eval  (Succ (Succ Zero)) (Nil).

Compute lfind_eval  (Zero) (Nil).


From stdpp Require Import relations.
Require Import st.prelude.generic.

Definition at_least_one {A : Type} (R : relation A) : relation A :=
  fun x y => ∃ n, 1 ≤ n ∧ nsteps R n x y.

Lemma at_least_one_once {A : Type} (R : relation A) (x y : A) : R x y → at_least_one R x y.
Proof. intros. exists 1. split; [lia | ]. by apply nsteps_once. Qed.

Lemma at_least_one_l {A : Type} (R : relation A) (x y z : A) : R x y → rtc R y z → at_least_one R x z.
Proof. intros. destruct (iffLR (rtc_nsteps _ _) H0) as [n Hn]. exists (S n). split; [lia | ]. eapply nsteps_l; eauto. Qed.

Lemma at_least_one_r {A : Type} (R : relation A) (x y z : A) : rtc R x y → R y z → at_least_one R x z.
Proof. intros. destruct (iffLR (rtc_nsteps _ _) H) as [n Hn]. exists (S n). split; [lia | ]. eapply nsteps_r; eauto. Qed.

Definition at_least_one_rtc {A : Type} (R : relation A) x y : at_least_one R x y → rtc R x y.
Proof. destruct 1 as [n [_ H]]. eapply rtc_nsteps. eauto. Qed.

Definition at_least_one_nsteps {A : Type} (R : relation A) x y : at_least_one R x y → ∃ n, nsteps R n x y.
Proof. eauto. destruct 1 as [n [_ H]]. eauto. Qed.

Lemma at_least_one_split_l {A : Type} (R : relation A) x z : at_least_one R x z → ∃ y, R x y ∧ rtc R y z.
Proof. destruct 1 as [n [H H']]. destruct H'. lia. exists y. split; auto. eapply rtc_nsteps. eauto. Qed.

Lemma at_least_one_split_r {A : Type} (R : relation A) x z : at_least_one R x z → ∃ y, rtc R x y ∧ R y z.
Proof. destruct 1 as [n [H H']]. destruct n. lia. destruct (nsteps_inv_r _ _ _ H') as [y [P P']]. exists y. split; auto. by eapply rtc_nsteps; eauto. Qed.


Set Warnings "-notation-overridden".
Require Export Coq.ZArith.ZArith.
Require Export Coq.Lists.List.
Require Import Tweetnacl.Libs.Decidable.
Require Import Tweetnacl.Libs.Expr_Decidable.
Require Import Tweetnacl.Libs.Term_Decidable.
Require Import Tweetnacl.Libs.Formula_Decidable.
Require Import Tweetnacl.Libs.Lists_extended.
Require Import ssreflect.

Open Scope Z_scope.

Section list_denote.

Context {T} {U} {inst : @Decidable T U}.

Fixpoint list_denote env (l: list T) : list U :=
  match l with
    | nil => nil
    | h :: q => (denote env h) :: list_denote env q
  end.

(*****************************************************************************************
 *   DECIDE EQUALITY
 *)

Fixpoint list_decide (l l' : list T) : bool := match l, l' with
  | nil, nil => true
  | a :: qa , b :: qb => andb (decide a b) (list_decide qa qb)
  | _, _ => false
  end.

Lemma list_decide_impl:
  forall env a b,
    list_decide a b = true ->
    list_denote env a = list_denote env b.
Proof.
  induction a as [|a qa IHa] => b H.
  destruct b.
  reflexivity.
  simpl in H ; congruence.
  destruct b.
  simpl in H ; congruence.
  simpl in *.
  apply Bool.andb_true_iff in H.
  destruct H.
  f_equal.
  by apply decide_impl.
  by apply IHa.
Qed.

Lemma list_denote_nth :
  forall i env (l: list T) (d:T), denote env (nth i l d) = nth i (list_denote env l) (denote env d).
Proof.
intros i env l. revert i. induction l as [|h l IHl] ; intros [|i] ; try reflexivity.
simpl. apply IHl.
Qed.

Lemma list_denote_firstn :
  forall i env (l: list T), list_denote env (firstn i l) = firstn i (list_denote env l).
Proof.
intros i env l. revert i. induction l as [|h l IHl] ; intros [|i] ; try reflexivity.
simpl. rewrite IHl ; reflexivity.
Qed.

Lemma list_denote_skipn :
  forall i env (l: list T), list_denote env (skipn i l) = skipn i (list_denote env l).
Proof.
intros i env l. revert i. induction l as [|h l IHl] ; intros [|i] ; try reflexivity.
simpl. rewrite IHl ; reflexivity.
Qed.

Lemma list_denote_map :
  forall env (l: list T), map (denote env) l = (list_denote env l).
Proof.
induction l as [|h l IHl] ; try reflexivity.
simpl. rewrite IHl ; reflexivity.
Qed.

Lemma list_denote_length:
  forall env (l:list T), length (list_denote env l) = length l.
Proof.
intros. rewrite -list_denote_map map_length ; reflexivity.
Qed.

Lemma list_denote_Zlength:
  forall env (l:list T), Zlength (list_denote env l) = Zlength l.
Proof.
intros. rewrite -list_denote_map Zlength_map ; reflexivity.
Qed.

Lemma list_denote_upd_nth :
  forall i env (l: list T) (v:T), list_denote env (upd_nth i l v) = upd_nth i (list_denote env l) (denote env v).
Proof.
intros i env m. revert i. induction m as [|h m IHm] ; intros [|i] v ; try reflexivity.
simpl. f_equal. apply IHm.
Qed.

End list_denote.

(********************************************************************************)

Local Definition ta := Var 1%positive.
Local Definition tb := Var 2%positive.
Local Definition tc := Var 3%positive.
Local Definition td := Var 4%positive.
Local Definition te := Var 5%positive.
Local Definition tf := Var 6%positive.
Local Definition tg := Var 7%positive.

Local Definition expr1 := A (M ta tb) (A (R tc) (R tb)).
Local Definition expr2 := A (A (R tc) (R tb)) (M ta tb).

Local Instance term_dec : Decidable := Build_Decidable _ _ term_decide term_denote term_decide_impl.
Local Instance list_term_dec : Decidable := Build_Decidable (list term) (list Z)
  list_decide list_denote list_decide_impl.

Local Instance expr_dec : Decidable := Build_Decidable _ _ expr_decide expr_denote expr_decide_impl.
Local Instance list_expr_dec : Decidable := Build_Decidable (list expr) (list Z)
  list_decide list_denote list_decide_impl.

Local Example test2: formula_decide (Eq expr1 expr2) = true.
Proof.
by compute.
Qed.

Local Example test3: formula_decide (Eq (expr1::nil) (expr2::nil)) = true.
Proof.
by compute.
Qed.

Close Scope Z.


Require Import List.

Inductive in_list (X : Type) : X -> list X -> Prop :=
  | in_cons_l : forall x l, in_list X x (x::l)
  | in_cons_r : forall x y l, in_list X x l -> in_list X x (y::l).
Implicit Arguments in_list [X].

Lemma in_list_nth (X : Type) (default : X) : forall x l, in_list x l <-> exists n, n < length l /\ x = nth n l default.
Proof.
  intros.
  split.
  - induction l.
    + intro.
      inversion_clear H.
    + intro.
      inversion H ; subst.
      * exists 0.
        split.
        apply PeanoNat.Nat.lt_0_succ.
        reflexivity.
      * apply IHl in H2.
        destruct H2 as [n [H2 H3]].
        exists (S n).
        split.
        now apply (PeanoNat.Nat.succ_lt_mono n _).
        assumption.
  - induction l.
    + intro.
      now destruct H as [n [H _]].
    + intro.
      destruct H as [n [H H0]].
      destruct n.
      * simpl in H0.
        subst.
        apply in_cons_l.
      * apply in_cons_r.
        apply IHl.
        exists n.
        split.
        now apply PeanoNat.Nat.succ_lt_mono.
        assumption.
Qed.
Implicit Arguments in_list_nth [X].

Inductive repeats (X : Type) : list X -> Prop :=
  | repeats_cons_l : forall x l, in_list x l -> repeats X (x::l)
  | repeats_cons_r : forall x l, repeats X l -> repeats X (x::l).
Implicit Arguments repeats [X].

Fixpoint remove_nth (X : Type) n (l : list X) :=
  match n, l with
  | 0, a::l => l
  | S n, a::l => a::(remove_nth X n l)
  | _, nil => nil
  end.
Implicit Arguments remove_nth [X].

Lemma remove_nth_length (X : Type) : forall n (l : list X), n < length l -> length l = S (length (remove_nth n l)).
Proof.
  intros n l.
  revert n.
  induction l.
  - easy.
  - intros.
    simpl.
    apply PeanoNat.Nat.succ_inj_wd.
    + destruct n.
       * easy.
       * now apply IHl, PeanoNat.Nat.succ_lt_mono.
Qed.
Implicit Arguments remove_nth_length [X].

Lemma remove_nth_length_le (X : Type) : forall n (l : list X), length l <= S (length (remove_nth n l)).
Proof.
  intros n l.
  revert n.
  induction l as [|x l] ; intros.
  - apply le_0_n.
  - destruct n.
    + easy.
    + apply le_n_S, IHl.
Qed.
Implicit Arguments remove_nth_length_le [X].

Lemma remove_nth_left (X : Type) (default : X) : forall n l m, m < n -> nth m (remove_nth n l) default = nth m l default.
Proof.
  intros n l.
  revert n.
  induction l as [|x l] ; intros.
  - now destruct n.
  - induction n.
    + easy.
    + apply PeanoNat.Nat.succ_le_mono, PeanoNat.Nat.le_lteq in H.
      destruct H.
      * rewrite <- IHn ; try assumption.
        destruct m.
        -- now destruct n.
        -- simpl.
           destruct n.
           ++ easy.
           ++ simpl remove_nth at 2.
              simpl nth at 2.
              simpl in IHn.
              rewrite IHn ; try assumption.
              now apply IHl, PeanoNat.Nat.lt_le_incl.
      * subst.
        -- destruct n.
           ++ reflexivity.
           ++ assert (n < S n) by constructor.
              now apply IHl in H.
Qed.
Implicit Arguments remove_nth_left [X].

Lemma remove_nth_right (X : Type) (default : X) : forall n l m, n <= m -> nth m (remove_nth n l) default = nth (S m) l default.
Proof.
  intros n l.
  revert n.
  induction l as [|x l] ; intros.
  - now destruct n ; destruct m.
  - simpl.
    destruct m.
    + apply Le.le_n_0_eq in H.
      now subst.
    + destruct n.
      * reflexivity.
      * now apply IHl, PeanoNat.Nat.succ_le_mono.
Qed.
Implicit Arguments remove_nth_right [X].

Definition in_list_decidable (X : Type) := forall (x : X) l, in_list x l \/ ~ in_list x l.

Theorem pigeonhole_classic (X : Type) : in_list_decidable X -> forall (l1 l2 : list X), length l2 < length l1 -> (forall x, in_list x l1 -> in_list x l2) -> repeats l1.
Proof.
  intro H1.
  induction l1.
  - easy.
  - intros.
    pose proof (H1 a l1) as H1.
    destruct H1.
    + now constructor.
    + apply repeats_cons_r.
      assert (in_list a l2) by (apply H0 ; constructor).
      apply (in_list_nth a) in H2.
      destruct H2 as [n H2].
      apply (IHl1 (remove_nth n l2)).
      * unfold lt.
        destruct H2.
        apply remove_nth_length in H2.
        rewrite <- H2.
        now apply Lt.lt_n_Sm_le.
      * intros.
        assert (in_list x (a::l1)) by (now apply in_cons_r).
        apply H0, (in_list_nth a) in H4.
        destruct H4 as [m H4].
        destruct (PeanoNat.Nat.lt_trichotomy m n) as [?|[?|?]].
        -- apply (in_list_nth a).
           exists m.
           split.
           ++ destruct H2.
              apply (PeanoNat.Nat.le_lt_trans (S m) _ (length l2)) in H5 ; try assumption.
              pose proof (remove_nth_length_le n l2).
              now apply PeanoNat.Nat.succ_lt_mono, PeanoNat.Nat.lt_le_trans with (length l2).
           ++ destruct H4.
              subst.
              now apply eq_sym, remove_nth_left.
        -- subst.
           elim H1.
           destruct H2.
           destruct H4.
           rewrite H5.
           now rewrite <- H6.
        -- destruct m.
           ++ easy.
           ++ apply (in_list_nth a).
              exists m.
              split ; destruct H4.
              ** pose proof (remove_nth_length_le n l2).
                 apply (PeanoNat.Nat.lt_le_trans _ _ (S (length (remove_nth n l2)))) in H4 ; try assumption.
                 now apply PeanoNat.Nat.succ_lt_mono.
              ** subst.
                 now apply eq_sym, remove_nth_right, PeanoNat.Nat.succ_le_mono.
Qed.

Lemma pigeonhole_aux (X : Type) (default : X) : forall (l1 l2 : list X),
  (forall x, in_list x l1 -> in_list x l2) ->
  (exists l3 : list nat, length l3 = length l1 /\ (forall n, n < length l3 -> nth n l3 0 < length l2) /\ (forall n, n < length l3 -> nth (nth n l3 0) l2 default = nth n l1 default) /\ (repeats l3 -> repeats l1)).
Proof.
  induction l1.
  - intros.
    now exists nil.
  - intros.
    destruct (IHl1 l2) as [l3 ?].
    + intros.
      apply H.
      now constructor.
    + assert (in_list a (a::l1)) by constructor.
      apply H, (in_list_nth default) in H1.
      destruct H1 as [n []].
      exists (n::l3).
      destruct H0 as [?[?[]]].
      assert ((forall n0 : nat, n0 < length (n :: l3) -> nth (nth n0 (n :: l3) 0) l2 default = nth n0 (a :: l1) default)).
        induction n0 ; intro.
        easy.
        now apply H4, PeanoNat.Nat.succ_lt_mono.
      repeat split.
      * simpl.
        now rewrite H0.
      * destruct n0 ; intro.
        -- assumption.
        -- now apply H3, PeanoNat.Nat.succ_lt_mono.
      * assumption.
      * intros.
        inversion_clear H7.
        -- apply repeats_cons_l, (in_list_nth default).
           apply (in_list_nth 0) in H8.
           destruct H8 as [m []].
           pose proof (H6 (S m)).
           apply PeanoNat.Nat.succ_lt_mono in H7 as ?.
           apply H9 in H10.
           simpl in H10.
           exists m.
           split.
           ++ now rewrite <- H0.
           ++ now rewrite <- H10, <- H8.
        -- now apply repeats_cons_r, H5.
Qed.
Implicit Arguments pigeonhole_aux [X].

Fixpoint enumerate (X : Type) (l : list X) n :=
  match l with
  | nil => nil
  | _::l => n::(enumerate X l (S n))
  end.
Implicit Arguments enumerate [X].

Lemma enumerate_length (X : Type) : forall (l : list X) n, length (enumerate l n) = length l.
Proof.
  induction l ; intros.
  - reflexivity.
  - simpl.
    cut (length (enumerate l (S n)) = length l).
    intro.
    now rewrite H.
    apply IHl.
Qed.

Lemma enumerate_nth (X : Type) : forall n m (l : list X), n < length l -> nth n (enumerate l m) 0 = n + m.
Proof.
  intros n m l.
  revert n m.
  induction l.
  - now intros.
  - induction n ; intros.
    + easy.
    + simpl.
      rewrite IHl.
      easy.
      now apply PeanoNat.Nat.succ_lt_mono.
Qed.
Implicit Arguments enumerate_nth [X].

Lemma in_list_nat_decidable : in_list_decidable nat.
Proof.
  intro n.
  induction l.
  - now right.
  - destruct (PeanoNat.Nat.eq_decidable n a).
    + left.
      subst.
      apply in_cons_l.
    + destruct IHl.
      * left.
        now constructor.
      * right.
        intro.
        apply H0.
        now inversion H1.
Qed.

Theorem pigeonhole (X : Type) : forall l1 l2 : list X,
  length l2 < length l1 ->
  (forall x, in_list x l1 -> in_list x l2) ->
  repeats l1.
Proof.
  intros.
  induction l1.
  - easy.
  - destruct (pigeonhole_aux a (a::l1) l2) as [l3 [?[]]].
    + intros.
      now apply H0.
    + apply H3.
      apply (pigeonhole_classic nat in_list_nat_decidable) with (enumerate l2 0).
      * now rewrite enumerate_length, H1.
      * intros.
        apply (in_list_nth 0) in H4.
        apply (in_list_nth 0).
        destruct H4 as [n []].
        exists x.
        split.
        -- rewrite H5, enumerate_length.
           now apply H2.
        -- induction x.
           now destruct l2.
           rewrite <- (PeanoNat.Nat.add_0_r (S x)) at 1.
           apply eq_sym, enumerate_nth.
           rewrite H5.
           now apply H2.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import BinInt.
Require Import Zeven.
Require Import Zorder.
Require Import Zcompare.
Require Import ZArith_dec.
Require Import Sumbool.

Local Open Scope Z_scope.

(** * Boolean operations from decidability of order *)
(** The decidability of equality and order relations over
    type [Z] gives some boolean functions with the adequate specification. *)

Definition Z_lt_ge_bool (x y:Z) := bool_of_sumbool (Z_lt_ge_dec x y).
Definition Z_ge_lt_bool (x y:Z) := bool_of_sumbool (Z_ge_lt_dec x y).

Definition Z_le_gt_bool (x y:Z) := bool_of_sumbool (Z_le_gt_dec x y).
Definition Z_gt_le_bool (x y:Z) := bool_of_sumbool (Z_gt_le_dec x y).

Definition Z_eq_bool (x y:Z) := bool_of_sumbool (Z.eq_dec x y).
Definition Z_noteq_bool (x y:Z) := bool_of_sumbool (Z_noteq_dec x y).

Definition Zeven_odd_bool (x:Z) := bool_of_sumbool (Zeven_odd_dec x).

(**********************************************************************)
(** * Boolean comparisons of binary integers *)

Notation Zle_bool := Z.leb (only parsing).
Notation Zge_bool := Z.geb (only parsing).
Notation Zlt_bool := Z.ltb (only parsing).
Notation Zgt_bool := Z.gtb (only parsing).

(** We now provide a direct [Z.eqb] that doesn't refer to [Z.compare].
   The old [Zeq_bool] is kept for compatibility. *)

Definition Zeq_bool (x y:Z) :=
  match x ?= y with
    | Eq => true
    | _ => false
  end.

Definition Zneq_bool (x y:Z) :=
  match x ?= y with
    | Eq => false
    | _ => true
  end.

(** Properties in term of [if ... then ... else ...] *)

Lemma Zle_cases n m : if n <=? m then n <= m else n > m.
Proof.
 case Z.leb_spec; now Z.swap_greater.
Qed.

Lemma Zlt_cases n m : if n <? m then n < m else n >= m.
Proof.
 case Z.ltb_spec; now Z.swap_greater.
Qed.

Lemma Zge_cases n m : if n >=? m then n >= m else n < m.
Proof.
 rewrite Z.geb_leb. case Z.leb_spec; now Z.swap_greater.
Qed.

Lemma Zgt_cases n m : if n >? m then n > m else n <= m.
Proof.
 rewrite Z.gtb_ltb. case Z.ltb_spec; now Z.swap_greater.
Qed.

(** Lemmas on [Z.leb] used in contrib/graphs *)

Lemma Zle_bool_imp_le n m : (n <=? m) = true -> (n <= m).
Proof.
 apply Z.leb_le.
Qed.

Lemma Zle_imp_le_bool n m : (n <= m) -> (n <=? m) = true.
Proof.
 apply Z.leb_le.
Qed.

Notation Zle_bool_refl := Z.leb_refl (only parsing).

Lemma Zle_bool_antisym n m :
 (n <=? m) = true -> (m <=? n) = true -> n = m.
Proof.
 rewrite !Z.leb_le. apply Z.le_antisymm.
Qed.

Lemma Zle_bool_trans n m p :
 (n <=? m) = true -> (m <=? p) = true -> (n <=? p) = true.
Proof.
 rewrite !Z.leb_le. apply Z.le_trans.
Qed.

Definition Zle_bool_total x y :
  { x <=? y = true } + { y <=? x = true }.
Proof.
 case_eq (x <=? y); intros H.
 - left; trivial.
 - right. apply Z.leb_gt in H. now apply Z.leb_le, Z.lt_le_incl.
Defined.

Lemma Zle_bool_plus_mono n m p q :
 (n <=? m) = true ->
 (p <=? q) = true ->
 (n + p <=? m + q) = true.
Proof.
 rewrite !Z.leb_le. apply Z.add_le_mono.
Qed.

Lemma Zone_pos : 1 <=? 0 = false.
Proof.
 reflexivity.
Qed.

Lemma Zone_min_pos n : (n <=? 0) = false -> (1 <=? n) = true.
Proof.
 rewrite Z.leb_le, Z.leb_gt. apply Z.le_succ_l.
Qed.

(** Properties in term of [iff] *)

Lemma Zle_is_le_bool n m : (n <= m) <-> (n <=? m) = true.
Proof.
 symmetry. apply Z.leb_le.
Qed.

Lemma Zge_is_le_bool n m : (n >= m) <-> (m <=? n) = true.
Proof.
 Z.swap_greater. symmetry. apply Z.leb_le.
Qed.

Lemma Zlt_is_lt_bool n m : (n < m) <-> (n <? m) = true.
Proof.
 symmetry. apply Z.ltb_lt.
Qed.

Lemma Zgt_is_gt_bool n m : (n > m) <-> (n >? m) = true.
Proof.
 Z.swap_greater. rewrite Z.gtb_ltb. symmetry. apply Z.ltb_lt.
Qed.

Lemma Zlt_is_le_bool n m : (n < m) <-> (n <=? m - 1) = true.
Proof.
 rewrite Z.leb_le. apply Z.lt_le_pred.
Qed.

Lemma Zgt_is_le_bool n m : (n > m) <-> (m <=? n - 1) = true.
Proof.
 Z.swap_greater. rewrite Z.leb_le. apply Z.lt_le_pred.
Qed.

(** Properties of the deprecated [Zeq_bool] *)

Lemma Zeq_is_eq_bool x y : x = y <-> Zeq_bool x y = true.
Proof.
 unfold Zeq_bool.
 rewrite <- Z.compare_eq_iff. destruct Z.compare; now split.
Qed.

Lemma Zeq_bool_eq x y : Zeq_bool x y = true -> x = y.
Proof.
 apply Zeq_is_eq_bool.
Qed.

Lemma Zeq_bool_neq x y : Zeq_bool x y = false -> x <> y.
Proof.
 rewrite Zeq_is_eq_bool; now destruct Zeq_bool.
Qed.

Lemma Zeq_bool_if x y : if Zeq_bool x y then x=y else x<>y.
Proof.
 generalize (Zeq_bool_eq x y) (Zeq_bool_neq x y).
 destruct Zeq_bool; auto.
Qed.


(* begin hide *)
Require Import List.
Require Import Streams.
(* end hide *)

(** * CoLists *)

Module CoList.

  (** ** Defining CoLists *)
  (** A [colist] is defined by analogy to the [Stream] datatype,
      so that we can use the high-level predicates defined in the
      [Coq.Lists.Streams] module. *)

  Notation colist         := Stream.
  Notation cocons         := Cons.
  Notation hd             := hd.
  Notation tl             := tl.
  Notation map            := map.
  Notation Eq             := EqSt.
  Notation Eq_refl        := EqSt_reflex.
  Notation Eq_sym         := sym_EqSt.
  Notation Eq_trans       := trans_EqSt.
  Notation Exists         := Exists.
  Notation Exists_here    := Here.
  Notation Exists_further := Further.
  Notation Forall         := ForAll.
  Notation Always         := HereAndFurther.
  Notation Forall_coind   := ForAll_coind.
  Notation lookup         := Str_nth.

  (** We'd like [lookup] to be transparent. *)

  Hint Unfold lookup.

  (** Constructing [colist]s is done by iteratively unfolding values. *)

  CoFixpoint unfold {A B: Type} (f: B -> (A*B)) (e: B) : colist A :=
    match f e with
      | (x,xs) => cocons  x (unfold f xs)
    end.

  (** Furthermore, we can limit [colist]s to [list]s by taking any finite prefix. *)

  Fixpoint take {A: Type} (n: nat) (xs: colist A) : list A :=
    match n with
      | O => nil
      | S n =>
        match xs with
          | cocons x xs => cons x (take n xs)
        end
    end.

  (** ** Properties on CoLists *)
  (** We need some ways to prove properties on [colist]s.
      The simpelest of such proves is to prove that an [x]
      is an element of a certain [colist].
    *)

  Inductive In {A: Type} (x: A) (xs: colist A) : Prop :=
  | In_here    : (x = hd xs) -> In x xs
  | In_further : In x (tl xs) -> In x xs.

  (** Below we define [At], which turns a witness index into
      a [colist] into a proof that an element is in the [colist]
      (at that position).
    *)

  Definition At : forall {A: Type} (x: A) (xs: colist A) (n: nat), (x = lookup n xs) -> In x xs.
  Proof.
    intros A x xs n; generalize xs; clear xs.
    induction n as [|n].
    - apply In_here.
    - intro xs; destruct xs as [y ys]; unfold lookup in *; simpl in *; intro H.
      apply IHn in H; apply In_further; simpl; assumption.
  Defined.

  (** Furthermore, we define the relations between the [In] predicate,
      and the predefined [Exists] and [Forall] predicates.
    *)

  Theorem In_At : forall {A: Type} (x: A) (xs: colist A),
    In x xs -> exists n, x = lookup n xs.
  Proof.
    intros A x xs H; elim H; clear H xs.
    - intros xs H; exists 0%nat; destruct xs. unfold lookup. simpl in *; assumption.
    - intros xs H IH; elim IH; clear IH; intros n IH; exists (S n).
      unfold lookup in *; simpl in *; assumption.
  Qed.

  Definition At_Exists : forall {A: Type} (P: A -> Prop) (xs: colist A) (n: nat),
    P (lookup n xs) -> Exists (fun l => P (hd l)) xs.
  Proof.
    intros A P xs n; generalize xs; clear xs.
    induction n as [|n].
    - intros xs H; unfold lookup in H; simpl in H.
      apply Exists_here; assumption.
    - intros xs H; unfold lookup in *; simpl in *.
      apply IHn in H; apply Exists_further; assumption.
  Defined.

  Theorem In_Exists : forall {A: Type} (P: A -> Prop) (x: A) (xs: colist A),
    P x /\ In x xs -> Exists (fun l => P (hd l)) xs.
  Proof.
    intros A P x xs H; elim H; clear H; intros HP HM.
    apply In_At in HM; elim HM; clear HM; intros n HM.
    apply (At_Exists P xs n); rewrite HM in HP; assumption.
  Qed.

  Theorem Exists_In : forall {A: Type} (P: A -> Prop) (xs: colist A),
    Exists (fun l => P (hd l)) xs -> exists x, P x /\ In x xs.
  Proof.
    intros A P xs H; elim H; clear H xs.
    - intros xs H; exists (hd xs); split.
      * assumption.
      * apply In_here; reflexivity.
    - intros xs H IH; elim IH; clear IH; intros x IH; elim IH; clear IH.
      intros HP IH; exists x; split.
      * assumption.
      * apply In_further; assumption.
  Qed.

  Lemma Forall_here : forall {A: Type} (P: A -> Prop) xs,
    Forall (fun l => P (hd l)) xs -> P (hd xs).
  Proof.
    intros A P xs H; destruct H; assumption.
  Qed.

  Lemma Forall_further : forall {A: Type} (P: colist A -> Prop) xs,
    Forall P xs -> Forall P (tl xs).
  Proof.
    intros A P xs H; destruct H; assumption.
  Qed.

  Theorem Forall_In : forall {A: Type} (P: A -> Prop) xs,
    Forall (fun l => P (hd l)) xs -> forall x, In x xs -> P x.
  Proof.
    intros A P xs Hall x Hin.
    apply In_At in Hin; elim Hin; intros n Heq.
    generalize Hall Heq; clear Hall Hin Heq.
    generalize xs; clear xs.
    induction n as [|n].
    - intros xs Hall Heq.
      destruct xs as [y ys]; unfold lookup in Heq; simpl in Heq.
      apply Forall_here in Hall; simpl in Hall; rewrite Heq; assumption.
    - intros xs Hall Heq.
      apply Forall_further in Hall; apply IHn in Hall; assumption.
  Qed.

  (** ** Concatinating an infinite list of lists *)
  (** We'll need a function to concatinate an infinite list of lists
      in order to define the naive enumeration of rationals later on.

      We can only do this if we have a guarantee that always,
      eventually there will be some list that isn't [nil], as an infinite
      list of [nil]s would never produce a [cocons].
    *)

  Definition AlwaysExistsNonEmpty {A: Type} (xs: colist (list A)) :=
    Forall (Exists (fun ys => nil <> hd ys)) xs.

  (** However, this notion is rather hard to prove, and since in most
      cases none of the [list]s will be [nil], we'll allow a proof of
      [AlwaysExistsNonEmpty] based on a proof of [AlwaysNonEmpty], using
      the [Always_AlwaysExists] lemma.
    *)

  Definition AlwaysNonEmpty {A: Type} (xs: colist (list A)) :=
    Forall (fun ys => nil <> hd ys) xs.

  Lemma Always_AlwaysExists : forall {A: Type} (P: colist A -> Prop) (xs: colist A),
    Forall P xs -> Forall (Exists P) xs.
  Proof.
    cofix.
    intros A P xs H; case H as [H0 H1].
    constructor.
    - constructor; assumption.
    - apply Always_AlwaysExists in H1; assumption.
  Qed.

  (** Since the [concat] function using proofs of the type [AlwaysExistsNonEmpty]
      is also rather hard to write, the current version is using the much stronger
      predicate [AlwaysNonEmpty].

      _TODO: Update [concat] to depend only on the weakened [AlwaysExistsNonEmpty]_.
    *)

  CoFixpoint concat {A: Type} (l: colist (list A)) : AlwaysNonEmpty l -> colist A.
    intro H.
    case l as [xs l'].
    case xs as [|y ys]; [case H as [H _]; exfalso; apply H; reflexivity| ].
    case ys as [|z zs].
    - apply (cocons y),(concat A l'); case H as [_ H]; auto.
    - apply (cocons y),(concat A (cocons (z :: zs) l')).
      case H as [_ H].
      constructor; [apply nil_cons|apply H].
  Defined.

  (** To check the function of [concat], we can run a small testcase. *)

  Definition test1 : colist (list nat) := unfold (fun x => (1 :: 2 :: nil, x)) 1.

  Lemma AlwaysNonEmpty_test1 : AlwaysNonEmpty test1.
  Proof. cofix; constructor; [apply nil_cons|auto]. Qed.

  Example test1_concat : (take 4 (concat test1 AlwaysNonEmpty_test1)) = 1 :: 2 :: 1 :: 2 :: nil.
  Proof. reflexivity. Qed.

End CoList.

Notation colist := CoList.colist.
Notation cocons := CoList.cocons.


Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelNC.
Require Export GeoCoq.Elements.OriginalProofs.lemma_crossimpliesopposite.
Require Export GeoCoq.Elements.OriginalProofs.proposition_34.
Require Export GeoCoq.Elements.OriginalProofs.lemma_NCdistinct.

Section Euclid.

Context `{Ax:euclidean_euclidean}.

Lemma lemma_diagonalsbisect :
   forall A B C D,
   PG A B C D ->
   exists X, Midpoint A X C /\ Midpoint B X D.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists M, (BetS A M C /\ BetS B M D)) by (conclude lemma_diagonalsmeet);destruct Tf as [M];spliter.
assert ((Par A B C D /\ Par A D B C)) by (conclude_def PG ).
assert (neq A C) by (forward_using lemma_betweennotequal).
assert (neq B D) by (forward_using lemma_betweennotequal).
assert (CR A C B D) by (conclude_def CR ).
assert (Par A B C D) by (conclude_def PG ).
assert (Par A B D C) by (forward_using lemma_parallelflip).
assert (nCol A B D) by (forward_using lemma_parallelNC).
assert (TS A B D C) by (forward_using lemma_crossimpliesopposite).
assert (Par B A D C) by (forward_using lemma_parallelflip).
assert (BetS C M A) by (conclude axiom_betweennesssymmetry).
assert (BetS D M B) by (conclude axiom_betweennesssymmetry).
assert (CR B D A C) by (conclude_def CR ).
assert (nCol A B C) by (forward_using lemma_parallelNC).
assert (nCol B A C) by (forward_using lemma_NCorder).
assert (TS B A C D) by (forward_using lemma_crossimpliesopposite).
assert (Cong A B D C) by (forward_using proposition_34).
assert (Cong A B C D) by (forward_using lemma_congruenceflip).
assert (~ Col M A B).
 {
 intro.
 assert (Col A M C) by (conclude_def Col ).
 assert (Col M A C) by (forward_using lemma_collinearorder).
 assert (neq A M) by (forward_using lemma_betweennotequal).
 assert (neq M A) by (conclude lemma_inequalitysymmetric).
 assert (Col A B C) by (conclude lemma_collinear4).
 assert (nCol A B C) by (forward_using lemma_parallelNC).
 contradict.
 }
assert (Triangle M A B) by (conclude_def Triangle ).
assert (~ Col M C D).
 {
 intro.
 assert (Col A M C) by (conclude_def Col ).
 assert (Col M C A) by (forward_using lemma_collinearorder).
 assert (neq M C) by (forward_using lemma_betweennotequal).
 assert (Col C D A) by (conclude lemma_collinear4).
 assert (Col A C D) by (forward_using lemma_collinearorder).
 assert (nCol A C D) by (forward_using lemma_parallelNC).
 contradict.
 }
assert (Triangle M C D) by (conclude_def Triangle ).
assert (Par B A C D) by (forward_using lemma_parallelflip).
assert (CongA B A C A C D) by (conclude proposition_29B).
assert (CongA B A C B A C) by (conclude lemma_equalanglesreflexive).
assert (Out A C M) by (conclude lemma_ray4).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (nCol A B C) by (forward_using lemma_parallelNC).
assert (neq A B) by (forward_using lemma_NCdistinct).
assert (Out A B B) by (conclude lemma_ray4).
assert (CongA B A C B A M) by (conclude lemma_equalangleshelper).
assert (CongA B A M B A C) by (conclude lemma_equalanglessymmetric).
assert (CongA B A M A C D) by (conclude lemma_equalanglestransitive).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (nCol A C D) by (forward_using lemma_parallelNC).
assert (neq C D) by (forward_using lemma_NCdistinct).
assert (neq C A) by (forward_using lemma_NCdistinct).
assert (Out C D D) by (conclude lemma_ray4).
assert (Out C A M) by (conclude lemma_ray4).
assert (CongA A C D A C D) by (conclude lemma_equalanglesreflexive).
assert (CongA A C D M C D) by (conclude lemma_equalangleshelper).
assert (CongA B A M M C D) by (conclude lemma_equalanglestransitive).
assert (nCol A C D) by (forward_using lemma_parallelNC).
assert (Col A M C) by (conclude_def Col ).
assert (Col A C M) by (forward_using lemma_collinearorder).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Col A C C) by (conclude_def Col ).
assert (neq M C) by (forward_using lemma_betweennotequal).
assert (nCol M C D) by (conclude lemma_NChelper).
assert (CongA M C D D C M) by (conclude lemma_ABCequalsCBA).
assert (CongA B A M D C M) by (conclude lemma_equalanglestransitive).
assert (Par A B D C) by (forward_using lemma_parallelflip).
assert (CongA A B D B D C) by (conclude proposition_29B).
assert (CongA A B D A B D) by (conclude lemma_equalanglesreflexive).
assert (Out B D M) by (conclude lemma_ray4).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (nCol B A D) by (forward_using lemma_parallelNC).
assert (neq B A) by (forward_using lemma_NCdistinct).
assert (Out B A A) by (conclude lemma_ray4).
assert (CongA A B D A B M) by (conclude lemma_equalangleshelper).
assert (CongA A B M A B D) by (conclude lemma_equalanglessymmetric).
assert (CongA A B M B D C) by (conclude lemma_equalanglestransitive).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (nCol B D C) by (forward_using lemma_parallelNC).
assert (neq D C) by (forward_using lemma_NCdistinct).
assert (neq D B) by (forward_using lemma_NCdistinct).
assert (Out D C C) by (conclude lemma_ray4).
assert (Out D B M) by (conclude lemma_ray4).
assert (CongA B D C B D C) by (conclude lemma_equalanglesreflexive).
assert (CongA B D C M D C) by (conclude lemma_equalangleshelper).
assert (CongA A B M M D C) by (conclude lemma_equalanglestransitive).
assert (nCol B D C) by (forward_using lemma_parallelNC).
assert (Col B M D) by (conclude_def Col ).
assert (Col B D M) by (forward_using lemma_collinearorder).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (Col B D D) by (conclude_def Col ).
assert (neq M D) by (forward_using lemma_betweennotequal).
assert (nCol M D C) by (conclude lemma_NChelper).
assert (CongA M D C C D M) by (conclude lemma_ABCequalsCBA).
assert (CongA A B M C D M) by (conclude lemma_equalanglestransitive).
assert (CongA M A B M C D) by (conclude lemma_equalanglesflip).
assert ((Cong M A M C /\ Cong M B M D /\ CongA A M B C M D)) by (conclude proposition_26A).
assert (Cong A M M C) by (forward_using lemma_congruenceflip).
assert (Cong B M M D) by (forward_using lemma_congruenceflip).
assert (Midpoint A M C) by (conclude_def Midpoint ).
assert (Midpoint B M D) by (conclude_def Midpoint ).
close.
Qed.

End Euclid.


Require Import
  MathClasses.interfaces.abstract_algebra.

Definition prod_equiv `{Equiv A} `{Equiv B} : Equiv (A * B) := λ p q, fst p = fst q ∧ snd p = snd q.
(* Avoid eager application *)
#[global]
Hint Extern 0 (Equiv (_ * _)) => eapply @prod_equiv : typeclass_instances.

Section product.
  Context `{Setoid A} `{Setoid B}.

  Global Instance: Setoid (A * B).
  Proof. firstorder auto. Qed.

  Global Instance pair_proper: Proper ((=) ==> (=) ==> (=)) (@pair A B).
  Proof. firstorder. Qed.

  Global Instance: Setoid_Morphism (@fst A B).
  Proof. constructor; try apply _. firstorder. Qed.

  Global Instance: Setoid_Morphism (@snd A B).
  Proof. constructor; try apply _. firstorder. Qed.

  Context `(A_dec : ∀ x y : A, Decision (x = y)) `(B_dec : ∀ x y : B, Decision (x = y)).
  Global Program Instance prod_dec: ∀ x y : A * B, Decision (x = y) := λ x y,
    match A_dec (fst x) (fst y) with
    | left _ => match B_dec (snd x) (snd y) with left _ => left _ | right _ => right _ end
    | right _ => right _
    end.
  Solve Obligations with (program_simpl; firstorder).
End product.

Definition prod_fst_equiv X A `{Equiv X} : relation (X * A) := λ x y, fst x = fst y.

Section product_fst.
  Context `{Setoid X}.

  Global Instance : `{Equivalence (prod_fst_equiv X A)}.
  Proof. unfold prod_fst_equiv. firstorder auto. Qed.
End product_fst.

Section dep_product.
  Context (I : Type) (c : I → Type) `{∀ i, Equiv (c i)} `{∀ i, Setoid (c i)}.

  Let dep_prod: Type := ∀ i, c i.

  Instance dep_prod_equiv: Equiv dep_prod := λ x y, ∀ i, x i = y i.

  Global Instance: Setoid dep_prod.
  Proof.
   constructor.
     repeat intro. reflexivity.
    intros ?? E ?. symmetry. apply E.
   intros ? y ??? i. transitivity (y i); firstorder.
  Qed.

  Global Instance dep_prod_morphism i : Setoid_Morphism (λ c: dep_prod, c i).
  Proof. firstorder auto. Qed.
End dep_product.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable defequalangles_1 : (forall A B C Ca Cb Cc : Universe, (exists U V Su Sv : Universe, (congA_ A B C Ca Cb Cc -> (out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C))))))))))).
Variable defequalangles2_2 : (forall A B C Ca Cb Cc U V Su Sv : Universe, ((out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C)))))))) -> congA_ A B C Ca Cb Cc)).
Variable lemma_ray3_3 : (forall B C D V : Universe, ((out_ B C D /\ out_ B C V) -> out_ B D V)).

Theorem lemma_equalangleshelper_4 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export Reals.
Require Import EnsemblesImplicit.
Require Import ImageImplicit.

Local Unset Standard Proposition Elimination Names.

Definition sup := completeness.

Open Scope R_scope.

Definition is_lower_bound (E:R->Prop) (m:R) :=
  forall x:R, E x -> x >= m.
Definition lower_bound (E:R->Prop) :=
  exists m:R, is_lower_bound E m.
Definition is_glb (E:R->Prop) (m:R) :=
  is_lower_bound E m /\ (forall b:R, is_lower_bound E b -> b <= m).

Definition inf: forall E:R->Prop, lower_bound E -> (exists x:R, E x) ->
  { m:R | is_glb E m }.
unshelve refine (fun E Hlb Hinh =>
  let H:=_ in let H0:=_ in
  exist _ (- (proj1_sig (sup (Im E Ropp) H H0))) _).
destruct Hlb as [m].
exists (-m).
red; intros.
destruct H0.
rewrite H1.
auto with real.

destruct Hinh as [x].
exists (-x).
exists x; trivial.

destruct sup as [m].
simpl.
split.
red; intros.
cut (-x <= m).
intros.
replace x with (--x) by ring.
auto with real.
apply i.
exists x; trivial.

intros.
cut (m <= -b).
intros.
replace b with (--b) by ring.
auto with real.
apply i.
red; intros.
cut (-x >= b).
intros.
replace x with (--x) by ring.
auto with real.
apply H1.
destruct H2.
rewrite H3.
replace (--x) with x by ring; trivial.
Qed.

Lemma lub_approx: forall (S:Ensemble R) (m:R) (eps:R),
  is_lub S m -> eps > 0 -> exists x:R, In S x /\
    m - eps < x <= m.
Proof.
intros.
assert (exists x:R, In S x /\ m - eps < x).
apply NNPP; intro.
pose proof (not_ex_all_not _ _ H1); clear H1.
simpl in H2.
assert (is_upper_bound S (m-eps)).
red; intros.
assert (~ x > m - eps).
red; intro.
contradiction (H2 x).
split; trivial.
destruct (total_order_T x (m-eps)) as [[?|?]|?]; auto with *.
contradiction H3; trivial.
destruct H.
pose proof (H3 _ H1).
apply Rle_minus in H4.
ring_simplify in H4.
assert (0 < 0).
apply Rlt_le_trans with eps; trivial.
revert H5; apply Rlt_irrefl.

destruct H1 as [x [? ?]].
exists x; repeat split; trivial.
destruct H.
apply H; trivial.
Qed.

Lemma glb_approx: forall (S:Ensemble R) (m:R) (eps:R),
  is_glb S m -> eps > 0 -> exists x:R, In S x /\ m <= x < m + eps.
Proof.
intros.
assert (exists x:R, In S x /\ x < m + eps).
apply NNPP; intro.
pose proof (not_ex_all_not _ _ H1); clear H1.
simpl in H2.
assert (is_lower_bound S (m+eps)).
red; intros.
assert (~ x < m + eps).
red; intro.
contradiction (H2 x).
split; trivial.
destruct (total_order_T x (m+eps)) as [[?|?]|?]; auto with *.
contradiction H3; trivial.
destruct H.
pose proof (H3 _ H1).
apply Rle_minus in H4.
ring_simplify in H4.
assert (0 < 0).
apply Rlt_le_trans with eps; trivial.
revert H5; apply Rlt_irrefl.

destruct H1 as [x [? ?]].
exists x; repeat split; trivial.
destruct H.
assert (x >= m).
apply H; trivial.
auto with *.
Qed.

Lemma lt_plus_epsilon_le: forall x y:R,
  (forall eps:R, eps > 0 -> x < y + eps) -> x <= y.
Proof.
intros.
destruct (total_order_T x y) as [[?|?]|?]; auto with *.
assert (x < y + (x - y)).
apply H.
apply Rgt_minus; trivial.
ring_simplify in H0.
contradict H0.
apply Rlt_irrefl.
Qed.

Lemma gt_minus_epsilon_ge: forall x y:R,
  (forall eps:R, eps > 0 -> x > y - eps) -> x >= y.
Proof.
intros.
destruct (total_order_T x y) as [[?|?]|?]; auto with *.
assert (x > y - (y - x)).
apply H.
apply Rgt_minus; trivial.
ring_simplify in H0.
contradict H0.
apply Rlt_irrefl.
Qed.


Require Import Auxiliaries.
Require Import TreeZipper.
Require Import Nat Bool Arith Omega.

Require Import String.
Require Import List.

From QuickChick Require Import QuickChick.
Import ListNotations.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.

Require Import Coq.Structures.Equalities.

Module NatType <: Typ with Definition t := nat.
Definition t := nat.
End NatType.

Module TreeZipperOverNat := (TreeZipper.TreeZipperDef NatType).
Import TreeZipperOverNat.

Instance showTree `{_ : Show } : Show (Tree) :=
  {| show :=
      let fix aux t := match t with
        | T_nil => " nil "
        | T_tr x l =>
        let fix printl x' l' := match l' with
          | [] => "{" ++ show x' ++ "}"
          | a::li' => (aux a) ++ (printl x' li')
          end in "<" ++ printl x l ++ ">"
      end in aux
  |}.

Instance showContext `{_ : Show } : Show (Context) :=
  {| show :=
      (fun t => match t with
        | T_move n x l =>
          "cntx {" ++ show n ++ "} {" ++ show x ++ "} {" ++ show l ++ "}"
        end)
  |}.

Fixpoint genTreeSized (sz: nat) (g: G A) : G (Tree) :=
  match sz with
  | 0 => returnGen T_nil
  | S sz' =>
    freq [ (1, returnGen T_nil) ;
      (sz, bindGen g (fun x =>
           bindGen (@listOf (Tree) (genTreeSized sz' g)) (fun l =>
         returnGen (T_tr x l)))) ]
  end.

Definition genTreeList (g: G nat) (gT: G Tree) : G (list Tree) :=
  sized (fun n => bindGen g (fun k => vectorOf k gT)).

(*Definition genTree (g: G A) : G (Tree) :=
  sized (fun n => bindGen (choose (0, n)) (fun k => genTreeSized k g)).
*)

Definition genTree (g: G nat) (gA: G A) : G (Tree) :=
  bindGen g (fun n => genTreeSized n g).

Fixpoint treeTraverse (T: Tree) : list nat :=
  match T with
  | T_nil => []
  | T_tr x l =>
    [x] ++ concat (map (treeTraverse) l)
  end.

Fixpoint tree_cnt (T: Tree) : nat :=
  match T with
  | T_nil => 0
  | T_tr x l =>
    1 + fold_right (fun x => fun y => x + y) 0 (map tree_cnt l)
  end.

Definition genContext (g: G nat) (g' : G A) (gT: G Tree) : G (Context) :=
  bindGen g (fun x =>
    bindGen g (fun y =>
      bindGen g' (fun a =>
        bindGen (genTreeList g gT) (fun lt =>
          returnGen (T_move ((max x y) - 1 - (min x y)) a lt))))).

Definition genContextList (g: G nat) (gC : G Context) : G (list Context) :=
    sized (fun n => bindGen g (fun k => vectorOf k gC)).

Definition genZipper (g: G nat) (gA : G A) : G (ZipperTree) :=
  bindGen (genTree g gA) (fun t =>
    bindGen (genContextList g (genContext g gA (genTree g gA))) (fun lC =>
      returnGen (t, lC))).

Definition qc_cnt_traverse (T: Tree) :=
  beq_nat (tree_cnt T) (List.length (treeTraverse T)).

Definition eq_tree (T T': Tree) : bool :=
  let lT := (treeTraverse T) in let lT' := (treeTraverse T') in
  (beq_nat (length lT) (length lT')) &&
  forallb (fun p => beq_nat (fst p) (snd p)) (combine lT lT').

Definition qc_ziptotree_id (T: Tree) :=
  eq_tree (ZipperToTree (TreeToZipper T)) T.

QuickChick (forAll (genTree (choose (0, 5)) (choose (0, 5))) qc_cnt_traverse).
QuickChick (forAll (genTree (choose (0, 5)) (choose (0, 5))) qc_ziptotree_id).