Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Sets.Ensembles.
Require Export Coq.Lists.List.
Require Import Coq.omega.Omega.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.EnsemblesProperties.

Section Lindenbaum.

Context {A: Type}
        (CA: Countable A)
        (init: Ensemble A)
        (P: Ensemble A -> Prop).

Fixpoint LindenbaumChain (n: nat): Ensemble A :=
  match n with
  | 0 => init
  | S n => fun a => LindenbaumChain n a \/ CA a n /\ P (Union _ (LindenbaumChain n) (Singleton _ a))
  end.

Definition LindenbaumConstruction: Ensemble A :=
  fun a => exists n, LindenbaumChain n a.

Lemma Lindenbaum_included_n_m: forall n m,
  n <= m ->
  Included _ (LindenbaumChain n) (LindenbaumChain m).
Proof.
  intros.
  induction H.
  + exact (fun x H => H).
  + refine (fun x H => _ (IHle x H)).
    clear.
    unfold Ensembles.In; intros; simpl.
    left.
    auto.
Qed.

Lemma Lindenbaum_included_n_omega: forall n,
  Included _ (LindenbaumChain n) LindenbaumConstruction.
Proof.
  intros.
  intros ? ?.
  exists n; auto.
Qed.

Lemma Lindenbaum_included:
  Included _ init LindenbaumConstruction.
Proof.
  apply (Lindenbaum_included_n_omega 0).
Qed.

Lemma Lindenbaum_pointwise_finite_decided: forall a n,
  CA a n ->
  (LindenbaumChain (S n) a) <-> (LindenbaumConstruction a).
Proof.
  intros.
  split; [apply (Lindenbaum_included_n_omega (S n)) | intros].
  destruct H0 as [m ?].
  destruct (le_dec m (S n)); [revert H0; apply Lindenbaum_included_n_m; auto |].
  assert (S n <= m) by omega; clear n0.
  induction H1; auto.
  apply IHle; clear IHle.
  simpl in H0.
  destruct H0; auto.
  destruct H0 as [? _]; exfalso.
  pose proof pf_inj _ _ CA a _ _ H H0.
  omega.
Qed.

Lemma Lindenbaum_finite_witness:
  forall xs, Forall LindenbaumConstruction xs ->
    exists n, Forall (LindenbaumChain n) xs.
Proof.
  intros.
  induction H.
  + exists 0.
    constructor.
  + destruct IHForall as [n ?H].
    destruct (im_inj _ _ CA x) as [m ?].
    exists (max n (S m)).
    constructor.
    - erewrite <- Lindenbaum_pointwise_finite_decided in H by eauto.
      revert H; apply (Lindenbaum_included_n_m (S m)).
      apply Max.le_max_r.
    - revert H1.
      apply Forall_impl; intro.
      apply Lindenbaum_included_n_m.
      apply Max.le_max_l.
Qed.

Hypothesis H_init: P init.

Lemma Lindenbaum_preserve_n:
  Proper (Same_set A ==> iff) P ->
  forall n, P (LindenbaumChain n).
Proof.
  intros P_Proper n.
  induction n; auto.
  simpl.
  destruct (classic (exists a, CA a n /\ P (Union A (LindenbaumChain n) (Singleton A a)))).
  + destruct H as [a [? ?]].
    eapply P_Proper; [| exact H0].
    rewrite Same_set_spec.
    intros a0.
    rewrite Union_spec, Singleton_spec.
    assert (CA a0 n -> a = a0).
    {
      intros.
      apply (in_inj _ _ CA a a0 n); auto.
    }
    assert (a = a0 -> P (Union A (LindenbaumChain n) (Singleton A a0))).
    {
      intros.
      subst; auto.
    }
    assert (a = a0 -> CA a0 n).
    {
      intros.
      subst; auto.
    }
    tauto.
  + eapply P_Proper; [| exact IHn].
    rewrite Same_set_spec.
    intros a0.
    firstorder.
Qed.

Lemma Lindenbaum_preserve_omega:
  finite_captured P ->
  subset_preserved P ->
  P LindenbaumConstruction.
Proof.
  intros.
  apply H.
  intros.
  apply Lindenbaum_finite_witness in H1.
  destruct H1 as [n ?].
  rewrite Forall_forall in H1.
  eapply H0; [exact H1 |].
  apply Lindenbaum_preserve_n, subset_preserved_same_set_preserved; auto.
Qed.

Lemma Lindenbaum_pointwise_finite_decided': forall a n,
  CA a n ->
  Proper (Same_set A ==> iff) P ->
  P (Union _ (LindenbaumChain n) (Singleton _ a)) <-> (LindenbaumConstruction a).
Proof.
  intros.
  rewrite <- Lindenbaum_pointwise_finite_decided by eauto.
  simpl.
  split; intros; auto.
  destruct H1 as [? | [? ?]]; auto.
  eapply H0; [| apply (Lindenbaum_preserve_n H0 n)].
  rewrite Same_set_spec; intros a0.
  rewrite Union_spec.
  split; intros; [| auto].
  destruct H2; auto.
  inversion H2; subst.
  auto.
Qed.

End Lindenbaum.

Definition Lindenbaum_preserves {A: Type} (P: Ensemble A -> Prop): Prop :=
  forall (CA: Countable A) init, P init -> P (LindenbaumConstruction CA init P).

Definition Lindenbaum_ensures {A: Type} (P cP: Ensemble A -> Prop): Prop :=
  forall (CA: Countable A) init, P init -> cP (LindenbaumConstruction CA init P).

Definition Lindenbaum_constructable {A: Type} (P cP: Ensemble A -> Prop): Prop :=
  forall Phi, P Phi -> exists Psi: sig cP, Included _ Phi (proj1_sig Psi) /\ P (proj1_sig Psi).

Lemma Lindenbaum_constructable_Same_set {A: Type}: forall P Q cP: Ensemble A -> Prop,
  Same_set _ P Q ->
  (Lindenbaum_constructable P cP <-> Lindenbaum_constructable Q cP).
Proof.
  intros.
  pose proof H.
  rewrite Same_set_spec in H.
  apply Morphisms_Prop.all_iff_morphism.
  intros Phi.
  apply Morphisms_Prop.iff_iff_iff_impl_morphism_obligation_1; auto.
  apply Morphisms_Prop.ex_iff_morphism.
  intros [Psi ?H].
  apply Morphisms_Prop.and_iff_morphism; [tauto |].
  auto.
Qed.

Lemma Lindenbaum_constructable_suffice {A: Type} (P cP: Ensemble A -> Prop):
  Countable A ->
  Lindenbaum_preserves P ->
  Lindenbaum_ensures P cP ->
  Lindenbaum_constructable P cP.
Proof.
  intros.
  hnf; intros.
  specialize (H X _ H1).
  specialize (H0 X _ H1).
  exists (exist _ _ H0).
  split; auto.
  apply Lindenbaum_included.
Qed.

Lemma Lindenbaum_preserves_by_finiteness {A: Type}: forall P: Ensemble A -> Prop,
  finite_captured P ->
  subset_preserved P ->
  Lindenbaum_preserves P.
Proof.
  intros.
  hnf; intros.
  apply Lindenbaum_preserve_omega; auto.
Qed.

Lemma Lindenbaum_ensures_by_conjunct {A: Type}: forall P cP1 cP2: Ensemble A -> Prop,
  Lindenbaum_ensures P cP1 ->
  Lindenbaum_ensures P cP2 ->
  Lindenbaum_ensures P (Intersection _ cP1 cP2).
Proof.
  intros.
  hnf.
  intros.
  rewrite Intersection_spec; auto.
Qed.


Require Export MetricSpaces.

Local Unset Standard Proposition Elimination Names.

Section UniformTopology.

Variable X Y:Type.
Variable d:Y->Y->R.
Variable y0:X->Y. (* base function limiting the extents of the
                  range of a function X->Y *)
Hypothesis d_metric: metric d.
Hypothesis X_inhabited: inhabited X.

Definition uniform_space := { f:X->Y | bound (Im Full_set
                                      (fun x:X => d (y0 x) (f x))) }.

Definition uniform_metric (f g:uniform_space) : R.
refine (match f, g with exist f0 Hf, exist g0 Hg =>
  proj1_sig (sup (Im Full_set (fun x:X => d (f0 x) (g0 x))) _ _) end).
destruct Hf as [mf].
destruct Hg as [mg].
exists (mf + mg).
red; intros.
destruct H1.
rewrite H2.
apply Rle_trans with (d (y0 x) (f0 x) + d (y0 x) (g0 x)).
rewrite (metric_sym _ d d_metric (y0 x) (f0 x)); trivial;
  apply triangle_inequality; trivial.
assert (d (y0 x) (f0 x) <= mf) by (apply H; exists x; trivial).
assert (d (y0 x) (g0 x) <= mg) by (apply H0; exists x; trivial).
auto with real.

destruct X_inhabited as [x0].
exists (d (f0 x0) (g0 x0)); exists x0; trivial; constructor.
Defined.

Lemma uniform_metric_is_metric: metric uniform_metric.
Proof.
constructor; intros.
unfold uniform_metric.
destruct x as [f0 Hf]; destruct y as [g0 Hg]; destruct sup.
simpl.
destruct X_inhabited as [x0].
apply Rge_trans with (d (f0 x0) (g0 x0)).
cut (d (f0 x0) (g0 x0) <= x); auto with real.
apply i.
exists x0; trivial.
constructor.
apply d_metric.
unfold uniform_metric.
destruct x as [f0 Hf]; destruct y as [g0 Hg].
destruct sup.
destruct sup.
simpl.
assert (Im Full_set (fun x:X => d (f0 x) (g0 x)) =
        Im Full_set (fun x:X => d (g0 x) (f0 x))).
apply Extensionality_Ensembles; split; red; intros.
destruct H.
exists x1.
constructor.
rewrite metric_sym; trivial.
destruct H.
exists x1.
constructor.
rewrite metric_sym; trivial.
apply Rle_antisym.
apply i.
rewrite H.
apply i0.
apply i0.
rewrite <- H.
apply i.

destruct x as [f0 Hf]; destruct y as [g0 Hg]; destruct z as [h0 Hh].
simpl.
repeat destruct sup; simpl.
apply i.
red; intros.
destruct H.
rewrite H0.
apply Rle_trans with (d (f0 x2) (g0 x2) + d (g0 x2) (h0 x2)).
apply d_metric.
assert (d (f0 x2) (g0 x2) <= x0) by
  (apply i0; exists x2; trivial).
assert (d (g0 x2) (h0 x2) <= x1) by
  (apply i1; exists x2; trivial).
auto with real.

destruct x as [f0 Hf].
simpl.
destruct sup; simpl.
apply Rle_antisym.
apply i.
red; intros.
destruct H.
rewrite metric_zero in H0; trivial.
right; trivial.
apply i.
destruct X_inhabited as [x0].
exists x0.
constructor.
symmetry; apply d_metric.

destruct x as [f0 Hf]; destruct y as [g0 Hg].
Require Import Proj1SigInjective.
apply subset_eq_compatT.
Require Import FunctionalExtensionality.
extensionality x.
apply d_metric.
simpl in H.
destruct sup in H.
simpl in H.
rewrite H in i; clear H.
apply Rle_antisym.
apply i; exists x; trivial.
constructor.
cut (d (f0 x) (g0 x) >= 0); auto with real.
apply d_metric.
Qed.

Definition UniformTopology : TopologicalSpace :=
  MetricTopology uniform_metric uniform_metric_is_metric.

Require Import Completeness.

Lemma uniform_metric_complete: complete d d_metric ->
  complete uniform_metric uniform_metric_is_metric.
Proof.
intros.
assert (forall y:Net nat_DS (MetricTopology d d_metric), cauchy d y ->
  { y0:Y | net_limit y y0 }) as cauchy_limit.
intros.
Require Import Description.
apply constructive_definite_description.
apply -> unique_existence; split.
apply H; trivial.
apply (Hausdorff_impl_net_limit_unique y).
apply T3_sep_impl_Hausdorff.
apply normal_sep_impl_T3_sep.
apply metrizable_impl_normal_sep.
exists d; trivial; apply MetricTopology_metrizable.

red; intros f ?.
unshelve refine (let H1 := _ in let H2 := _ in ex_intro _
  (exist _ (fun x:X => proj1_sig (cauchy_limit
                  (fun n:nat => proj1_sig (f n) x) (H1 x))) H2) _); [ | clearbody H1 | clearbody H1 H2 ].
intros.
red; intros.
destruct (H0 eps H1) as [N].
exists N; intros.
apply Rle_lt_trans with (uniform_metric (f m) (f n)).
unfold uniform_metric.
destruct (f m) as [f0 Hf]; destruct (f n) as [g0 Hg]; destruct sup.
simpl.
apply i.
exists x; trivial; constructor.
apply H2; trivial.

assert (1 > 0) by (red; auto with real).
destruct (H0 1 H2) as [N].
pose (fN := f N).
assert (f N = fN) by reflexivity.
destruct fN as [fN [M]].
assert (forall (n:nat) (x:X), (n >= N)%nat -> d (proj1_sig (f n) x)
                                               (proj1_sig (f N) x) < 1).
intros.
apply Rle_lt_trans with (uniform_metric (f n) (f N)).
unfold uniform_metric; destruct (f n) as [f0 Hf];
  destruct (f N) as [g0 Hg]; destruct sup; simpl.
apply i0.
exists x; trivial.
constructor.
apply H3; trivial.
constructor.
assert (forall x:X,
  d (fN x) (proj1_sig (cauchy_limit _ (H1 x))) <= 1).
intros.
apply lt_plus_epsilon_le.
intros.
destruct cauchy_limit; simpl.
pose proof (metric_space_net_limit_converse _ _
  (MetricTopology_metrizable _ d d_metric) nat_DS
  (fun n:nat => proj1_sig (f n) x) x0 n).
destruct (H7 eps H6) as [i0].
Require Import Max.
pose (N' := max N i0).
apply Rle_lt_trans with (d (fN x) (proj1_sig (f N') x) +
                         d x0 (proj1_sig (f N') x)).
rewrite metric_sym with (x:=x0) (y:=proj1_sig (f N') x); trivial.
apply d_metric.
replace (fN x) with (proj1_sig (f N) x).
assert (d (proj1_sig (f N) x) (proj1_sig (f N') x) < 1).
rewrite metric_sym; trivial.
apply H5.
apply le_max_l.
assert (d x0 (proj1_sig (f N') x) < eps).
apply H8.
apply le_max_r.
auto with real.
rewrite H4; reflexivity.
exists (M+1).
red; intros.
destruct H7.
rewrite H8; clear H8.
apply Rle_trans with (d (y0 x) (fN x) + d (fN x)
                                   (proj1_sig (cauchy_limit _ (H1 x)))).
apply d_metric.
assert (d (y0 x) (fN x) <= M).
apply i.
exists x; trivial.
auto with real.

apply metric_space_net_limit with uniform_metric.
apply MetricTopology_metrizable.
intros.
Require Import Fourier.
assert (eps/2 > 0) by fourier.
destruct (H0 (eps/2) H4) as [N].
exists N; intros.
apply Rle_lt_trans with (eps/2); try fourier.
unfold uniform_metric; remember (f j) as fj; destruct fj as [fj].
destruct sup; simpl.
apply i.
red; intros.
destruct H7.
rewrite H8; clear y H8.
apply lt_plus_epsilon_le; intros.
destruct (cauchy_limit (fun n:nat => proj1_sig (f n) x0) (H1 x0));
  simpl.
pose proof (metric_space_net_limit_converse _ _
  (MetricTopology_metrizable _ d d_metric) nat_DS
  (fun n:nat => proj1_sig (f n) x0) x1 n).
destruct (H9 eps0 H8) as [N'].
pose (N'' := max N N').
apply Rle_lt_trans with (d x1 (proj1_sig (f N'') x0) +
                        d (proj1_sig (f N'') x0) (proj1_sig (f j) x0)).
repeat rewrite <- Heqfj; simpl.
apply d_metric.
assert (d x1 (proj1_sig (f N'') x0) < eps0).
apply H10.
apply le_max_r.
assert (d (proj1_sig (f N'') x0) (proj1_sig (f j) x0) < eps/2).
apply Rle_lt_trans with (uniform_metric (f N'') (f j)).
unfold uniform_metric; destruct (f N'') as [f1];
  destruct (f j) as [f2]; destruct sup; simpl.
apply i0; exists x0; trivial.
apply H5; trivial.
apply le_max_l.
rewrite (Rplus_comm (eps/2) eps0).
auto with real.
Qed.

End UniformTopology.

Arguments uniform_space [X] [Y].
Arguments uniform_metric [X] [Y].
Arguments UniformTopology [X] [Y].

Section UniformTopology_and_continuity.

Variable X:TopologicalSpace.
Variable Y:Type.
Variable d:Y->Y->R.
Variable y0:point_set X -> Y.
Hypothesis d_metric: metric d.
Hypothesis X_inh: inhabited (point_set X).

Lemma continuous_functions_at_point_closed_in_uniform_metric:
  forall x0:point_set X,
  closed (fun f:uniform_space d y0 => continuous_at (proj1_sig f) x0
                                      (Y:=MetricTopology d d_metric))
    (X:=UniformTopology d y0 d_metric X_inh).
Proof.
intros.
match goal with |- @closed ?X ?F => cut (Included (@closure X F) F) end.
intros.
match type of H with | Included ?A ?B => assert (A=B) end.
apply Extensionality_Ensembles; split; trivial;
  apply closure_inflationary.
rewrite <- H0; apply closure_closed.
red; intros f0 ?.
red.
apply first_countable_sequence_closure in H.
destruct H as [f []].
pose proof (MetricTopology_metrizable _ d d_metric
  (proj1_sig f0 x0)).
apply open_neighborhood_basis_is_neighborhood_basis in H1.
apply continuous_at_neighborhood_basis with (1:=H1).
intros.
destruct H2.
assert (r/3>0) by fourier.
destruct (metric_space_net_limit_converse _ _
  (MetricTopology_metrizable _ _
     (uniform_metric_is_metric _ _ d y0 d_metric X_inh))
  nat_DS f f0 H0 (r/3) H3) as [N].
assert (neighborhood
  (inverse_image (proj1_sig (f N))
     (open_ball _ d (proj1_sig (f N) x0) (r/3))) x0).
apply H.
pose proof (MetricTopology_metrizable _ d d_metric
  (proj1_sig (f N) x0)).
apply open_neighborhood_basis_is_neighborhood_basis in H5.
apply H5.
constructor; trivial.
match goal with H5:neighborhood ?U x0 |- neighborhood ?V x0 =>
  cut (Included U V) end.
intros.
destruct H5 as [U []].
exists U; auto with sets.
red; intros.
destruct H6.
destruct H6.
constructor.
constructor.
apply Rle_lt_trans with
  (d (proj1_sig f0 x0) (proj1_sig (f N) x0) +
   d (proj1_sig (f N) x0) (proj1_sig f0 x)).
apply d_metric.
apply Rle_lt_trans with
  (d (proj1_sig f0 x0) (proj1_sig (f N) x0) +
   d (proj1_sig (f N) x0) (proj1_sig (f N) x) +
   d (proj1_sig (f N) x) (proj1_sig f0 x)).
assert (d (proj1_sig (f N) x0) (proj1_sig f0 x) <=
        d (proj1_sig (f N) x0) (proj1_sig (f N) x) +
        d (proj1_sig (f N) x) (proj1_sig f0 x)) by apply d_metric.
fourier.
assert (forall x':point_set X,
  d (proj1_sig f0 x') (proj1_sig (f N) x') < r/3).
intros.
apply Rle_lt_trans with (uniform_metric d y0 d_metric X_inh f0 (f N)).
unfold uniform_metric; destruct f0 as [f0]; destruct (f N) as [fN];
  destruct sup; simpl.
apply i.
exists x'; trivial.
constructor.
apply H4; simpl; auto with arith.
rewrite (metric_sym _ d d_metric (proj1_sig (f N) x) (proj1_sig f0 x)).
pose proof (H7 x0); pose proof (H7 x).
fourier.

apply metrizable_impl_first_countable.
exists (uniform_metric d y0 d_metric X_inh).
exact (uniform_metric_is_metric _ _ d y0 d_metric X_inh).
apply MetricTopology_metrizable.
Qed.

Lemma continuous_functions_closed_in_uniform_metric:
  closed (fun f:uniform_space d y0 => continuous (proj1_sig f)
                                      (Y:=MetricTopology d d_metric))
    (X:=UniformTopology d y0 d_metric X_inh).
Proof.
replace (fun f:uniform_space d y0 => continuous (proj1_sig f)
                                     (Y:=MetricTopology d d_metric)) with
  (IndexedIntersection (fun (x0:point_set X) (f:uniform_space d y0) =>
         continuous_at (proj1_sig f) x0 (Y:=MetricTopology d d_metric))).
apply (@closed_indexed_intersection (UniformTopology d y0 d_metric X_inh)).
apply continuous_functions_at_point_closed_in_uniform_metric.

apply Extensionality_Ensembles; split; intros f ?.
destruct H.
apply pointwise_continuity; trivial.
constructor; intros x.
unfold In in H |-*.
apply continuous_func_continuous_everywhere; trivial.
Qed.

End UniformTopology_and_continuity.


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Hints.Core.
Local Open Scope Z_scope.

Module Z.
  Lemma pow_1_l_Zpos a : 1^Zpos a = 1.
  Proof. apply Z.pow_1_l; lia. Qed.
#[global]
  Hint Rewrite pow_1_l_Zpos : zsimplify_fast zsimplify_const zsimplify.
  Lemma pow_1_l_0 : 1^Z0 = 1. Proof. reflexivity. Qed.
#[global]
  Hint Rewrite pow_1_l_0 : zsimplify_fast zsimplify_const zsimplify.
  Lemma pow_r_Zneg a b : a^Zneg b = 0. Proof. reflexivity. Qed.
#[global]
  Hint Rewrite pow_r_Zneg : zsimplify_fast zsimplify_const zsimplify.
  Lemma pow_1_l_Zof_nat a : 1^Z.of_nat a = 1.
  Proof. apply Z.pow_1_l; lia. Qed.
#[global]
  Hint Rewrite pow_1_l_Zof_nat : zsimplify_fast zsimplify_const zsimplify.
  Lemma pow_0_l_Zpos a : 0^Zpos a = 0.
  Proof. apply Z.pow_0_l; lia. Qed.
#[global]
  Hint Rewrite pow_0_l_Zpos : zsimplify_fast zsimplify_const zsimplify.

  Lemma sub_same_minus (x y : Z) : x - (x - y) = y.
  Proof. lia. Qed.
#[global]
  Hint Rewrite sub_same_minus : zsimplify.
  Lemma sub_same_plus (x y : Z) : x - (x + y) = -y.
  Proof. lia. Qed.
#[global]
  Hint Rewrite sub_same_plus : zsimplify.
  Lemma sub_same_minus_plus (x y z : Z) : x - (x - y + z) = y - z.
  Proof. lia. Qed.
#[global]
  Hint Rewrite sub_same_minus_plus : zsimplify.
  Lemma sub_same_plus_plus (x y z : Z) : x - (x + y + z) = -y - z.
  Proof. lia. Qed.
#[global]
  Hint Rewrite sub_same_plus_plus : zsimplify.
  Lemma sub_same_minus_minus (x y z : Z) : x - (x - y - z) = y + z.
  Proof. lia. Qed.
#[global]
  Hint Rewrite sub_same_minus_minus : zsimplify.
  Lemma sub_same_plus_minus (x y z : Z) : x - (x + y - z) = z - y.
  Proof. lia. Qed.
#[global]
  Hint Rewrite sub_same_plus_minus : zsimplify.
  Lemma sub_same_minus_then_plus (x y w : Z) : x - (x - y) + w = y + w.
  Proof. lia. Qed.
#[global]
  Hint Rewrite sub_same_minus_then_plus : zsimplify.
  Lemma sub_same_plus_then_plus (x y w : Z) : x - (x + y) + w = w - y.
  Proof. lia. Qed.
#[global]
  Hint Rewrite sub_same_plus_then_plus : zsimplify.
  Lemma sub_same_minus_plus_then_plus (x y z w : Z) : x - (x - y + z) + w = y - z + w.
  Proof. lia. Qed.
#[global]
  Hint Rewrite sub_same_minus_plus_then_plus : zsimplify.
  Lemma sub_same_plus_plus_then_plus (x y z w : Z) : x - (x + y + z) + w = w - y - z.
  Proof. lia. Qed.
#[global]
  Hint Rewrite sub_same_plus_plus_then_plus : zsimplify.
  Lemma sub_same_minus_minus_then_plus (x y z w : Z) : x - (x - y - z) + w = y + z + w.
  Proof. lia. Qed.
#[global]
  Hint Rewrite sub_same_minus_minus : zsimplify.
  Lemma sub_same_plus_minus_then_plus (x y z w : Z) : x - (x + y - z) + w = z - y + w.
  Proof. lia. Qed.
#[global]
  Hint Rewrite sub_same_plus_minus_then_plus : zsimplify.

  Lemma simplify_twice_sub_sub x y : 2 * x - (x - y) = x + y.
  Proof. lia. Qed.
#[global]
  Hint Rewrite simplify_twice_sub_sub : zsimplify.

  Lemma simplify_twice_sub_add x y : 2 * x - (x + y) = x - y.
  Proof. lia. Qed.
#[global]
  Hint Rewrite simplify_twice_sub_add : zsimplify.

  Lemma simplify_2XmX X : 2 * X - X = X.
  Proof. lia. Qed.
#[global]
  Hint Rewrite simplify_2XmX : zsimplify.

  Lemma simplify_add_pos x y : Z.pos x + Z.pos y = Z.pos (x + y).
  Proof. reflexivity. Qed.
#[global]
  Hint Rewrite simplify_add_pos : zsimplify_Z_to_pos.
  Lemma simplify_add_pos10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9
    : Z.pos x0 + (Z.pos x1 + (Z.pos x2 + (Z.pos x3 + (Z.pos x4 + (Z.pos x5 + (Z.pos x6 + (Z.pos x7 + (Z.pos x8 + Z.pos x9))))))))
      = Z.pos (x0 + (x1 + (x2 + (x3 + (x4 + (x5 + (x6 + (x7 + (x8 + x9))))))))).
  Proof. reflexivity. Qed.
#[global]
  Hint Rewrite simplify_add_pos10 : zsimplify_Z_to_pos.
  Lemma simplify_mul_pos x y : Z.pos x * Z.pos y = Z.pos (x * y).
  Proof. reflexivity. Qed.
#[global]
  Hint Rewrite simplify_mul_pos : zsimplify_Z_to_pos.
  Lemma simplify_mul_pos10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9
    : Z.pos x0 * (Z.pos x1 * (Z.pos x2 * (Z.pos x3 * (Z.pos x4 * (Z.pos x5 * (Z.pos x6 * (Z.pos x7 * (Z.pos x8 * Z.pos x9))))))))
      = Z.pos (x0 * (x1 * (x2 * (x3 * (x4 * (x5 * (x6 * (x7 * (x8 * x9))))))))).
  Proof. reflexivity. Qed.
#[global]
  Hint Rewrite simplify_mul_pos10 : zsimplify_Z_to_pos.
  Lemma simplify_sub_pos x y : Z.pos x - Z.pos y = Z.pos_sub x y.
  Proof. reflexivity. Qed.
#[global]
  Hint Rewrite simplify_sub_pos : zsimplify_Z_to_pos.

  Lemma two_sub_sub_inner_sub x y z : 2 * x - y - (x - z) = x - y + z.
  Proof. clear; lia. Qed.
#[global]
  Hint Rewrite two_sub_sub_inner_sub : zsimplify.

  Lemma minus_minus_one : - -1 = 1.
  Proof. reflexivity. Qed.
#[global]
  Hint Rewrite minus_minus_one : zsimplify zsimplify_fast zsimplify_const.
End Z.


From Coq Require Import Bool List ListSet Compare_dec RelationClasses Lia.
Import ListNotations.

From CasperCBC Require Import Preamble ListExtras ListSetExtras.

(** * Topological sorting implementation *)

(**
This module describes an algorithm producing a linear extension for a
given partial order using an algorithm similar to Kahn's topological
sorting algorithm.

The algorithm extracts an element with a minimal number of predecessors
among the current elements, then recurses on the remaining elements.

To begin with we assume an unconstrained <<preceeds>> function to say
whether an element preceeds another.  The proofs will show that if
<<preceeds>> determines a strict order on the set of elements in the list,
then the [top_sort] algoritm produces a linear extension of that ordering
(Lemmas [top_sort_preceeds] and [top_sort_preceeds_before]).
*)

Section min_predecessors.
(** ** Finding an element with a minimal number of predecessors *)

(** For this section we will fix a list <<l>> and count the predecessors
occurring in that list. *)

Context {A} (preceeds : A -> A -> Prop) {rd: RelDecision preceeds} (l : list A).

Definition count_predecessors
  (a : A)
  : nat
  := length (filter (fun b => bool_decide (preceeds b a)) l).

Lemma zero_predecessors
  (a : A)
  (Ha : count_predecessors a = 0)
  : Forall (fun b => bool_decide (preceeds b a) = false) l.
Proof.
  apply filter_nil.
  apply length_zero_iff_nil.
  assumption.
Qed.

(**
Finds an element minimizing [count_predecessesors] in <<min :: remainder>>
*)

Fixpoint min_predecessors
  (remainder : list A)
  (min : A)
  : A
  :=
  match remainder with
  | [] => min
  | h::t =>
    if (lt_dec (count_predecessors h) (count_predecessors min))
    then min_predecessors t h
    else min_predecessors t min
  end.

Lemma min_predecessors_in
  (l' : list A)
  (a : A)
  (min := min_predecessors l' a)
  : min = a \/ In min l'.
Proof.
  unfold min; clear min. revert a.
  induction l';try (left; reflexivity).
  intro a0. simpl.
  destruct (lt_dec _ _);
    [specialize (IHl' a)|specialize (IHl' a0)];
    destruct IHl';intuition.
Qed.

Lemma min_predecessors_correct
  (l' : list A)
  (a : A)
  (min := min_predecessors l' a)
  (mins := count_predecessors min)
  : Forall (fun b => mins <= count_predecessors b) (a :: l').
Proof.
  unfold mins; clear mins. unfold min; clear min. generalize dependent a.
  induction l'; intros; rewrite Forall_forall; intros.
  - simpl in H. inversion H; try contradiction. subst; clear H.
    simpl. lia.
  - apply in_inv in H. destruct H as [Heq | Hin]; subst.
    + simpl. destruct (lt_dec (count_predecessors a) (count_predecessors x)).
      * specialize (IHl' a). rewrite Forall_forall in IHl'.
        assert (Ha : In a (a :: l')) by (left; reflexivity).
        specialize (IHl' a Ha).
        lia.
      * specialize (IHl' x). rewrite Forall_forall in IHl'.
        assert (Hx : In x (x :: l')) by (left; reflexivity).
        specialize (IHl' x Hx).
        assumption.
    + simpl. destruct (lt_dec (count_predecessors a) (count_predecessors a0)).
      * specialize (IHl' a). rewrite Forall_forall in IHl'.
        specialize (IHl' x Hin).
        assumption.
      * apply not_lt in n. unfold ge in n.
        { destruct Hin as [Heq | Hin]; subst.
        - specialize (IHl' a0). rewrite Forall_forall in IHl'.
          assert (Ha0 : In a0 (a0 :: l')) by (left; reflexivity).
          specialize (IHl' a0 Ha0).
          lia.
        - specialize (IHl' a0). rewrite Forall_forall in IHl'.
          assert (Hx : In x (a0 :: l')) by (right; assumption).
          specialize (IHl' x Hx).
          assumption.
        }
Qed.

(** Given <<P>> a property on <<A>>, [preceeds_P] is the relation
induced by <<preceeds>> on the subset of <<A>> determined by <<P>>. *)

Definition preceeds_P
  (P : A -> Prop)
  (x y : sig P)
  : Prop
  := preceeds (proj1_sig x) (proj1_sig y).

(** In what follows, let us fix a property <<P>> satisfied by all elements
of <<l>>, such that [preceeds_P] <<P>> is a [StrictOrder].

Consequently, this means that <<preceeds>> is a [StrictOrder] on the
elements of <<l>>.
*)

Context
  (P : A -> Prop)
  (HPl : Forall P l)
  {Hso : StrictOrder (preceeds_P P)}
  .

(** Next we derive easier to work with formulations for the [StrictOrder]
properties associated with [preceeds_P]. *)
Lemma preceeds_irreflexive
  (a : A)
  (Ha : P a)
  : ~ preceeds a a.
Proof.
  specialize (StrictOrder_Irreflexive (exist P a Ha)).
  unfold complement; unfold preceeds_P; simpl; intro Hirr.
  destruct (decide (preceeds a a)); assumption.
Qed.

Lemma preceeds_asymmetric
  (a b : A)
  (Ha : P a)
  (Hb : P b)
  (Hab : preceeds a b)
  : ~ preceeds b a.
Proof.
  intro Hba.
  exact
    (StrictOrder_Asymmetric Hso
      (exist P a Ha) (exist P b Hb)
      Hab Hba
    ).
Qed.

Lemma preceeds_transitive
  (a b c : A)
  (Ha : P a)
  (Hb : P b)
  (Hc : P c)
  (Hab : preceeds a b)
  (Hbc : preceeds b c)
  : preceeds a c.
Proof.
  exact
    (RelationClasses.StrictOrder_Transitive
      (exist P a Ha) (exist P b Hb) (exist P c Hc)
      Hab Hbc
    ).
Qed.

(** If <<preceeds>> is a [StrictOrder] on <<l>>, then there must exist an
element of <<l>> with no predecessors in <<l>>.
*)
Lemma count_predecessors_zero
  (Hl : l <> [])
  : Exists (fun a => count_predecessors a = 0) l.
Proof.
  unfold count_predecessors.
  induction l.
  - elim Hl;reflexivity.
  - inversion_clear HPl as [|? ? HPa HPl0].
    specialize (IHl0 HPl0).
    apply Exists_cons.
    simpl.
    rewrite bool_decide_eq_false_2 by (apply preceeds_irreflexive;assumption).

    assert ({l0=[]}+{l0<>[]}) by (destruct l0;clear;[left|right];congruence).
    destruct H as [?|Hl0];[subst l0|].
    + left. reflexivity.
    + specialize (IHl0 Hl0).
      apply Exists_exists in IHl0.
      destruct IHl0 as [x [Hin Hlen]].
      destruct (decide (preceeds a x)).
      * left. (* inversion H2; subst. *)
        specialize (Forall_forall P l0); intros [Hall _].
        specialize (Hall HPl0 x Hin).
        match goal with |- ?X = 0  => cut (X <= 0) end.
        lia.
        rewrite <- Hlen;clear Hlen.
        apply filter_length_fn.
        revert HPl0.
        apply Forall_impl.
        setoid_rewrite bool_decide_eq_true.
        intros;apply preceeds_transitive with a;assumption.
      * right. apply Exists_exists. exists x. split; try assumption.
        rewrite bool_decide_eq_false_2;assumption.
Qed.

(**
Hence, computing [min_predecessors] on <<l>> yields an element with
no predecessors.
*)
Lemma min_predecessors_zero
  (l' : list A)
  (a : A)
  (Hl : l = a :: l')
  (min := min_predecessors l' a)
  : count_predecessors min = 0.
Proof.
  assert (Hl' : l <> []) by (intro H; rewrite Hl in H; inversion H).
  specialize (count_predecessors_zero Hl'); intro Hx.
  apply Exists_exists in Hx. destruct Hx as [x [Hinx Hcountx]].
  specialize (min_predecessors_correct l' a); simpl; intro Hall.
  rewrite Forall_forall in Hall.
  rewrite Hl in Hinx.
  specialize (Hall x Hinx).
  unfold min.
  lia.
Qed.

End min_predecessors.

Section topologically_sorted.

(** ** Topologically sorted lists. Definition and properties. *)

Context {A} (preceeds : A -> A -> Prop) {rd: RelDecision preceeds} (l : list A).

(**
We say that a list <<l>> is [topologically_sorted] w.r.t a <<preceeds>>
relation iff <<a preceeds b>> implies that <<a>> cannot occur after <<b>> in <<l>>.
*)
Definition topologically_sorted
  :=
  forall
    (a b : A)
    (Hab : preceeds a b)
    (l1 l2 : list A)
    (Heq : l = l1 ++ [b] ++ l2)
    , ~In a l2.

(** The following properties assume that <<preceeds>> determines a [StrictOrder]
on the list
*)
Context
  (P : A -> Prop)
  {Hso : StrictOrder (preceeds_P preceeds P)}
  .

Section topologically_sorted_fixed_list.

Context
  (Hl : Forall P l)
  (Hts : topologically_sorted)
  .

(** If <<l>> is [topologically_sorted], then for any occurences
of <<a>> and <<b>> in <<l>> such that <<a preceeds b>> it must be that
the occurrence of <<a>> is before that of <<b>>.

Hence all occurrences of <<a>> must be before all occurrences of <<b>> in
a [topologically_sorted] list.
*)
Lemma topologically_sorted_occurrences_ordering
  (a b : A)
  (Hab : preceeds a b)
  (la1 la2 : list A)
  (Heqa : l = la1 ++ [a] ++ la2)
  (lb1 lb2 : list A)
  (Heqb : l = lb1 ++ [b] ++ lb2)
  : exists (lab : list A), lb1 = la1 ++ a :: lab.
Proof.
  assert (Hpa : P a).
  { rewrite Forall_forall in Hl. apply Hl. rewrite Heqa. apply in_elt. }
  specialize (Hts a b Hab lb1 lb2 Heqb).
  rewrite Heqa in Heqb.
  assert (Ha : ~In a (b :: lb2)).
  { intro Ha. apply Hts. destruct Ha; try assumption. subst.
    apply (preceeds_irreflexive preceeds P a Hpa) in Hab.
    contradict Hab.
  }
  specialize (occurrences_ordering a b la1 la2 lb1 lb2 Heqb Ha).
  intro; assumption.
Qed.

(**
If <<a>> and <<b>> are in a [topologically_sorted] list <<lts>> and <<a preceeds b>>
then there is an <<a>> before any occurence of <<b>> in <<lts>>.
*)
Corollary top_sort_before
  (a b : A)
  (Hab : preceeds a b)
  (Ha : In a l)
  (l1 l2 : list A)
  (Heq : l = l1 ++ [b] ++ l2)
  : In a l1.
Proof.
  apply in_split in Ha.
  destruct Ha as [la1 [la2 Ha]].
  specialize (topologically_sorted_occurrences_ordering a b Hab la1 la2 Ha l1 l2 Heq).
  intros [lab Hlab].
  subst. apply in_elt.
Qed.

(** As a corollary of the above, if <<a preceeds b>> then <<a>> can be found before
<<b>> in l.

*)
Corollary top_sort_preceeds
  (a b : A)
  (Hab : preceeds a b)
  (Ha : In a l)
  (Hb : In b l)
  : exists l1 l2 l3, l = l1 ++ [a] ++ l2 ++ [b] ++ l3.
Proof.
  apply in_split in Hb.
  destruct Hb as [l12 [l3 Hb']].
  specialize (top_sort_before a b Hab Ha l12 l3 Hb').
  intros Ha12. apply in_split in Ha12.
  destruct Ha12 as [l1 [l2 Ha12]].
  subst l12.
  exists l1. exists l2. exists l3. rewrite Hb'. rewrite <- app_assoc.
  reflexivity.
Qed.

End topologically_sorted_fixed_list.
End topologically_sorted.

Lemma toplogically_sorted_remove_last
  {A : Type}
  (preceeds : A -> A -> Prop)
  {rd: RelDecision preceeds}
  (l : list A)
  (Hts : topologically_sorted preceeds l)
  (init : list A)
  (final : A)
  (Hinit : l = init ++ [final])
  : topologically_sorted preceeds init.
Proof.
  subst l.
  intros a b Hab l1 l2 Hinit.
  specialize (Hts a b Hab l1 (l2 ++ [final])).
  rewrite Hinit in Hts. repeat rewrite <- app_assoc in Hts.
  specialize (Hts eq_refl). intro Hnin. apply Hts.
  apply in_app_iff. left. assumption.
Qed.

Definition preceeds_closed
  {A : Type}
  (preceeds : A -> A -> Prop)
  {rd: RelDecision preceeds}
  (s : set A)
  : Prop
  :=
  Forall (fun (b : A) => forall (a : A) (Hmj : preceeds a b), In a s) s.

Lemma preceeds_closed_set_eq
  {A : Type}
  (preceeds : A -> A -> Prop)
  {rd: RelDecision preceeds}
  (s1 s2 : set A)
  (Heq : set_eq s1 s2)
  : preceeds_closed preceeds s1 <-> preceeds_closed preceeds s2.
Proof.
  unfold preceeds_closed. repeat rewrite Forall_forall.
  split; intros Hpc b Hb a Hab
  ; apply Heq; apply Heq in Hb; apply (Hpc b Hb)
  ; assumption.
Qed.

Lemma topologically_sorted_preceeds_closed_remove_last
  {A : Type}
  (preceeds : A -> A -> Prop)
  {rd: RelDecision preceeds}
  (P : A -> Prop)
  {Hso : StrictOrder (preceeds_P preceeds P)}
  (l : list A)
  (Hl : Forall P l)
  (Hts : topologically_sorted preceeds l)
  (init : list A)
  (final : A)
  (Hinit : l = init ++ [final])
  (Hpc : preceeds_closed preceeds l)
  : preceeds_closed preceeds init.
Proof.
  unfold preceeds_closed in *.
  rewrite Forall_forall in Hpc. rewrite Forall_forall.
  subst l.
  intros b Hb a Hab.
  assert (Hb' : In b (init ++ [final])) by (apply in_app_iff; left; assumption).
  specialize (Hpc b Hb' a Hab). apply in_app_iff in Hpc.
  destruct Hpc as [Ha | Ha]; try assumption.
  destruct Ha as [Heq | Hn]; try inversion Hn.
  subst final.
  apply in_split in Hb'.
  destruct Hb' as [l1 [l2 Heq]].
  specialize
    (topologically_sorted_occurrences_ordering preceeds
      (init ++ [a]) P Hl Hts a b Hab init [] eq_refl l1 l2 Heq
    ).
  intros [lab Hlab].
  rewrite Hlab in Heq. exfalso. clear -Heq.
  simpl in Heq. rewrite <- app_assoc in Heq. simpl in Heq.
  apply app_inv_head in Heq. inversion Heq.
  symmetry in H0. apply app_eq_nil in H0.
  destruct H0 as [_ H].
  inversion H.
Qed.

Section top_sort.
(** ** The topological sorting algorithm *)

Context {A} `{EqDecision A} (preceeds : A -> A -> Prop) {rd: RelDecision preceeds}.

(** Iteratively extracts <<n>> elements with minimal number of precessors
from a given list.
 *)

Fixpoint top_sort_n
  (n : nat)
  (l : list A)
  : list A
  :=
  match n,l with
  | 0, _ => []
  | _, [] => []
  | S n', a :: l' =>
    let min := min_predecessors preceeds l l' a in
    let l'' := set_remove decide_eq min l in
    min :: top_sort_n n' l''
  end.

(** Repeats the procedure above to order all elements from the input list.
*)
Definition top_sort
  (l : list A)
  : list A
  := top_sort_n (length l) l.

(** The result of [top_sort] and its input are equal as sets.
*)
Lemma top_sort_set_eq
  (l : list A)
  : set_eq l (top_sort l).
Proof.
  unfold top_sort.
  remember (length l) as n. generalize dependent l.
  induction n; intros; destruct l; try apply set_eq_refl
  ; inversion Heqn.
  simpl.
  remember (min_predecessors preceeds (a :: l) l a) as min.
  remember (set_remove decide_eq min l) as l'.
  destruct (decide (min = a)); try rewrite e.
  - apply set_eq_cons. specialize (IHn l H0). subst. assumption.
  - specialize (min_predecessors_in preceeds (a :: l) l a).
    rewrite <- Heqmin. simpl. intros [Heq | Hin]; try (elim n0; assumption).
    specialize (IHn (a :: l')).
    specialize (set_remove_length min l Hin).
    rewrite <- Heql'. rewrite <- H0. intro Hlen.
    specialize (IHn Hlen).
    split; intros x [Heq | Hinx]; try (subst x).
    + right. apply IHn. left. reflexivity.
    + destruct (decide (x = min)); try subst x.
      * left. reflexivity.
      * specialize (set_remove_3 decide_eq l Hinx n1).
        rewrite <- Heql'. intro Hinx'.
        right. apply IHn. right. assumption.
    + right. assumption.
    + apply IHn in Hinx.
      destruct Hinx as [Heq | Hinx]; try (subst; left; reflexivity).
      right. subst. apply set_remove_1 in Hinx. assumption.
Qed.

Lemma top_sort_nodup
  (l : list A)
  (Hl : NoDup l)
  : NoDup (top_sort l).
Proof.
  unfold top_sort.
  remember (length l) as len.
  generalize dependent l.
  induction len; intros.
  - symmetry in Heqlen. apply length_zero_iff_nil in Heqlen. subst l.
    constructor.
  - destruct l as [| a l].
    + constructor.
    + simpl.
      assert (Hl' : NoDup l) by (inversion Hl; assumption).
      assert (Hlen : len = length l) by (inversion Heqlen; reflexivity).
      assert (Hl'' : NoDup (set_remove decide_eq (min_predecessors preceeds (a :: l) l a) l))
        by (apply set_remove_nodup; assumption).
      destruct (decide (min_predecessors preceeds (a :: l) l a = a)); constructor.
      * specialize (IHlen l Hl'  Hlen).
        rewrite e in *.
        inversion Hl; subst x l0. intro Ha. elim H1.
        apply top_sort_set_eq. subst len. assumption.
      * apply IHlen; try assumption.
      * intro Hmin.
        assert (Hlen' : len = length (a :: set_remove decide_eq (min_predecessors preceeds (a :: l) l a) l)).
        { simpl.
          rewrite <- set_remove_length; try assumption.
          pose (@min_predecessors_in _ preceeds _ (a :: l) l a) as Hin.
          destruct Hin as [Heq | Hin]; try assumption.
          elim n. assumption.
        }
        rewrite Hlen' in Hmin.
        apply (proj2 (top_sort_set_eq (a :: set_remove decide_eq (min_predecessors preceeds (a :: l) l a) l)))
          in Hmin.
        destruct Hmin; try (symmetry in H; elim n; assumption).
        apply set_remove_2 in H; try assumption.
        elim H. reflexivity.
      * { apply IHlen.
        - constructor; try assumption.
          intro Ha. apply set_remove_iff in Ha; try assumption.
          destruct Ha as [Ha _].
          inversion Hl. elim H1. assumption.
        - simpl.
          rewrite <- set_remove_length; try assumption.
          pose (@min_predecessors_in _ preceeds _ (a :: l) l a) as Hin.
          destruct Hin as [Heq | Hin]; try assumption.
          elim n. assumption.
        }
Qed.

Context
  (P : A -> Prop)
  {Hso : StrictOrder (preceeds_P preceeds P)}
  (l : list A)
  (Hl : Forall P l)
  .

(** Under the assumption that <<preceeds>> induces a [StrictOrder] on the elements of
<<l>>, [top_sort] <<l>> is [topologically_sorted].

*)
Lemma top_sort_sorted : topologically_sorted preceeds (top_sort l).
Proof.
  intro a; intros.
  intro Ha2.
  assert (Ha : In a l).
  { apply top_sort_set_eq.
    rewrite Heq. simpl. apply in_app_iff. right. right. assumption.
  }
  unfold top_sort in Heq.
  remember (length l) as n.
  generalize dependent Heq.
  generalize dependent l2.
  generalize dependent l1.
  generalize dependent Ha.
  generalize dependent Hab.
  generalize dependent b.
  generalize dependent a.
  generalize dependent l. clear Hl l.
  induction n; intros
  ; try (symmetry in Heqn;  apply length_zero_iff_nil in Heqn; subst l; inversion Ha).
  destruct l as [| a0 l0]; inversion Hl; subst; simpl in Heq.
  + inversion Ha.
  + remember (min_predecessors preceeds (a0 :: l0) l0 a0) as min.
    remember
      (match decide (min = a0) return (set A) with
      | left _ => l0
      | right _ => @cons A a0 (set_remove decide_eq min l0)
      end) as l'.
    inversion Heqn.
    assert (Hall' : Forall P l').
    { rewrite Forall_forall. intros x Hx.
      rewrite Forall_forall in H2.
      destruct (decide (min = a0)).
      - subst a0 l'. apply H2. assumption.
      - subst l'.
        destruct Hx as [Heqx | Hx]; try (subst; assumption).
        apply set_remove_1 in Hx.
        apply H2. assumption.
    }
    assert (Hlenl' : n = length l').
    { destruct (decide (min = a0)).
      - subst a0.
        subst l'. assumption.
      - subst l'. simpl.
        rewrite <- set_remove_length; try assumption.
        specialize (min_predecessors_in preceeds (a0 :: l0) l0 a0).
        rewrite <- Heqmin. simpl.
        intros [Heq' | Hin]; try assumption.
        elim n0. assumption.
    }
    specialize (IHn l' Hall' Hlenl' a b Hab).
    assert (Hminb : b <> min).
    { destruct (decide (b = min)); try assumption.
      subst b.
      specialize (min_predecessors_zero preceeds (a0 :: l0) P Hl l0 a0 eq_refl).
      rewrite <- Heqmin. simpl. intro Hmin.
      apply zero_predecessors in Hmin.
      rewrite Forall_forall in Hmin. apply Hmin in Ha.
      apply bool_decide_eq_false in Ha.
      congruence.
    }
    destruct l1 as [| _min l1]; inversion Heq
    ; try (subst b; elim Hminb; reflexivity).
    subst _min.
    destruct (in_dec decide_eq a l').
    - apply (IHn i l1 l2 Ha2 H4).
    - assert (Hmina : min = a).
      { destruct (decide (min = a0)).
      - subst a0 l'.
        inversion Ha; try assumption.
        elim n0. assumption.
      - subst l'.
        destruct Ha as [Heqa | Ha'].
        + subst a0. elim n0. left. reflexivity.
        + destruct (decide (a = min)); try (symmetry; assumption).
          apply (set_remove_3 decide_eq _ Ha') in n2.
          elim n0. right. assumption.
      }
      subst a.
      apply n0.
      apply top_sort_set_eq.
      unfold top_sort. rewrite <- Hlenl'.
      rewrite H4.
      apply in_app_iff.
      right. right. assumption.
Qed.

(** <<lts>> is a [topological_sorting] of <<l>> if it has the same elements as <<l>>
and is [toplogically_sorted].
*)
Definition topological_sorting
  (l lts : list A)
  :=
  set_eq l lts /\ topologically_sorted preceeds lts.

Corollary top_sort_correct : topological_sorting l (top_sort l).
Proof.
  split.
  - apply top_sort_set_eq.
  - apply top_sort_sorted.
Qed.

End top_sort.


Require Import CT.Category.
Require Import CT.Functor.
Require Import CT.NaturalTransformation.
Require Import CT.Instance.NaturalTransformation.IdentityNaturalTransformation.

(** * Vertical Composition of Natural Transformations

From wikipedia:

If η : F → G and ε : G → H are natural transformations between functors
F,G,H : C → D, then we can compose them to get a natural transformation
εη : F → H. This is done componentwise: (εη)X = εXηX. This "vertical
composition" of natural transformation is associative and has an identity.
*)
Section VCNaturalTransformation.
  Context {C D : Category} {F G H : Functor C D}.
  Variable (eta : NaturalTransformation F G).
  Variable (epsilon : NaturalTransformation G H).
  Variable X : ob C.
  Program Definition VCNaturalTransformation : NaturalTransformation F H :=
    {| nt_components := fun X => comp (nt_components F G eta X) (nt_components G H epsilon X) |}.
  Next Obligation.
  Proof.
    rewrite assoc.
    rewrite nt_commutes.
    repeat rewrite assoc_sym.
    rewrite nt_commutes_sym.
    reflexivity.
  Qed.
  Next Obligation.
    symmetry.
    apply VCNaturalTransformation_obligation_1.
  Qed.
End VCNaturalTransformation.

(** Vertical composition of natural transformations associates. *)
Theorem VCNaturalTransformation_assoc :
  forall C D F G H I
         (N : @NaturalTransformation C D H I)
         (O : @NaturalTransformation C D G H)
         (P : @NaturalTransformation C D F G),
           VCNaturalTransformation (VCNaturalTransformation P O) N =
           VCNaturalTransformation P (VCNaturalTransformation O N).
Proof.
  intros.
  apply nt_eq.
  simpl.
  extensionality g.
  rewrite assoc.
  reflexivity.
Qed.

(** The identity natural transformations acts as left vertical compositional
    identity *)
Theorem VCNaturalTransformation_id_left :
  forall C D F G
         (N : @NaturalTransformation C D F G),
    VCNaturalTransformation (IdentityNaturalTransformation F) N = N.
Proof.
  intros.
  apply nt_eq.
  simpl.
  extensionality g.
  rewrite id_left.
  reflexivity.
Qed.

(** The identity natural transformations acts as right vertical compositional
    identity *)
Theorem VCNaturalTransformation_id_right :
  forall C D F G
         (N : @NaturalTransformation C D F G),
    VCNaturalTransformation N (IdentityNaturalTransformation G) = N.
Proof.
  intros.
  apply nt_eq.
  simpl.
  extensionality g.
  rewrite id_right.
  reflexivity.
Qed.


(* http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt5.html *)
Goal forall (P Q R S : Prop), (S /\ P) /\ (Q /\ R) -> (P /\ S) /\ (R /\ Q).
  intros.
  destruct H.
  assert (forall (X Y :Prop), X /\ Y -> Y /\X).
  intros.
  destruct H1.
  split.
  apply H2.
  apply H1.
  split.
  apply (H1 S P H).
  apply (H1 Q R H0).
Qed.

Require Import List.

Theorem app_eq_nil : forall (A : Type)(l l' : list A), l ++ l' = nil -> l = nil /\ l' = nil.
  intros.
  split.
  destruct l.
  reflexivity.
  discriminate.
  destruct l'.
  reflexivity.
  destruct l.
  discriminate.
  discriminate.
Qed.

Goal forall (n m : nat)(f : nat -> nat), f n = n -> S (f (f n)) = S m -> n = m.
  intros.
  congruence.
  Qed.