(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import ZArith_base.
Require Import ZArithRing.
Require Import Zcomplements.
Require Export Zpower.
Require Import Zdiv.
Require Import Znumtheory.
Open Local Scope Z_scope.

Lemma Zpower_pos_1_r: forall x, Zpower_pos x 1 = x.
Proof.
  intros x; unfold Zpower_pos; simpl; auto with zarith.
Qed.

Lemma Zpower_pos_1_l: forall p, Zpower_pos 1 p = 1.
Proof.
  induction p.
  (* xI *)
  rewrite xI_succ_xO, <-Pplus_diag, Pplus_one_succ_l.
  repeat rewrite Zpower_pos_is_exp.
  rewrite Zpower_pos_1_r, IHp; auto.
  (* xO *)
  rewrite <- Pplus_diag.
  repeat rewrite Zpower_pos_is_exp.
  rewrite IHp; auto.
  (* xH *)
  rewrite Zpower_pos_1_r; auto.
Qed.

Lemma Zpower_pos_0_l: forall p, Zpower_pos 0 p = 0.
Proof.
  induction p.
  change (xI p) with (1 + (xO p))%positive.
  rewrite Zpower_pos_is_exp, Zpower_pos_1_r; auto.
  rewrite <- Pplus_diag.
  rewrite Zpower_pos_is_exp, IHp; auto.
  rewrite Zpower_pos_1_r; auto.
Qed.

Lemma Zpower_pos_pos: forall x p,
  0 < x -> 0 < Zpower_pos x p.
Proof.
  induction p; intros.
  (* xI *)
  rewrite xI_succ_xO, <-Pplus_diag, Pplus_one_succ_l.
  repeat rewrite Zpower_pos_is_exp.
  rewrite Zpower_pos_1_r.
  repeat apply Zmult_lt_0_compat; auto.
  (* xO *)
  rewrite <- Pplus_diag.
  repeat rewrite Zpower_pos_is_exp.
  repeat apply Zmult_lt_0_compat; auto.
  (* xH *)
  rewrite Zpower_pos_1_r; auto.
Qed.

Theorem Zpower_1_r: forall z, z^1 = z.
Proof.
  exact Zpower_pos_1_r.
Qed.

Theorem Zpower_1_l: forall z, 0 <= z -> 1^z = 1.
Proof.
  destruct z; simpl; auto.
  intros; apply Zpower_pos_1_l.
  intros; compute in H; elim H; auto.
Qed.

Theorem Zpower_0_l: forall z, z<>0 -> 0^z = 0.
Proof.
  destruct z; simpl; auto with zarith.
  intros; apply Zpower_pos_0_l.
Qed.

Theorem Zpower_0_r: forall z, z^0 = 1.
Proof.
  simpl; auto.
Qed.

Theorem Zpower_2: forall z, z^2 = z * z.
Proof.
  intros; ring.
Qed.

Theorem Zpower_gt_0: forall x y,
  0 < x -> 0 <= y -> 0 < x^y.
Proof.
  destruct y; simpl; auto with zarith.
  intros; apply Zpower_pos_pos; auto.
  intros; compute in H0; elim H0; auto.
Qed.

Theorem Zpower_Zabs: forall a b,  Zabs (a^b) = (Zabs a)^b.
Proof.
  intros a b; case (Zle_or_lt 0 b).
  intros Hb; pattern b; apply natlike_ind; auto with zarith.
  intros x Hx Hx1; unfold Zsucc.
  (repeat rewrite Zpower_exp); auto with zarith.
  rewrite Zabs_Zmult; rewrite Hx1.
  f_equal; auto.
  replace (a ^ 1) with a; auto.
  simpl; unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto.
  simpl; unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto.
  case b; simpl; auto with zarith.
  intros p Hp; discriminate.
Qed.

Theorem Zpower_Zsucc: forall p n, 0 <= n -> p^(Zsucc n) = p * p^n.
Proof.
  intros p n H.
  unfold Zsucc; rewrite Zpower_exp; auto with zarith.
  rewrite Zpower_1_r; apply Zmult_comm.
Qed.

Theorem Zpower_mult: forall p q r, 0 <= q -> 0 <= r -> p^(q*r) = (p^q)^r.
Proof.
  intros p q r H1 H2; generalize H2; pattern r; apply natlike_ind; auto.
  intros H3; rewrite Zmult_0_r; repeat rewrite Zpower_exp_0; auto.
  intros r1 H3 H4 H5.
  unfold Zsucc; rewrite Zpower_exp; auto with zarith.
  rewrite <- H4; try rewrite Zpower_1_r; try rewrite <- Zpower_exp; try f_equal; auto with zarith.
  ring.
  apply Zle_ge; replace 0 with (0 * r1); try apply Zmult_le_compat_r; auto.
Qed.

Theorem Zpower_le_monotone: forall a b c,
 0 < a -> 0 <= b <= c -> a^b <= a^c.
Proof.
  intros a b c H (H1, H2).
  rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith.
  rewrite Zpower_exp; auto with zarith.
  apply Zmult_le_compat_l; auto with zarith.
  assert (0 < a ^ (c - b)); auto with zarith.
  apply Zpower_gt_0; auto with zarith.
  apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith.
Qed.

Theorem Zpower_lt_monotone: forall a b c,
 1 < a -> 0 <= b < c -> a^b < a^c.
Proof.
  intros a b c H (H1, H2).
  rewrite <- (Zmult_1_r (a ^ b)); replace c with (b + (c - b)); auto with zarith.
  rewrite Zpower_exp; auto with zarith.
  apply Zmult_lt_compat_l; auto with zarith.
  apply Zpower_gt_0; auto with zarith.
  assert (0 < a ^ (c - b)); auto with zarith.
  apply Zpower_gt_0; auto with zarith.
  apply Zlt_le_trans with (a ^1); auto with zarith.
  rewrite Zpower_1_r; auto with zarith.
  apply Zpower_le_monotone; auto with zarith.
Qed.

Theorem Zpower_gt_1 : forall x y,
  1 < x -> 0 < y -> 1 < x^y.
Proof.
  intros x y H1 H2.
  replace 1 with (x ^ 0) by apply Zpower_0_r.
  apply Zpower_lt_monotone; auto with zarith.
Qed.

Theorem Zpower_ge_0: forall x y, 0 <= x -> 0 <= x^y.
Proof.
  intros x y; case y; auto with zarith.
  simpl ; auto with zarith.
  intros p H1; assert (H: 0 <= Zpos p); auto with zarith.
  generalize H; pattern (Zpos p); apply natlike_ind; auto with zarith.
  intros p1 H2 H3 _; unfold Zsucc; rewrite Zpower_exp; simpl; auto with zarith.
  apply Zmult_le_0_compat; auto with zarith.
  generalize H1; case x; compute; intros; auto; try discriminate.
Qed.

Theorem Zpower_le_monotone2:
   forall a b c, 0 < a -> b <= c -> a^b <= a^c.
Proof.
  intros a b c H H2.
  destruct (Z_le_gt_dec 0 b).
  apply Zpower_le_monotone; auto.
  replace (a^b) with 0.
  destruct (Z_le_gt_dec 0 c).
  destruct (Zle_lt_or_eq _ _ z0).
  apply Zlt_le_weak;apply Zpower_gt_0;trivial.
  rewrite <- H0;simpl;auto with zarith.
  replace (a^c) with 0. auto with zarith.
  destruct c;trivial;unfold Zgt in z0;discriminate z0.
  destruct b;trivial;unfold Zgt in z;discriminate z.
Qed.

Theorem Zmult_power: forall p q r, 0 <= r ->
  (p*q)^r = p^r * q^r.
Proof.
  intros p q r H1; generalize H1; pattern r; apply natlike_ind; auto.
  clear r H1; intros r H1 H2 H3.
  unfold Zsucc; rewrite Zpower_exp; auto with zarith.
  rewrite H2; repeat rewrite Zpower_exp; auto with zarith; ring.
Qed.

Hint Resolve Zpower_ge_0 Zpower_gt_0: zarith.

Theorem Zpower_le_monotone3: forall a b c,
 0 <= c -> 0 <= a <= b -> a^c <= b^c.
Proof.
  intros a b c H (H1, H2).
  generalize H; pattern c; apply natlike_ind; auto.
  intros x HH HH1 _; unfold Zsucc; repeat rewrite Zpower_exp; auto with zarith.
  repeat rewrite Zpower_1_r.
  apply Zle_trans with (a^x * b); auto with zarith.
Qed.

Lemma Zpower_le_monotone_inv: forall a b c,
  1 < a -> 0 < b -> a^b <= a^c -> b <= c.
Proof.
  intros a b c H H0 H1.
  destruct (Z_le_gt_dec b c);trivial.
  assert (2 <= a^b).
   apply Zle_trans with (2^b).
   pattern 2 at 1;replace 2 with (2^1);trivial.
   apply Zpower_le_monotone;auto with zarith.
   apply Zpower_le_monotone3;auto with zarith.
  assert (c > 0).
  destruct (Z_le_gt_dec 0 c);trivial.
  destruct (Zle_lt_or_eq _ _ z0);auto with zarith.
  rewrite <- H3 in H1;simpl in H1; exfalso;omega.
  destruct c;try discriminate z0. simpl in H1. exfalso;omega.
  assert (H4 := Zpower_lt_monotone a c b H). exfalso;omega.
Qed.

Theorem Zpower_nat_Zpower: forall p q, 0 <= q ->
 p^q = Zpower_nat p (Zabs_nat q).
Proof.
  intros p1 q1; case q1; simpl.
  intros _; exact (refl_equal _).
  intros p2 _; apply Zpower_pos_nat.
  intros p2 H1; case H1; auto.
Qed.

Theorem Zpower2_lt_lin: forall n, 0 <= n -> n < 2^n.
Proof.
  intros n; apply (natlike_ind (fun n => n < 2 ^n)); clear n.
  simpl; auto with zarith.
  intros n H1 H2; unfold Zsucc.
  case (Zle_lt_or_eq _ _ H1); clear H1; intros H1.
  apply Zle_lt_trans with (n + n); auto with zarith.
  rewrite Zpower_exp; auto with zarith.
  rewrite Zpower_1_r.
  assert (tmp: forall p, p * 2 = p + p); intros; try ring;
  rewrite tmp; auto with zarith.
  subst n; simpl; unfold Zpower_pos; simpl; auto with zarith.
Qed.

Theorem Zpower2_le_lin: forall n, 0 <= n -> n <= 2^n.
Proof.
  intros; apply Zlt_le_weak; apply Zpower2_lt_lin; auto.
Qed.

Lemma Zpower2_Psize :
  forall n p, Zpos p < 2^(Z_of_nat n) <-> (Psize p <= n)%nat.
Proof.
  induction n.
  destruct p; split; intros H; discriminate H || inversion H.
  destruct p; simpl Psize.
  rewrite inj_S, Zpower_Zsucc; auto with zarith.
  rewrite Zpos_xI; specialize IHn with p; omega.
  rewrite inj_S, Zpower_Zsucc; auto with zarith.
  rewrite Zpos_xO; specialize IHn with p; omega.
  split; auto with arith.
  intros _; apply Zpower_gt_1; auto with zarith.
  rewrite inj_S; generalize (Zle_0_nat n); omega.
Qed.

(** * Zpower and modulo *)

Theorem Zpower_mod: forall p q n, 0 < n ->
 (p^q) mod n = ((p mod n)^q) mod n.
Proof.
  intros p q n Hn; case (Zle_or_lt 0 q); intros H1.
  generalize H1; pattern q; apply natlike_ind; auto.
  intros q1 Hq1 Rec _; unfold Zsucc; repeat rewrite Zpower_exp; repeat rewrite Zpower_1_r; auto with zarith.
  rewrite (fun x => (Zmult_mod x p)); try rewrite Rec; auto with zarith.
  rewrite (fun x y => (Zmult_mod (x ^y))); try f_equal; auto with zarith.
  f_equal; auto; apply sym_equal; apply Zmod_mod; auto with zarith.
  generalize H1; case q; simpl; auto.
  intros; discriminate.
Qed.

(** A direct way to compute Zpower modulo **)

Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) : Z :=
  match m with
   | xH => a mod n
   | xO m' =>
      let z := Zpow_mod_pos a m' n in
      match z with
       | 0 => 0
       | _ => (z * z) mod n
      end
   | xI m' =>
      let z := Zpow_mod_pos a m' n in
      match z with
       | 0 => 0
       | _ => (z * z * a) mod n
      end
  end.

Definition Zpow_mod a m n :=
  match m with
   | 0 => 1
   | Zpos p => Zpow_mod_pos a p n
   | Zneg p => 0
  end.

Theorem Zpow_mod_pos_correct: forall a m n, 0 < n ->
 Zpow_mod_pos a m n = (Zpower_pos a m) mod n.
Proof.
  intros a m; elim m; simpl; auto.
  intros p Rec n H1; rewrite xI_succ_xO, Pplus_one_succ_r, <-Pplus_diag; auto.
  repeat rewrite Zpower_pos_is_exp; auto.
  repeat rewrite Rec; auto.
  rewrite Zpower_pos_1_r.
  repeat rewrite (fun x => (Zmult_mod x a)); auto with zarith.
  rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith.
  case (Zpower_pos a p mod n); auto.
  intros p Rec n H1; rewrite <- Pplus_diag; auto.
  repeat rewrite Zpower_pos_is_exp; auto.
  repeat rewrite Rec; auto.
  rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith.
  case (Zpower_pos a p mod n); auto.
  unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto with zarith.
Qed.

Theorem Zpow_mod_correct: forall a m n, 1 < n -> 0 <= m ->
 Zpow_mod a m n = (a ^ m) mod n.
Proof.
  intros a m n; case m; simpl.
  intros; apply sym_equal; apply Zmod_small; auto with zarith.
  intros; apply Zpow_mod_pos_correct; auto with zarith.
  intros p H H1; case H1; auto.
Qed.

(* Complements about power and number theory. *)

Lemma Zpower_divide: forall p q, 0 < q -> (p | p ^ q).
Proof.
  intros p q H; exists (p ^(q - 1)).
  pattern p at 3; rewrite <- (Zpower_1_r p); rewrite <- Zpower_exp; try f_equal; auto with zarith.
Qed.

Theorem rel_prime_Zpower_r: forall i p q, 0 < i ->
 rel_prime p q -> rel_prime p (q^i).
Proof.
  intros i p q Hi Hpq; generalize Hi; pattern i; apply natlike_ind; auto with zarith; clear i Hi.
  intros H; contradict H; auto with zarith.
  intros i Hi Rec _; rewrite Zpower_Zsucc; auto.
  apply rel_prime_mult; auto.
  case Zle_lt_or_eq with (1 := Hi); intros Hi1; subst; auto.
  rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1.
Qed.

Theorem rel_prime_Zpower: forall i j p q, 0 <= i ->  0 <= j ->
 rel_prime p q -> rel_prime (p^i) (q^j).
Proof.
  intros i j p q Hi; generalize Hi j p q; pattern i; apply natlike_ind; auto with zarith; clear i Hi j p q.
  intros _ j p q H H1; rewrite Zpower_0_r; apply rel_prime_1.
  intros n Hn Rec _ j p q Hj Hpq.
  rewrite Zpower_Zsucc; auto.
  case Zle_lt_or_eq with (1 := Hj); intros Hj1; subst.
  apply rel_prime_sym; apply rel_prime_mult; auto.
  apply rel_prime_sym; apply rel_prime_Zpower_r; auto with arith.
  apply rel_prime_sym; apply Rec; auto.
  rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1.
Qed.

Theorem prime_power_prime: forall p q n, 0 <= n ->
 prime p -> prime q -> (p | q^n)  -> p = q.
Proof.
  intros p q n Hn Hp Hq; pattern n; apply natlike_ind; auto; clear n Hn.
  rewrite Zpower_0_r; intros.
  assert (2<=p) by (apply prime_ge_2; auto).
  assert (p<=1) by (apply Zdivide_le; auto with zarith).
  omega.
  intros n1 H H1.
  unfold Zsucc; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith.
  assert (2<=p) by (apply prime_ge_2; auto).
  assert (2<=q) by (apply prime_ge_2; auto).
  intros H3; case prime_mult with (2 := H3); auto.
  intros; apply prime_div_prime; auto.
Qed.

Theorem Zdivide_power_2: forall x p n, 0 <= n -> 0 <= x -> prime p ->
 (x | p^n) -> exists m, x = p^m.
Proof.
  intros x p n Hn Hx; revert p n Hn; generalize Hx.
  pattern x; apply Z_lt_induction; auto.
  clear x Hx; intros x IH Hx p n Hn Hp H.
  case Zle_lt_or_eq with (1 := Hx); auto; clear Hx; intros Hx; subst.
  case (Zle_lt_or_eq 1 x); auto with zarith; clear Hx; intros Hx; subst.
  (* x > 1 *)
  case (prime_dec x); intros H2.
  exists 1; rewrite Zpower_1_r; apply prime_power_prime with n; auto.
  case not_prime_divide with (2 := H2); auto.
  intros p1 ((H3, H4), (q1, Hq1)); subst.
  case (IH p1) with p n; auto with zarith.
  apply Zdivide_trans with (2 := H); exists q1; auto with zarith.
  intros r1 Hr1.
  case (IH q1) with p n; auto with zarith.
  case (Zle_lt_or_eq 0 q1).
  apply Zmult_le_0_reg_r with p1; auto with zarith.
  split; auto with zarith.
  pattern q1 at 1; replace q1 with (q1 * 1); auto with zarith.
  apply Zmult_lt_compat_l; auto with zarith.
  intros H5; subst; contradict Hx; auto with zarith.
  apply Zmult_le_0_reg_r with p1; auto with zarith.
  apply Zdivide_trans with (2 := H); exists p1; auto with zarith.
  intros r2 Hr2; exists (r2 + r1); subst.
  apply sym_equal; apply Zpower_exp.
  generalize Hx; case r2; simpl; auto with zarith.
  intros; red; simpl; intros; discriminate.
  generalize H3; case r1; simpl; auto with zarith.
  intros; red; simpl; intros; discriminate.
  (* x = 1 *)
  exists 0; rewrite Zpower_0_r; auto.
  (* x = 0 *)
  exists n; destruct H; rewrite Zmult_0_r in H; auto.
Qed.

(** * Zsquare: a direct definition of [z^2] *)

Fixpoint Psquare (p: positive): positive :=
  match p with
   | xH => xH
   | xO p => xO (xO (Psquare p))
   | xI p => xI (xO (Pplus (Psquare p) p))
  end.

Definition Zsquare p :=
  match p with
   | Z0 => Z0
   | Zpos p => Zpos (Psquare p)
   | Zneg p => Zpos (Psquare p)
  end.

Theorem Psquare_correct: forall p, Psquare p = (p * p)%positive.
Proof.
  induction p; simpl; auto; f_equal; rewrite IHp.
  apply trans_equal with (xO p + xO (p*p))%positive; auto.
  rewrite (Pplus_comm (xO p)); auto.
  rewrite Pmult_xI_permute_r; rewrite Pplus_assoc.
  f_equal; auto.
  symmetry; apply Pplus_diag.
  symmetry; apply Pmult_xO_permute_r.
Qed.

Theorem Zsquare_correct: forall p, Zsquare p = p * p.
Proof.
  intro p; case p; simpl; auto; intros p1; rewrite Psquare_correct; auto.
Qed.


Require Import graph.
Require Import subgraph.
Require Import coloring.
Require Import List.
Require Import Setoid.  (* Generalized rewriting *)
Require Import FSets.   (* Efficient functional sets *)
Require Import FMaps.   (* Efficient functional maps *)
Require Import PArith.
Require Import FunInd.
Require Import restrict.
Require Import munion.
From Hammer Require Import Hammer.
From Hammer Require Import Tactics.
Import Arith.
Import ListNotations.
Import Nat.

(* Predicate that takes a vertex with high degree (> K) *)
Definition high_deg (K: nat) (n: node) (adj: nodeset) : bool := K <? S.cardinal adj.

Definition injective {A B} (f : A -> B) := forall x y, f x = f y -> x = y.

Local Open Scope positive_scope.

(* Wigderson's algorithm definition

let G be a graph, |G.v| = k
a vertex v is high-degree if deg(v) > k^2
phase1 is selecting the high-degree vertices and coloring their neighborhoods
phase2 is coloring the remaining nodes with at most sqrt(k) colors
 *)

Lemma selectW_terminates:
  forall (K: nat) (g : graph) (n : S.elt),
   S.choose (subset_nodes (high_deg K) g) = Some n ->
   (M.cardinal (remove_node n g) < M.cardinal g)%nat.
Proof.
  intros K g n H.
  unfold remove_node.
  assert (~ M.In n (remove_node n g)).
  {
    strivial use: remove_node_neq2 unfold: PositiveOrderedTypeBits.t, PositiveMap.key, PositiveSet.elt, node.
  }
  assert (M.In n g).
  {
    assert (S.In n (subset_nodes (high_deg K) g)).
    {
      hauto l: on use: S.choose_1.
    }
    pose proof (subset_nodes_sub (high_deg K) g n H1).
    unfold nodes, Mdomain in H2.
    now apply Sin_domain in H2.
  }
  rewrite cardinal_map.
  now apply Mremove_cardinal_less.
Qed.

Function selectW (K: nat) (g: graph) {measure M.cardinal g} : list node :=
  match S.choose (subset_nodes (high_deg K) g) with
  | Some n => n :: selectW K (remove_node n g)
  | None => nil
  end.
Proof. apply selectW_terminates.
Defined.

Lemma subset_nodes_prop : forall (P: node -> nodeset -> bool) (g: graph) v,
    S.In v (subset_nodes P g) -> P v (adj g v) = true.
Proof.
  intros P g v H.
  unfold subset_nodes in H.
  apply Sin_domain in H.
  destruct H as [e He].
  epose proof (@WP.filter_iff _ P _ g v e).
  rewrite H in He.
  unfold adj.
  sauto.
Qed.

(* If a node m is removed from the graph then the cardinality of the
  adj set of a vertex v is decreasing. *)
Lemma cardinal_remove : forall g v m,
    (S.cardinal (adj (remove_node m g) v) <= S.cardinal (adj g v))%nat.
Proof.
  intros g v m.
  unfold adj.
  destruct (WF.In_dec g v).
  - ssimpl.
    subst.
    unfold nodeset, node, remove_node in *.
    assert (n0 = x) by scongruence.
    subst.
    (* Note: why is this not more automatic *)
    destruct (E.eq_dec v m).
    + ecrush use: map_o, M.grs.
    + unfold nodeset in *.
      rewrite map_o, M.gro in Heqo by auto.
      qauto use: SP.subset_cardinal, PositiveSet.remove_3 unfold: PositiveSet.elt, PositiveOrderedTypeBits.t, option_map, PositiveSet.Subset.
  - hauto lq: on use: remove_node_subgraph, SP.subset_cardinal unfold: PositiveMap.In, PositiveSet.t, is_subgraph, nodeset, PositiveMap.MapsTo, PositiveSet.Subset, adj inv: option.
Qed.

(* If v is in the list returned by selectW then the cardinality of v is indeed high. *)
Lemma select_hi_deg : forall n g v, In v (selectW n g) -> (S.cardinal (adj g v) > n)%nat.
Proof.
  intros n g v.
  functional induction (selectW n g) using selectW_ind.
  - intros H.
    destruct H.
    + subst.
      clear IHl.
      assert (S.In v (subset_nodes (high_deg n) g)).
      {
        hauto q: on use: PositiveSet.choose_1 inv: option.
      }
      hauto lqb: on drew: off use: subset_nodes_prop unfold: high_deg.
    + specialize (IHl H).
      strivial use: le_gt_trans, cardinal_remove unfold: PositiveOrderedTypeBits.t, PositiveSet.elt, PositiveSet.t, adj, node, nodeset, PositiveSet.empty.
  - sfirstorder.
Qed.

(* Phase 1 of Wigderson *)
(* Let:
- k: bound for degree of vertices
- c: color currently used
- g: graph
- f: coloring
- H: proof that g is 3-colorable
- H1: proof that f is a complete coloring of g
- Hf: proof that f is a 3-coloring

phase1(g,c):
  if a high degree vertex in g exists:
    v := select a high-degree vertex in g
    nbhd := neighborhood of v in g
    coloring_of_nbhd := 2-coloring of nbhd using c+1 and c+2
    g' := remove nbhd from g
    return union(coloring_of_nbhd, phase1(g',c+2))
  else:
    return empty coloring

 *)
Require Import Program.

(* Two-coloring of neighborhood *)
Definition two_color_nbd (g : graph) (v : node) (c1 c2 : positive) : option coloring.
Admitted.

(* Two coloring of a neighborhood of a 3-colorable graph is complete *)
(* Let c1, c2, c3 be distinct colors.  Assume the graph can be
   3-colored and that in this 3-coloring the vertex v has color c3,
   and that the coloring is complete. Then two_color_nbd colors the
   neighborhood of v correctly with two colors. *)
Lemma two_color_nbd_complete : forall (g : graph) (v : node) c1 c2 c3 m,
    c1 <> c2 ->
    c1 <> c3 ->
    c2 <> c3 ->
    no_selfloop g ->
    undirected g ->
    M.In v g ->
    (exists m, M.find v m = Some c3 /\ coloring_complete (SP.of_list [c1;c2;c3]) g m) ->
    two_color_nbd g v c1 c2 = Some m ->
    coloring_complete (SP.of_list [c1;c2]) (subgraph_of g (nodes (neighborhood g v))) m.
Proof.
Admitted.

Lemma two_color_nbd_fail_n3_col : forall (g : graph) (v : node) c1 c2 c3,
    c1 <> c2 ->
    c1 <> c3 ->
    c2 <> c3 ->
    no_selfloop g ->
    undirected g ->
    M.In v g ->
    two_color_nbd g v c1 c2 = None ->
    ~ (exists m, M.find v m = Some c3 /\ coloring_complete (SP.of_list [c1;c2;c3]) g m).
Proof.
Admitted.

Program Fixpoint phase1
  (* The criterion for high-degree vertices *)
  (k : nat)
  (* Current color count *)
  (c : positive)
  (g : graph) {measure (M.cardinal g)} : option coloring :=
  (* Choose a high-degree vertex *)
  match S.choose (subset_nodes (high_deg k) g) with
  | Some v =>
      let nbhd := neighborhood g v in
      (* i is the map that turns the coloring using colors 1,2 into c+1, c+2 *)
      let coloring_of_nbhd := two_color_nbd g c (c+1) v in
      let g' := remove_nodes g (nodes nbhd) in
      (* color the high-degree vertex 1 each time *)
      match coloring_of_nbhd with
      | None => None
      | Some m' => option_map (Munion (M.add v 1 m')) (phase1 k (c+2) g')
      end
  | None => Some (@M.empty _)
  end.
Next Obligation.
Admitted.

Functional Scheme phase1_ind := Induction for phase1 Sort Prop.

(* things we want to prove:
 - let d be the number of iterations
 - prove that the resulting color uses 2d+1 colors
   - induction on size of graph
   - two new colors each time
   - base case: no more high degree vertices, color with phase2
 - there are no more high-degree nodes (this is the hypothesis for phase2)
 - need to identify the terminal properties for phase1 to supply to phase2
 *)
(* induction on M.cardinal g *)
Check phase1.
(* Lemmas:
- you can color any graph with max degree + 1 colors
- can prove 3*(sqrt n) + 1
 *)

(* Some notes about how the algorithm will be written:

- we will not pass proofs that the graph is 3-colorable all the time,
  since later we want to talk about robustness

- we want to break down algorithm enough to reason about the graph and
  the coloring at each step while still making the overall algorithm
  clear

- an important lemma we will use repeatedly is that we can combine OK
  disjoint colorings into larger colorings, and that the number of
  colors used is the size of the palette

- to show that the coloring is complete, we show that a vertex must be
  one of the following:

1) a high-degree vertex, in which case it's colored by phase 1
2) a neighbor of a high-degree vertex, in which case it's colored by phase 1
3) a low-degree vertex, in which case it's colored by phase 2
 *)

(*
We define phase 1 of the algorithm in several pieces:

two_color_step takes:
  - a graph g
  - a high-degree vertex v
  - the current color number c
two_color_step outputs:
  - a complete coloring of N(v) using colors c+1, c+2
note:
  - phase 1 will color v with c
  - the expectation is that two_color_step will be called with another
    vertex and c+2

so phase 1 will fold over the list of high-degree vertices Lv and do:
- the state of the fold will be (c,m), where c is a number and m is the coloring
- call two_color_step on each vertex to produce the coloring and update m
- update c to c+2

we will have to show that:

- the resulting tuple will be (d,m), where d is the number of high-degree
  vertices and m is the coloring of all the neighborhoods of high-degree vertices
- d*d <= k
- the number of colors used is 2*d

random lemmas that we have to show:
- it's decidable to check whether a node is colored or not (WF.In_Dec)
- the number of high-degree vertices cannot exceed sqrt(k)
 *)

(* Lifting two color maps with any injective function *)
Lemma two_color_up_inj f g (inj : S.elt -> S.elt) :
  injective inj ->
  undirected g ->
  coloring_ok two_colors g f ->
  {h | coloring_ok (fold_right S.add S.empty [inj 1;inj 2]) g h}.
Proof.
  intros Hm Ug Hf.
  exists (M.map inj f).
  intros v.
  split.
  - intros ci Hv.
    assert (M.In v f) by hauto l: on use: M.map_2.
    destruct H0 as [cj Hcj].
    unfold M.MapsTo in Hcj.
    assert (ci = inj 1 \/ ci = inj 2).
    {
      unfold coloring_ok in Hf.
      pose proof (map_o f v inj).
      assert (Some ci = option_map inj (M.find v f)) by qauto l: on.
      sauto q: on.
    }
    destruct H0; hauto use: PositiveSet.add_2, PositiveSet.add_1 unfold: PositiveSet.elt.
  - intros ci cj Hci Hcj.
    assert (M.In v f) by hauto l: on use: M.map_2.
    assert (M.In j f) by hauto l: on use: M.map_2.
    destruct H0 as [ci' Hci'].
    destruct H1 as [cj' Hcj'].
    unfold M.MapsTo in *.
    assert (Some ci = option_map inj (M.find v f)) by sauto lq: on use: map_o.
    assert (Some cj = option_map inj (M.find j f)) by sauto lq: on use: map_o.
    pose proof (proj2 (Hf v j H) ci' cj' Hci' Hcj').
    assert (ci' = 1 \/ ci' = 2).
    {
      pose proof (proj1 (Hf _ _ H) _ Hci').
      sauto.
    }
    (* Here we use the fact that the graph is undirected so we can
       go from j being adjacent to v to v being adjacent to j. *)
    assert (cj' = 1 \/ cj' = 2).
    {
      pose proof (proj1 (Hf _ _ (Ug _ _ H)) _ Hcj').
      sauto.
    }
    sauto.
Qed.

(* Lifting three color maps *)
Lemma three_color_up_inj f g (inj : S.elt -> S.elt) :
  injective inj ->
  undirected g ->
  coloring_ok three_colors g f ->
  {h | coloring_ok (fold_right S.add S.empty [inj 1;inj 2;inj 3]) g h}.
Proof.
  intros Hm Ug Hf.
  exists (M.map inj f).
  intros v.
  split.
  - intros ci Hv.
    assert (M.In v f) by hauto l: on use: M.map_2.
    destruct H0 as [cj Hcj].
    unfold M.MapsTo in Hcj.
    assert (ci = inj 1 \/ ci = inj 2 \/ ci = inj 3).
    {
      unfold coloring_ok in Hf.
      pose proof (map_o f v inj).
      assert (Some ci = option_map inj (M.find v f)) by qauto l: on.
      sauto q: on.
    }
    destruct H0; hauto use: PositiveSet.add_2, PositiveSet.add_1 unfold: PositiveSet.elt.
  - intros ci cj Hci Hcj.
    assert (M.In v f) by hauto l: on use: M.map_2.
    assert (M.In j f) by hauto l: on use: M.map_2.
    destruct H0 as [ci' Hci'].
    destruct H1 as [cj' Hcj'].
    unfold M.MapsTo in *.
    assert (Some ci = option_map inj (M.find v f)) by sauto lq: on use: map_o.
    assert (Some cj = option_map inj (M.find j f)) by sauto lq: on use: map_o.
    pose proof (proj2 (Hf v j H) ci' cj' Hci' Hcj').
    assert (ci' = 1 \/ ci' = 2 \/ ci' = 3).
    {
      pose proof (proj1 (Hf _ _ H) _ Hci').
      sauto.
    }
    (* Here we use the fact that the graph is undirected so we can
       go from j being adjacent to v to v being adjacent to j. *)
    assert (cj' = 1 \/ cj' = 2 \/ cj' = 3).
    {
      pose proof (proj1 (Hf _ _ (Ug _ _ H)) _ Hcj').
      sauto.
    }
    sauto.
Qed.

(* To make "without loss of generality" type arguments, we'll need to
turn any 2-coloring into ones that involve just the colors 1,2 then
use appropriate lemmas to turn them into c, c+1.
*)

(* Idea: use reflection for coloring_ok *)

(* Remove whole neighborhood from a graph *)

(* Try to abstract the details about the criterion about how the
   high-degree vertex is chosen *)

(*
Try to 2-color a 2-colorable graph

- choose a vertex, color it 1
- color all of its neighbors 2
- when you color a vertex 2, color all of its neighbors 1
- keep going

 *)

(*
Induction principle for graphs?

*)


(* * First-Order Logic *)

From Undecidability.FOL Require Import FullSyntax.

#[global]
Existing Instance falsity_on.
(* ** Syntax as defined in Util/Syntax.v

 Inductive term  : Type :=
  | var : nat -> term
  | func : forall (f : syms), vec term (ar_syms f) -> term.

  Inductive falsity_flag := falsity_off | falsity_on.

  Inductive form : falsity_flag -> Type :=
  | falsity : form falsity_on
  | atom {b} : forall (P : preds), vec term (ar_preds P) -> form b
  | bin {b} : binop -> form b -> form b -> form b
  | quant {b} : quantop -> form b -> form b.
*)

(* ** Instantiation to for custom FSAT reduction *)

Inductive syms_func :=
  | f : bool -> syms_func
  | e : syms_func
  | dum : syms_func.

Definition func_arity (f : syms_func) := match f with
  | f _ => 1
  | e => 0
  | dum => 0 end.

#[global]
Instance sig_func : funcs_signature :=
  {| syms := syms_func; ar_syms := func_arity |}.

Inductive syms_pred :=
  | P : syms_pred
  | less : syms_pred
  | equiv : syms_pred.

Definition pred_arty (p : syms_pred) := 2.

#[global]
Instance sig_pred : preds_signature :=
  {| preds := syms_pred; ar_preds := pred_arty |}.


(* Bartłomiej Królikowski *)

Require Import Arith.

Inductive BinTree (A : Type) : Type :=
| Node : A -> BinTree A -> BinTree A -> BinTree A
| Empty : BinTree A.

Inductive Maybe (A : Type) : Type :=
| Just : A -> Maybe A
| Nothing : Maybe A.

Fixpoint insert (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A) : BinTree A :=
match T with
  | Node _ a' Tl Tr =>
  if ord a a'
    then Node A a' (insert A ord a Tl) Tr
    else Node A a' Tl (insert A ord a Tr)
  | Empty _ => Node A a (Empty A) (Empty A)
end.

Fixpoint find (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A) : bool :=
match T with
  | Node _ a' Tl Tr =>
  if ord a a'
    then if ord a' a
           then true
           else find A ord a Tl
    else find A ord a Tr
  | Empty _ => false
end.

Fixpoint min (A : Type) (T : BinTree A) : Maybe A :=
match T with
  | Node _ a (Empty _) _ => Just A a
  | Node _ _ Tl _ => min A Tl
  | Empty _ => Nothing A
end.

Fixpoint max (A : Type) (T : BinTree A) : Maybe A :=
match T with
  | Node _ a _ (Empty _) => Just A a
  | Node _ _ _ Tr => max A Tr
  | Empty _ => Nothing A
end.

Fixpoint removeMax (A : Type) (T : BinTree A) : BinTree A :=
match T with
  | Node _ _ Tl (Empty _) => Tl
  | Node _ a Tl Tr => Node A a Tl (removeMax A Tr)
  | Empty _ => Empty A
end.

Definition root (A : Type) (T : BinTree A) : Maybe A :=
match T with
  | Node _ a _ _ => Just A a
  | Empty _ => Nothing A
end.

Definition remove (A : Type) (T : BinTree A) : BinTree A :=
match T with
  | Node _ _ Tl Tr =>
  match max A Tl with
    | Just _ a => Node A a (removeMax A Tl) Tr
    | Nothing _ => Tr
  end
  | Empty _ => Empty A
end.

Fixpoint delete (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A) : BinTree A :=
match T with
  | Node _ a' Tl Tr =>
  if ord a a'
    then if ord a' a
           then remove A T
           else Node A a' (delete A ord a Tl) Tr
    else Node A a' Tl (delete A ord a Tr)
  | Empty _ => Empty A
end.

Fixpoint size (A : Type) (T : BinTree A) : nat :=
match T with
  | Node _ _ Tl Tr => 1 + size A Tl + size A Tr
  | Empty _ => 0
end.

Inductive Elem (A : Type) (a : A) : BinTree A -> Prop :=
| elem_root : forall Tl Tr : BinTree A, Elem A a (Node A a Tl Tr)
| elem_left :
  forall T : BinTree A, Elem A a T ->
  forall (a' : A) (T' : BinTree A), Elem A a (Node A a' T T')
| elem_right :
  forall T : BinTree A, Elem A a T ->
  forall (a' : A) (T' : BinTree A), Elem A a (Node A a' T' T).

Inductive BSTProperty (A : Type) (ord : A -> A -> Prop) : BinTree A -> Prop :=
| BST_node :
  forall (Tl Tr : BinTree A) (a : A),
    BSTProperty A ord Tl ->
    BSTProperty A ord Tr ->
    (forall a' : A, Elem A a' Tl -> ord a' a) ->
    (forall a' : A, Elem A a' Tr -> ord a a') ->
      BSTProperty A ord (Node A a Tl Tr)
| BST_empty : BSTProperty A ord (Empty A).

Fact bool_fun :
  forall (A : Type) (rel : A -> A -> bool) (a a' : A),
    rel a a' = true \/ rel a a' = false.
Proof.
  intros. destruct (rel a a').
  - left. reflexivity.
  - right. reflexivity.
Qed.

Fact empty_elem :
  forall (A : Type) (a : A), ~Elem A a (Empty A).
Proof.
  intros A a H. inversion H.
Qed.

Definition single (A : Type) (a : A) : BinTree A := (Node A a (Empty A) (Empty A)).

Fact single_elem :
  forall (A : Type) (a a' : A), Elem A a (single A a') -> a = a'.
Proof.
  intros. inversion H.
  - reflexivity.
  - inversion H1.
  - inversion H1.
Qed.

Fact BST_single :
  forall (A : Type) (ord : A -> A -> bool) (a : A),
    BSTProperty A (fun a' a'' : A => ord a' a'' = true) (single A a).
Proof.
  intros. unfold single. apply BST_node.
  - apply BST_empty.
  - apply BST_empty.
  - intros. inversion H.
  - intros. inversion H.
Qed.

Fact BST_trans :
  forall (A : Type) (ord : A -> A -> Prop) (a : A) (Tl Tr : BinTree A),
  (forall b c d : A, ord b c -> ord c d -> ord b d) ->
  BSTProperty A ord (Node A a Tl Tr) ->
  forall a' a'' : A, Elem A a' Tl -> Elem A a'' Tr -> ord a' a''.
Proof.
  intros. inversion H0. apply (H a' a a'').
  - apply H8. exact H1.
  - apply H9. exact H2.
Qed.

Fact find_correct :
  forall (A : Type) (ord : A -> A -> bool),
  (forall a a' : A, ord a a' = true -> ord a' a = true -> a = a') ->
  forall (a : A) (T : BinTree A), find A ord a T = true -> Elem A a T.
Proof.
  induction T.
  - cbn. specialize (bool_fun A ord). intro. specialize (H0 a0 a) as H1. specialize (H0 a a0).
    destruct H0.
    + destruct H1.
      * intros. rewrite (H a a0).
        -- apply elem_root.
        -- exact H0.
        -- exact H1.
      * rewrite H0, H1. intros. apply elem_left. apply IHT1. exact H2.
    + rewrite H0. intros. apply elem_right. apply IHT2. exact H2.
  - cbn. intros. inversion H0.
Qed.

Fact find_equiv_correct :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
  find A ord a T = true ->
  exists a' : A, Elem A a' T /\ ord a a' = true /\ ord a' a = true.
Proof.
  induction T; cbn.
  - specialize (bool_fun A ord). intro. specialize (H a0 a) as H'. specialize (H a a0).
    destruct H; rewrite H.
    + destruct H'; rewrite H0; intros.
      * exists a0. split.
        -- apply elem_root.
        -- split.
           ++ exact H.
           ++ exact H0.
      * destruct IHT1.
        -- exact H1.
        -- exists x. destruct H2. split.
           ++ apply elem_left. exact H2.
           ++ exact H3.
    + intros. destruct IHT2.
      * exact H0.
      * exists x. destruct H1. split.
        -- apply elem_right. exact H1.
        -- exact H2.
  - intros. inversion H.
Qed.

Fact find_left :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
  Elem A a T ->
  find A ord a T = true ->
  forall (a' : A) (T' : BinTree A),
  BSTProperty A (fun b b' : A => ord b b' = true) (Node A a' T T') ->
    find A ord a (Node A a' T T') = true.
Proof.
  intros. cbn. inversion H1. rewrite H7.
  - specialize (bool_fun A ord a' a). intros. destruct H9; rewrite H9.
    + reflexivity.
    + exact H0.
  - exact H.
Qed.

Fact find_right :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
  Elem A a T ->
  find A ord a T = true ->
  forall (a' : A) (T' : BinTree A),
  BSTProperty A (fun b b' : A => ord b b' = true) (Node A a' T' T) ->
    find A ord a (Node A a' T' T) = true.
Proof.
  intros. cbn. inversion H1. rewrite H8.
  - specialize (bool_fun A ord a a'). intros. destruct H9; rewrite H9.
    + reflexivity.
    + exact H0.
  - exact H.
Qed.

Fact find_correct_r :
  forall (A : Type) (ord : A -> A -> bool),
  (forall a : A, ord a a = true) ->
  forall (a : A) (T : BinTree A),
    BSTProperty A (fun a' a'' : A => ord a' a'' = true) T ->
    Elem A a T -> find A ord a T = true.
Proof.
  intros. induction H1.
  - cbn. rewrite H. reflexivity.
  - apply find_left.
    + exact H1.
    + apply IHElem. inversion H0. exact H5.
    + exact H0.
  - apply find_right.
    + exact H1.
    + apply IHElem. inversion H0. exact H6.
    + exact H0.
Qed.

Fact insert_increase :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
    size A (insert A ord a T) = S (size A T).
Proof.
  induction T; cbn.
  - specialize (bool_fun A ord a a0). intros. destruct H; rewrite H; cbn; f_equal.
    + rewrite IHT1. cbn. reflexivity.
    + rewrite IHT2. apply Nat.add_succ_r.
  - reflexivity.
Qed.

Fact insert_correct :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
    Elem A a (insert A ord a T).
Proof.
  induction T; cbn.
  - destruct (ord a a0).
    + apply elem_left. exact IHT1.
    + apply elem_right. exact IHT2.
  - apply elem_root.
Qed.

Fact insert_extends :
  forall (A : Type) (a : A) (T : BinTree A),
  Elem A a T ->
  forall (ord : A -> A -> bool) (a' : A), Elem A a (insert A ord a' T).
Proof.
  intros A a T H. induction H; intros; cbn.
  - destruct (ord a' a); apply elem_root.
  - destruct (ord a'0 a'); apply elem_left; trivial.
  - destruct (ord a'0 a'); apply elem_right; trivial.
Qed.

Lemma insert_elem :
  forall (A : Type) (ord : A -> A -> bool) (a a' : A) (T : BinTree A),
    Elem A a (insert A ord a' T) -> a = a' \/ Elem A a T.
Proof.
  induction T; cbn; intros.
  - destruct (ord a' a0); inversion H.
    + right. apply elem_root.
    + destruct IHT1.
      * exact H1.
      * left. exact H4.
      * right. apply elem_left. exact H4.
    + right. apply elem_right. exact H1.
    + right. apply elem_root.
    + right. apply elem_left. exact H1.
    + destruct IHT2.
      * exact H1.
      * left. exact H4.
      * right. apply elem_right. exact H4.
  - left. apply single_elem. unfold single. exact H.
Qed.

Theorem insert_BST_correct :
  forall (A : Type) (ord : A -> A -> bool) (T : BinTree A),
  (forall a a' : A, ord a a' = false -> ord a' a = true) ->
  BSTProperty A (fun a a' => ord a a' = true) T ->
  forall a : A, BSTProperty A (fun a a' => ord a a' = true) (insert A ord a T).
Proof.
  intros A ord T ordLin H. induction H.
  - cbn. specialize (bool_fun A ord). intros. specialize (H3 a0 a).
    destruct H3; rewrite H3; apply BST_node.
    + apply IHBSTProperty1.
    + apply H0.
    + intros. specialize (insert_elem A ord a' a0 Tl H4). intro. destruct H5.
      * rewrite H5. exact H3.
      * apply H1. exact H5.
    + exact H2.
    + apply H.
    + apply IHBSTProperty2.
    + exact H1.
    + intros. specialize (insert_elem A ord a' a0 Tr H4). intro. destruct H5.
      * rewrite H5. apply ordLin. exact H3.
      * apply H2. exact H5.
  - cbn. intros. apply BST_single.
Qed.

Fact min_node_node :
  forall (A : Type) (a a' : A) (Tl Tmid Tr : BinTree A),
    min A (Node A a (Node A a' Tl Tmid) Tr) = min A (Node A a' Tl Tmid).
Proof.
  trivial.
Qed.

Fact min_node_empty :
  forall (A : Type) (a : A) (Tr : BinTree A),
    min A (Node A a (Empty A) Tr) = Just A a.
Proof.
  trivial.
Qed.

Fact min_empty :
  forall A : Type,
    min A (Empty A) = Nothing A.
Proof.
  trivial.
Qed.

Fact min_success :
  forall (A : Type) (Tl Tr : BinTree A) (a : A),
  exists (a' : A), min A (Node A a Tl Tr) = Just A a'.
Proof.
  induction Tl; intros.
  - rewrite min_node_node. apply IHTl1.
  - cbn. exists a. reflexivity.
Qed.

Lemma min_elem :
  forall (A : Type) (T : BinTree A) (a : A),
    min A T = Just A a -> Elem A a T.
Proof.
  induction T.
  - destruct T1.
    + rewrite min_node_node. intros. apply elem_left. apply IHT1. exact H.
    + cbn. intros. injection H. intros. rewrite H0. apply elem_root.
  - cbn. intros. inversion H.
Qed.

Theorem min_correct :
  forall (A : Type) (ord : A -> A -> Prop) (T : BinTree A) (a a' : A),
  (forall b : A, ord b b) ->
  (forall b b' b'' : A, ord b b' -> ord b' b'' -> ord b b'') ->
  BSTProperty A ord T ->
    Elem A a T -> min A T = Just A a' -> ord a' a.
Proof.
  intros. induction H1; inversion H2.
  - destruct Tl.
    + apply H1. apply min_elem. rewrite min_node_node in H3. exact H3.
    + cbn in H3. injection H3. intros. rewrite H5. apply H.
  - apply IHBSTProperty1.
    + exact H6.
    + destruct Tl.
      * rewrite min_node_node in H3. exact H3.
      * inversion H6.
  - destruct Tl.
    + apply (BST_trans A ord a0 (Node A a1 Tl1 Tl2) Tr).
      * exact H0.
      * apply BST_node; trivial.
      * apply min_elem. rewrite min_node_node in H3. exact H3.
      * exact H6.
    + cbn in H3. injection H3. intros. rewrite <- H9. apply H4. exact H6.
Qed.

Fact max_node_node :
  forall (A : Type) (a a' : A) (Tl Tmid Tr : BinTree A),
    max A (Node A a Tl (Node A a' Tmid Tr)) = max A (Node A a' Tmid Tr).
Proof.
  trivial.
Qed.

Fact max_node_empty :
  forall (A : Type) (a : A) (Tl : BinTree A),
    max A (Node A a Tl (Empty A)) = Just A a.
Proof.
  trivial.
Qed.

Fact max_empty :
  forall A : Type,
    max A (Empty A) = Nothing A.
Proof.
  trivial.
Qed.

Fact max_success :
  forall (A : Type) (Tl Tr : BinTree A) (a : A),
  exists (a' : A), max A (Node A a Tl Tr) = Just A a'.
Proof.
  induction Tr; intros.
  - rewrite max_node_node. apply IHTr2.
  - cbn. exists a. reflexivity.
Qed.

Lemma max_elem :
  forall (A : Type) (T : BinTree A) (a : A),
    max A T = Just A a -> Elem A a T.
Proof.
  induction T.
  - destruct T2.
    + rewrite max_node_node. intros. apply elem_right. apply IHT2. exact H.
    + cbn. intros. injection H. intros. rewrite H0. apply elem_root.
  - cbn. intros. inversion H.
Qed.

Theorem max_correct :
  forall (A : Type) (ord : A -> A -> Prop) (T : BinTree A) (a a' : A),
  (forall b : A, ord b b) ->
  (forall b b' b'' : A, ord b b' -> ord b' b'' -> ord b b'') ->
  BSTProperty A ord T ->
    Elem A a T -> max A T = Just A a' -> ord a a'.
Proof.
  intros. induction H1; inversion H2.
  - destruct Tr.
    + apply H4. apply max_elem. rewrite max_node_node in H3. exact H3.
    + cbn in H3. injection H3. intros. rewrite H5. apply H.
  - destruct Tr.
    + apply (BST_trans A ord a0 Tl (Node A a1 Tr1 Tr2)).
      * exact H0.
      * apply BST_node; trivial.
      * exact H6.
      * apply max_elem. rewrite max_node_node in H3. exact H3.
    + cbn in H3. injection H3. intros. rewrite <- H9. apply H1. exact H6.
  - apply IHBSTProperty2.
    + exact H6.
    + destruct Tr.
      * rewrite max_node_node in H3. exact H3.
      * inversion H6.
Qed.

Fact root_node :
  forall (A : Type) (a : A) (Tl Tr : BinTree A), root A (Node A a Tl Tr) = Just A a.
Proof.
  trivial.
Qed.

Fact root_empty :
  forall (A : Type), root A (Empty A) = Nothing A.
Proof.
  trivial.
Qed.

Fact root_elem :
  forall (A : Type) (a : A) (T : BinTree A), root A T = Just A a -> Elem A a T.
Proof.
  destruct T; cbn; intros.
  - injection H. intros. rewrite H0. apply elem_root.
  - inversion H.
Qed.

Fact size_node :
  forall (A : Type) (a : A) (Tl Tr : BinTree A),
    size A (Node A a Tl Tr) = S (size A Tl + size A Tr).
Proof.
  trivial.
Qed.

Fact size_empty :
  forall A : Type, size A (Empty A) = 0.
Proof.
  trivial.
Qed.

Fact removeMax_decrease :
  forall (A : Type) (T : BinTree A), size A (removeMax A T) = size A T - 1.
Proof.
  induction T; cbn.
  - destruct T2.
    + rewrite size_node. rewrite IHT2. cbn. rewrite Nat.add_succ_r. cbn. rewrite Nat.sub_0_r.
      reflexivity.
    + cbn. symmetry. rewrite Nat.sub_0_r. apply Nat.add_0_r.
  - reflexivity.
Qed.

Lemma removeMax_incl :
  forall (A : Type) (a : A) (T : BinTree A),
    Elem A a (removeMax A T) -> Elem A a T.
Proof.
  induction T; cbn.
  - destruct T2; intros.
    + inversion H.
      * apply elem_root.
      * apply elem_left. exact H1.
      * apply elem_right. apply IHT2. cbn. exact H1.
    + apply elem_left. exact H.
  - exact id.
Qed.

Lemma removeMax_elem :
  forall (A : Type) (a : A) (T : BinTree A),
    Elem A a T -> Elem A a (removeMax A T) \/ max A T = Just A a.
Proof.
  intros. induction H.
  - cbn. destruct Tr.
    + left. apply elem_root.
    + right. reflexivity.
  - left. cbn. destruct T'.
    + apply elem_left. exact H.
    + exact H.
  - destruct IHElem.
    + left. cbn. destruct T.
      * apply elem_right. exact H0.
      * cbn in H0. inversion H0.
    + right. cbn. destruct T.
      * exact H0.
      * cbn in H0. inversion H0.
Qed.

Theorem removeMax_BST_correct :
  forall (A : Type) (ord : A -> A -> Prop) (T : BinTree A),
    BSTProperty A ord T -> BSTProperty A ord (removeMax A T).
Proof.
  intros. induction H.
  - cbn. destruct Tr.
    + apply BST_node.
      * exact H.
      * exact IHBSTProperty2.
      * exact H1.
      * intros. apply H2. apply removeMax_incl. exact H3.
    + exact H.
  - cbn. apply BST_empty.
Qed.

Fact remove_decrease :
  forall (A : Type) (T : BinTree A), size A (remove A T) = size A T - 1.
Proof.
  destruct T; cbn.
  - destruct T1.
    + destruct (max_success A T1_1 T1_2 a0). rewrite H. rewrite size_node.
      rewrite removeMax_decrease. cbn. f_equal. f_equal. apply Nat.sub_0_r.
    + cbn. symmetry. apply Nat.sub_0_r.
  - reflexivity.
Qed.

Lemma remove_incl :
  forall (A : Type) (a : A) (T : BinTree A),
    Elem A a (remove A T) -> Elem A a T.
Proof.
  destruct T; cbn.
  - destruct T1.
    + destruct (max_success A T1_1 T1_2 a1). rewrite H. intro. inversion H0.
      * apply elem_left. apply max_elem. exact H.
      * apply elem_left. apply removeMax_incl. cbn. exact H2.
      * apply elem_right. exact H2.
    + cbn. intros. apply elem_right. exact H.
  - exact id.
Qed.

Lemma remove_elem :
  forall (A : Type) (a : A) (T : BinTree A),
    Elem A a T -> Elem A a (remove A T) \/ root A T = Just A a.
Proof.
  intros. destruct H.
  - right. cbn. reflexivity.
  - left. cbn. destruct T.
    + destruct (max_success A T1 T2 a0). rewrite H0.
      destruct (removeMax_elem A a (Node A a0 T1 T2)).
      * exact H.
      * apply elem_left. exact H1.
      * rewrite H0 in H1. injection H1. intros. rewrite H2. apply elem_root.
    + inversion H.
  - left. cbn. destruct T'.
    + destruct (max_success A T'1 T'2 a0). rewrite H0. apply elem_right. exact H.
    + cbn. exact H.
Qed.

Theorem remove_BST_correct :
  forall (A : Type) (ord : A -> A -> Prop) (T : BinTree A),
  (forall a : A, ord a a) ->
  (forall a b c : A, ord a b -> ord b c -> ord a c) ->
  BSTProperty A ord T ->
    BSTProperty A ord (remove A T).
Proof.
  intros. destruct H1; cbn.
  - destruct Tl.
    + destruct (max_success A Tl1 Tl2 a0). rewrite H3. apply BST_node.
      * apply removeMax_BST_correct. exact H1_.
      * exact H1_0.
      * intros. apply (max_correct A ord (Node A a0 Tl1 Tl2)).
        -- exact H.
        -- exact H0.
        -- exact H1_.
        -- apply removeMax_incl. exact H4.
        -- exact H3.
      * intros.
        apply (BST_trans A ord a (Node A a0 Tl1 Tl2) Tr).
        -- exact H0.
        -- apply BST_node; trivial.
        -- apply max_elem. exact H3.
        -- exact H4.
    + cbn. exact H1_0.
  - apply BST_empty.
Qed.

Fact delete_decrease :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
  (forall a' : A, ord a' a' = true) ->
  BSTProperty A (fun a' a'' : A => ord a' a'' = true) T ->
    Elem A a T -> size A (delete A ord a T) = size A T - 1.
Proof.
  intros. induction H1; cbn; inversion H0.
  - rewrite H. fold (remove A (Node A a Tl Tr)). apply remove_decrease.
  - rewrite H7.
    + specialize (bool_fun A ord a' a). intro. destruct H9; rewrite H9.
      * fold (remove A (Node A a T T')). apply remove_decrease.
      * cbn. rewrite IHElem.
        -- destruct T.
          ++ cbn. rewrite Nat.sub_0_r. reflexivity.
          ++ inversion H1.
        -- exact H5.
    + exact H1.
  - rewrite H8.
    + specialize (bool_fun A ord a a'). intro. destruct H9; rewrite H9.
      * fold (remove A (Node A a T' T)). apply remove_decrease.
      * cbn. rewrite IHElem.
        -- destruct T.
          ++ cbn. rewrite Nat.add_succ_r. cbn. f_equal. f_equal. apply Nat.sub_0_r.
          ++ inversion H1.
        -- exact H6.
    + exact H1.
Qed.

Fact delete_find_decrease :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
  find A ord a T = true ->
    size A (delete A ord a T) = size A T - 1.
Proof.
  induction T; cbn.
  - specialize (bool_fun A ord). intro. specialize (H a0 a) as H0. specialize (H a a0).
    destruct H; rewrite H.
    + destruct H0; rewrite H0; intros.
      * fold (remove A (Node A a T1 T2)). apply remove_decrease.
      * cbn. rewrite IHT1.
        -- destruct T1; cbn.
          ++ f_equal. f_equal. apply Nat.sub_0_r.
          ++ cbn in H1. inversion H1.
        -- exact H1.
    + intros. cbn. rewrite IHT2.
      * destruct T2; cbn.
        -- rewrite Nat.add_succ_r. cbn. f_equal. f_equal. apply Nat.sub_0_r.
        -- cbn in H1. inversion H1.
      * exact H1.
  - reflexivity.
Qed.

Fact delete_not_find_ident :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
    find A ord a T = false -> delete A ord a T = T.
Proof.
  induction T; cbn.
  - specialize (bool_fun A ord). intro. specialize (H a0 a) as H0. specialize (H a a0).
    destruct H; rewrite H.
    + destruct H0; rewrite H0.
      * intro. inversion H1.
      * intro. rewrite IHT1; trivial.
    + intro. rewrite IHT2; trivial.
  - reflexivity.
Qed.

Fact delete_decrease_find :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
  size A (delete A ord a T) = size A T - 1 ->
    find A ord a T = true \/ T = Empty A.
Proof.
  induction T.
  - cbn. specialize (bool_fun A ord). intro. specialize (H a0 a) as H1.
    specialize (H a a0) as H0. destruct H0; rewrite H0.
    + destruct H1; rewrite H1; cbn.
      * intros. left. reflexivity.
      * rewrite Nat.sub_0_r. rewrite <- Nat.add_succ_l. rewrite Nat.add_cancel_r. intro.
        destruct IHT1.
        -- destruct T1; cbn in *.
          ++ injection H2. intro. rewrite H3. symmetry. apply Nat.sub_0_r.
          ++ reflexivity.
        -- left. exact H3.
        -- rewrite H3 in H2. cbn in H2. inversion H2.
    + cbn. rewrite Nat.sub_0_r. rewrite <- Nat.add_succ_r. rewrite Nat.add_cancel_l. intro.
      destruct IHT2.
      * destruct T2; cbn in *.
        -- injection H2. intro. rewrite H3. symmetry. apply Nat.sub_0_r.
        -- reflexivity.
      * left. exact H3.
      * rewrite H3 in H2. cbn in H2. inversion H2.
  - intro. right. reflexivity.
Qed.

Lemma delete_incl :
  forall (A : Type) (ord : A -> A -> bool) (a a' : A) (T : BinTree A),
    Elem A a (delete A ord a' T) -> Elem A a T.
Proof.
  induction T; cbn.
  - specialize (bool_fun A ord). intro. specialize (H a' a0) as H0. specialize (H a0 a').
    destruct H0; rewrite H0.
    + destruct H; rewrite H.
      * destruct T1.
        -- destruct (max_success A T1_1 T1_2 a1). rewrite H1. intro. inversion H2.
          ++ apply elem_left. apply max_elem. exact H1.
          ++ apply elem_left. apply removeMax_incl. cbn. exact H4.
          ++ apply elem_right. exact H4.
        -- cbn. intro. apply elem_right. exact H1.
      * intro. inversion H1.
        -- apply elem_root.
        -- apply elem_left. apply IHT1. exact H3.
        -- apply elem_right. exact H3.
    + intro. inversion H1.
      * apply elem_root.
      * apply elem_left. exact H3.
      * apply elem_right. apply IHT2. exact H3.
  - exact id.
Qed.

Lemma delete_elem :
  forall (A : Type) (ord : A -> A -> bool) (a a' : A) (T : BinTree A),
    Elem A a T -> Elem A a (delete A ord a' T) \/ find A ord a' T = true.
Proof.
  intros. specialize (bool_fun A ord). intro. induction H; cbn.
  - intros. specialize (H0 a a') as H1. specialize (H0 a' a).
    destruct H0; rewrite H.
    + destruct H1; rewrite H0.
      * right. reflexivity.
      * left. apply elem_root.
    + left. apply elem_root.
  - specialize (H0 a'0 a') as H1. specialize (H0 a' a'0). destruct H0; rewrite H0.
    + destruct H1; rewrite H1.
      * right. reflexivity.
      * destruct IHElem.
        -- left. apply elem_left. exact H2.
        -- right. exact H2.
    + left. apply elem_left. exact H.
  - specialize (H0 a'0 a') as H1. specialize (H0 a' a'0). destruct H0; rewrite H0.
    + destruct H1; rewrite H1.
      * right. reflexivity.
      * left. apply elem_right. exact H.
    + destruct IHElem.
      * left. apply elem_right. exact H2.
      * right. exact H2.
Qed.

Theorem delete_BST_correct :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
  (forall a' : A, ord a' a' = true) ->
  (forall b c d : A, ord b c = true -> ord c d = true -> ord b d = true) ->
  BSTProperty A (fun b b' : A => ord b b' = true) T ->
    BSTProperty A (fun b b' : A => ord b b' = true) (delete A ord a T).
Proof.
  intros. induction H1; cbn.
  - specialize (bool_fun A ord). intro. specialize (H3 a0 a) as H4. specialize (H3 a a0).
    destruct H3; rewrite H3.
    + destruct H4; rewrite H4.
      * destruct Tl.
        -- destruct (max_success A Tl1 Tl2 a1). rewrite H5. apply BST_node.
          ++ apply removeMax_BST_correct. exact H1_.
          ++ exact H1_0.
          ++ intros.
apply (max_correct A (fun b b' : A => ord b b' = true) (Node A a1 Tl1 Tl2)); trivial.
apply removeMax_incl. exact H6.
          ++ intros. apply (H0 x a0 a').
            ** apply H1. apply max_elem. exact H5.
            ** apply H2. exact H6.
        -- cbn. exact H1_0.
      * apply BST_node; trivial. intros. apply H1. apply (delete_incl A ord a' a). exact H5.
    + apply BST_node; trivial. intros. apply H2. apply (delete_incl A ord a' a). exact H5.
  - apply BST_empty.
Qed.

Theorem insert_delete_inverse :
  forall (A : Type) (ord : A -> A -> bool) (a : A) (T : BinTree A),
  ord a a = true ->
  find A ord a T = false ->
    delete A ord a (insert A ord a T) = T.
Proof.
  induction T.
  - cbn. specialize (bool_fun A ord). intro. specialize (H a0 a) as H0. specialize (H a a0).
    destruct H; rewrite H.
    + destruct H0; rewrite H0.
      * intros. inversion H2.
      * cbn. rewrite H. rewrite H0. intros. rewrite IHT1; trivial.
    + cbn. rewrite H. intros. rewrite IHT2; trivial.
  - cbn. intros. rewrite H. reflexivity.
Qed.


Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops.

Local Open Scope functor_scope.

(** Cat, the category of (small) categories, is a category whose objects are
    (small) categories and morphisms are functors.

In this development, the (relative) smallness/largeness is represented by
universe levels and universe polymorphism of Coq.
*)
Definition Cat : Category :=
{|
  Obj := Category;

  Hom := Functor;

  compose := fun C D E => Functor_compose;

  assoc := fun C D E F (G : C –≻ D) (H : D –≻ E) (I : E –≻ F) =>
            @Functor_assoc _ _ _ _ G H I;

  assoc_sym := fun C D E F (G : C –≻ D) (H : D –≻ E) (I : E –≻ F) =>
            eq_sym (@Functor_assoc _ _ _ _ G H I);

  id := fun C => Functor_id C;

  id_unit_left := fun C D => @Functor_id_unit_left C D;

  id_unit_right := fun C D => @Functor_id_unit_right C D
|}.


Require Import HoTT.

Definition homotopic {A P}
           (f : forall (x:A), P x) (g : forall (x : A), P x) :=
  forall x, f x = g x.

Notation "f ~ g" := (homotopic f g) (at level 85) : equiv_scope.

Theorem m51_1 : forall X Y Z (h h' : X -> Y) (k k' : Y -> Z),
  h ~ h' -> k ~ k' -> k o h ~ k' o h'.
Proof.
  intros X Y Z h h' k k' H K.
  intro x. rewrite (H x). rewrite (K (h' x)).
  reflexivity.
Qed.

Theo


Require Import Coq.micromega.Lia Coq.ZArith.ZArith.
Local Open Scope Z_scope.

Module Z.
  Lemma push_minus_add a b : -(-a + b) = a + -b. Proof. lia. Qed.

  Ltac clean_neg_step _ :=
    match goal with
    | [ H : (-?x) < 0 |- _ ] => assert (0 < x) by lia; clear H
    | [ H : 0 > (-?x) |- _ ] => assert (0 < x) by lia; clear H
    | [ H : 0 <> -?x |- _ ] => assert (0 <> x) by lia; clear H
    | [ H : -?x <> 0 |- _ ] => assert (x <> 0) by lia; clear H
    | [ H : (-?x) <= 0 |- _ ] => assert (0 <= x) by lia; clear H
    | [ H : 0 >= (-?x) |- _ ] => assert (0 <= x) by lia; clear H
    | [ H : -?x <= -?y |- _ ] => rewrite <- Z.opp_le_mono in H
    | [ |- -?x <= -?y ] => rewrite <- Z.opp_le_mono
    | [ H : -?x < -?y |- _ ] => rewrite <- Z.opp_lt_mono in H
    | [ |- -?x < -?y ] => rewrite <- Z.opp_lt_mono
    | _ => progress rewrite <- Z.opp_le_mono in *
    | [ H : context[_ * _] |- _ ]
      => first [ rewrite !Z.mul_opp_opp in H
               | rewrite !Z.mul_opp_l in H
               | rewrite !Z.mul_opp_r in H ]
    | [ |- context[_ * _] ]
      => first [ rewrite !Z.mul_opp_opp
               | rewrite !Z.mul_opp_l
               | rewrite !Z.mul_opp_r ]
    | [ H : context[- - _] |- _ ] => rewrite !Z.opp_involutive in H
    | [ |- context[- - _] ] => rewrite !Z.opp_involutive
    | [ H : context[-_ + -_] |- _ ] => rewrite <- !Z.opp_add_distr in H
    | [ |- context[-_ + -_] ] => rewrite <- !Z.opp_add_distr
    | [ H : context[-(-?a + ?b)] |- _ ] => rewrite !push_minus_add in H
    | [ |- context[-(-?a + ?b)] ] => rewrite !push_minus_add
    | [ H : 0 <= ?x, H' : 0 <= ?y, H'' : -?x <= ?y |- _ ] => clear H''
    | [ H : 0 < ?x, H' : 0 <= ?y, H'' : -?x <= ?y |- _ ] => clear H''
    | [ H : 0 <= ?x, H' : 0 < ?y, H'' : -?x <= ?y |- _ ] => clear H''
    | [ H : 0 < ?x, H' : 0 < ?y, H'' : -?x <= ?y |- _ ] => clear H''
    | [ H : 0 < ?x, H' : 0 <= ?y, H'' : -?x < ?y |- _ ] => clear H''
    | [ H : 0 <= ?x, H' : 0 < ?y, H'' : -?x < ?y |- _ ] => clear H''
    | [ H : 0 < ?x, H' : 0 < ?y, H'' : -?x < ?y |- _ ] => clear H''
    | [ |- -_ = -_ ] => rewrite Z.opp_inj_wd
    | [ H : -_ = -_ |- _ ] => rewrite Z.opp_inj_wd in H
    end.
  Ltac clean_neg := repeat clean_neg_step ().
  Ltac replace_with_neg x :=
    assert (x = -(-x)) by (symmetry; apply Z.opp_involutive); generalize dependent (-x);
    let x' := fresh in
    rename x into x'; intro x; intros; subst x';
    clean_neg.
  Ltac replace_all_neg_with_pos :=
    repeat match goal with
           | [ H : ?x < 0 |- _ ] => replace_with_neg x
           | [ H : 0 > ?x |- _ ] => replace_with_neg x
           | [ H : ?x <= 0 |- _ ] => replace_with_neg x
           | [ H : 0 >= ?x |- _ ] => replace_with_neg x
           end.
End Z.