Add LoadPath "metatheory".
Require Import Coq.Arith.Wf_nat.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.

Require Export Metatheory.
Require Export LibLNgen.

Require Export Unbound.

Set Implicit Arguments.

Lemma beq_nat_sym : forall n1 n2 b, beq_nat n1 n2 = b -> beq_nat n2 n1 = b.
induction n1; destruct n2; simpl; auto.
Qed.

Lemma case_bool : forall b:bool, {b = true} + {b = false}.
intro b. destruct b. auto. auto.
Qed.

Lemma aeq_sym : forall t u m, aeq m t u = true -> aeq m u t = true.
induction t; intros u m; destruct m; destruct u; simpl in *;
   try (intro H;
        destruct (andb_prop _ _ H);
        rewrite (IHt1 _ _); auto;
        rewrite (IHt2 _ _); auto);
auto using beq_nat_sym.
destruct (case_bool (beq_nat n n1)).
rewrite e.
rewrite (beq_nat_sym n n1 e).
auto using beq_nat_sym.
rewrite e.
rewrite (beq_nat_sym n n1 e). auto.
destruct (case_bool (beq_nat n n1));
  rewrite e; rewrite (beq_nat_sym n n1 e); auto using beq_nat_sym.
destruct (n == n0); destruct (n0 == n); auto.
Qed.

Lemma beq_nat_trans : forall n1 n2 n3, beq_nat n1 n2 = true ->
  beq_nat n2 n3 = true -> beq_nat n1 n3 = true.
induction n1; destruct n2;
induction n3; simpl; auto. intros. inversion H.
apply IHn1.
Qed.

Lemma aeq_trans : forall s t u m, aeq m s t = true -> aeq m t u = true -> aeq m s u = true.
induction s; destruct t; destruct u; intro m; simpl; try (intro H; inversion H); auto.
Admitted.

Lemma aeq_fv : forall t1 t2 m, aeq m t1 t2 = true -> fv m t1 = fv m t2.
induction t1; destruct t2; intro m; simpl; try (intro H; inversion H); auto.
destruct m; simpl in *;
  auto;
  try (destruct (andb_prop _ _ H);
      rewrite (IHt1_1 t2_1); auto;
      rewrite (IHt1_2 t2_2); auto);
  auto.
destruct (n == n0). subst. auto. inversion H.
destruct (andb_prop _ _ H).
rewrite (IHt1_1 t2_1); auto.
rewrite (IHt1_2 t2_2); auto.
destruct (andb_prop _ _ H).
rewrite (IHt1_1 t2_1); auto.
rewrite (IHt1_2 t2_2); auto.
destruct (andb_prop _ _ H).
rewrite (IHt1_1 t2_1); auto.
rewrite (IHt1_2 t2_2); auto.
Qed.

Lemma aeq_subst : forall t1 t2 s1 s2 x m,
  aeq m t1 t2 = true -> aeq Term s1 s2 = true ->
  aeq m (subst m s1 x t1) (subst m s2 x t2) = true.
induction t1; destruct t2; intros s1 s2 x m; try (intro H; inversion H);
  try (destruct (andb_prop _ _ H1);
    rewrite H0; rewrite H2; simpl;
    intro J; rewrite IHt1_1; auto; rewrite IHt1_2; auto); auto.

destruct m.
  simpl. destruct (n == n0). subst. destruct (n0 == x). auto. auto.
    inversion H1.
  simpl. auto.
rewrite H1. intro J. simpl. rewrite IHt1; auto.
rewrite H1. intro J. simpl. rewrite IHt1; auto.
rewrite H1. intro J. simpl. rewrite IHt1; auto.
Qed.

Lemma aeq_freshen_pat : forall pat pat1 pat2 ns1 ns1' ns2 ns2' perm1 perm2,
  freshen pat1 ns1 nil = (pat, ns1', perm1) ->
  freshen pat2 ns2 nil = (pat, ns2', perm2) ->
  aeq Pat pat1 pat2 = true.
induction pat; destruct pat1; simpl;
   intros pat2' ns1 ns1' ns2 ns2' perm1 perm2 J1 J2; try inversion J1; subst.
destruct pat2'; simpl in *; inversion J2. subst.
rewrite <- beq_nat_refl.
rewrite <- beq_nat_refl. auto.
destruct ns2;  inversion J2.

Lemma aeq_freshen : forall t1 t2 pat pat1 pat2 ns1 ns1' ns2 ns2' perm1 perm2,
  freshen Pat pat1 ns1 nil = (pat, ns1', perm1) ->
  freshen Pat pat2 ns2 nil = (pat, ns2', perm2) ->
  aeq Term (swaps perm1 t1) (swaps perm2 t2) = true ->
  aeq Term (bind pat1 t1) (bind pat2 t2) = true.
induction t1; destruct t2; simpl;
  intros pat pat1 pat2 ns1 ns1' ns2 ns2' perm1 perm2 H1 H2 H3;
  try inversion H3.
(* 1 *)
rewrite H3.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable supp_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable sumA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable rT_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defanglesum_1 : (forall A B C D E F P Q R : Universe, (exists X : Universe, (sumA_ A B C D E F P Q R -> (congA_ A B C P Q X /\ (congA_ D E F X Q R /\ betS_ P X R))))).
Variable defanglesum2_2 : (forall A B C D E F P Q R X : Universe, ((congA_ A B C P Q X /\ (congA_ D E F X Q R /\ betS_ P X R)) -> sumA_ A B C D E F P Q R)).
Variable lemma_equalanglesNC_3 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> ~(col_ Xa Xb Xc))).
Variable lemma_NCdistinct_4 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable lemma_layoff_5 : (forall A B C D : Universe, (exists X : Universe, ((A <> B /\ C <> D) -> (out_ A B X /\ cong_ A X C D)))).
Variable lemma_equalanglessymmetric_6 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_equalanglestransitive_7 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_equalangleshelper_8 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Variable proposition_04_9 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ congA_ B A C Xb Xa Xc)) -> (cong_ B C Xb Xc /\ (congA_ A B C Xa Xb Xc /\ congA_ A C B Xa Xc Xb)))).
Variable lemma_equalanglesflip_10 : (forall A B C D E F : Universe, (congA_ A B C D E F -> congA_ C B A F E D)).
Variable lemma_ray4_1_11 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_12 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_13 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable defsupplement_14 : (forall A B C D F : Universe, (supp_ A B C D F -> (out_ B C D /\ betS_ A B F))).
Variable defsupplement2_15 : (forall A B C D F : Universe, ((out_ B C D /\ betS_ A B F) -> supp_ A B C D F)).
Variable deftworightangles_16 : (forall A B C D E F : Universe, (exists X Y Z U V : Universe, (rT_ A B C D E F -> (supp_ X Y U V Z /\ (congA_ A B C X Y U /\ congA_ D E F V Y Z))))).
Variable deftworightangles2_17 : (forall A B C D E F X Y Z U V : Universe, ((supp_ X Y U V Z /\ (congA_ A B C X Y U /\ congA_ D E F V Y Z)) -> rT_ A B C D E F)).
Variable lemma_rayimpliescollinear_18 : (forall A B C : Universe, (out_ A B C -> col_ A B C)).
Variable lemma_collinearorder_19 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable defcollinear_20 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_21 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_22 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_23 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_24 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_25 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_26 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_ray2_27 : (forall A B C : Universe, (out_ A B C -> A <> B)).
Variable lemma_inequalitysymmetric_28 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_NChelper_29 : (forall A B C P Q : Universe, ((~(col_ A B C) /\ (col_ A B P /\ (col_ A B Q /\ P <> Q))) -> ~(col_ P Q C))).
Variable lemma_NCorder_30 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable defoppositeside_31 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_32 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable lemma_oppositesidesymmetric_33 : (forall A B P Q : Universe, (tS_ P A B Q -> tS_ Q A B P)).
Variable lemma_ray5_34 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_9_5_35 : (forall A B C P Q R : Universe, ((tS_ P A B C /\ (out_ R Q P /\ col_ A B R)) -> tS_ Q A B C)).
Variable lemma_raystrict_36 : (forall A B C : Universe, (out_ A B C -> A <> C)).
Variable proposition_14_37 : (forall A B C D E : Universe, ((rT_ A B C D B E /\ (out_ B C D /\ tS_ E D B A)) -> (supp_ A B C D E /\ betS_ A B E))).
Variable cn_sumofparts_38 : (forall A B C E F G : Universe, ((cong_ A B E F /\ (cong_ B C F G /\ (betS_ A B C /\ betS_ E F G))) -> cong_ A C E G)).
Variable lemma_betweennotequal_39 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_congruencesymmetric_40 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable defequalangles_41 : (forall A B C Ca Cb Cc : Universe, (exists U V Su Sv : Universe, (congA_ A B C Ca Cb Cc -> (out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C))))))))))).
Variable defequalangles2_42 : (forall A B C Ca Cb Cc U V Su Sv : Universe, ((out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C)))))))) -> congA_ A B C Ca Cb Cc)).

Theorem lemma_angleaddition_43 : (forall A B C D E F P Q R Xa Xb Xc Xd Xe Xf Xp Xq Xr : Universe, ((sumA_ A B C D E F P Q R /\ (congA_ A B C Xa Xb Xc /\ (congA_ D E F Xd Xe Xf /\ sumA_ Xa Xb Xc Xd Xe Xf Xp Xq Xr))) -> congA_ P Q R Xp Xq Xr)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*****************************************************************

 Enrichment over the category of sets

 One of the simplest categories over which we can study enrichments
 is the category of sets. In this file, we show that enrichments
 over the category of sets exist and that they are unique. From
 that, we conclude that the notions of category, functor, and
 natural transformations are equivalent to their enrichment
 counterpart if we look at enrichments over the category of sets.

 Contents
 1. Enrichments over sets are unique for categories
 2. Enrichments over sets are unique for functors
 3. Enrichments over sets are unique for natural transformations

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Examples.SetCartesianMonoidal.

Local Open Scope cat.
Local Open Scope moncat.
Import MonoidalNotations.

Proposition set_faithful_moncat
  : faithful_moncat SET_monoidal_cat.
Proof.
  intros X Y f g p.
  use funextsec.
  intro x.
  exact (eqtohomot (p (λ _, x)) tt).
Qed.

Proposition set_conservative_moncat
  : conservative_moncat SET_monoidal_cat.
Proof.
  intros X Y f Hf.
  use (hset_equiv_is_z_iso _ _ (_ ,, _)).
  use isweq_iso.
  - exact (λ y, invmap (_ ,, Hf) (λ _, y) tt).
  - abstract
      (intros x ;
       exact (eqtohomot (homotinvweqweq (_ ,, Hf) (λ _, x)) tt)).
  - abstract
      (intros y ;
       exact (eqtohomot (homotweqinvweq (_ ,, Hf) (λ _, y)) tt)).
Defined.

(**
 1. Enrichments over sets are unique for categories
 *)
Section UniqueSetEnrichment.
  Context (C : category).

  Definition set_enrichment_data
    : enrichment_data C SET_monoidal_cat.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _ ,, _).
    - exact (λ x y, make_hSet (x --> y) (homset_property C x y)).
    - exact (λ x _, identity x).
    - exact (λ x y z fg, pr2 fg · pr1 fg).
    - exact (λ x y f _, f).
    - exact (λ x y f, f tt).
  Defined.

  Proposition set_enrichment_laws
    : enrichment_laws set_enrichment_data.
  Proof.
    repeat split.
    - intros x y.
      use funextsec ; intro ; cbn.
      rewrite id_right.
      apply idpath.
    - intros x y.
      use funextsec ; intro ; cbn.
      rewrite id_left.
      apply idpath.
    - intros w x y z.
      use funextsec ; intro ; cbn.
      apply assoc.
    - intros x y f.
      use funextsec ; intro w ; cbn.
      apply maponpaths.
      apply isapropunit.
  Qed.

  Definition set_enrichment
    : enrichment C SET_monoidal_cat.
  Proof.
    simple refine (_ ,, _).
    - exact set_enrichment_data.
    - exact set_enrichment_laws.
  Defined.

  Theorem iscontr_set_enrichment
    : iscontr (enrichment C SET_monoidal_cat).
  Proof.
    refine (set_enrichment ,, _).
    intro E.
    use subtypePath.
    {
      intro.
      apply isaprop_enrichment_laws.
    }
    use (invweq (total2_paths_equiv _ _ _)).
    use (invmap (enrichment_data_hom_path _ (pr1 E) set_enrichment_data)).
    {
      exact is_univalent_HSET.
    }
    simple refine (_ ,, _ ,, _ ,, _ ,, _).
    - intros x y.
      use make_z_iso.
      + exact (λ f, enriched_to_arr E (λ _, f)).
      + exact (λ f, enriched_from_arr E f tt).
      + split.
        * use funextsec ; intro f ; cbn.
          rewrite enriched_from_to_arr.
          apply idpath.
        * use funextsec ; intro f ; cbn.
          refine (_ @ enriched_to_from_arr E _).
          apply maponpaths.
          use funextsec.
          intro z.
          apply maponpaths.
          apply isapropunit.
    - intro x ; use funextsec ; intro f ; cbn.
      refine (_ @ enriched_to_arr_id E _).
      apply maponpaths.
      use funextsec.
      intro z.
      apply maponpaths.
      apply isapropunit.
    - intros x y z ; use funextsec ; intro f ; cbn.
      use (invmaponpathsweq (invweq (_ ,, isweq_enriched_to_arr E _ _))) ; cbn.
      rewrite enriched_from_arr_comp ; cbn.
      rewrite !enriched_from_to_arr.
      apply idpath.
    - intros x y f ; use funextsec ; intro w ; cbn.
      refine (_ @ enriched_to_from_arr E _).
      apply maponpaths.
      use funextsec.
      intro z.
      apply maponpaths.
      apply isapropunit.
    - intros x y f ; cbn.
      apply maponpaths.
      use funextsec.
      intro z.
      apply maponpaths.
      apply isapropunit.
  Qed.
End UniqueSetEnrichment.

Definition cat_with_set_enrichment_weq_cat
  : cat_with_enrichment SET_monoidal_cat ≃ category.
Proof.
  use weqpr1.
  intro.
  apply iscontr_set_enrichment.
Defined.

(**
 2. Enrichments over sets are unique for functors
 *)
Section UniqueFunctorSetEnrichment.
  Context {C₁ C₂ : category}
          (F : C₁ ⟶ C₂).

  Definition functor_set_enrichment
    : functor_enrichment
        F
        (set_enrichment C₁)
        (set_enrichment C₂).
  Proof.
    simple refine (_ ,, _).
    - exact (λ x y f, #F f).
    - repeat split.
      + abstract
          (intro x ; cbn ;
           use funextsec ; intro ;
           apply functor_id).
      + abstract
          (intros x y f ; cbn ;
           use funextsec ; intro ;
           apply functor_comp).
  Defined.

  Theorem iscontr_functor_set_enrichment
    : iscontr
        (functor_enrichment
           F
           (set_enrichment C₁)
           (set_enrichment C₂)).
  Proof.
    refine (functor_set_enrichment ,, _).
    intro EF.
    use subtypePath.
    {
      intro.
      apply isaprop_is_functor_enrichment.
    }
    use funextsec ; intro x.
    use funextsec ; intro y.
    use funextsec ; intro f.
    cbn.
    exact (!(eqtohomot (functor_enrichment_from_arr EF f) tt)).
  Qed.
End UniqueFunctorSetEnrichment.

Definition functor_with_set_enrichment_weq_functor
           (C₁ C₂ : category)
  : functor_with_enrichment (C₁ ,, set_enrichment C₁) (C₂ ,, set_enrichment C₂)
    ≃
    C₁ ⟶ C₂.
Proof.
  use weqpr1.
  intro.
  apply iscontr_functor_set_enrichment.
Defined.

(**
 3. Enrichments over sets are unique for natural transformations
 *)
Section UniqueNatTransSetEnrichment.
  Context {C₁ C₂ : category}
          {F G : C₁ ⟶ C₂}
          (τ : F ⟹ G).

  Definition nat_trans_set_enrichment
    : nat_trans_enrichment
        τ
        (functor_set_enrichment F)
        (functor_set_enrichment G).
  Proof.
    intros x y ; cbn.
    use funextsec ; intro f ; cbn.
    exact (!(nat_trans_ax τ _ _ f)).
  Qed.

  Theorem iscontr_nat_trans_set_enrichment
    : iscontr
        (nat_trans_enrichment
           τ
           (functor_set_enrichment F)
           (functor_set_enrichment G)).
  Proof.
    refine (nat_trans_set_enrichment ,, _).
    intro.
    apply isaprop_nat_trans_enrichment.
  Qed.
End UniqueNatTransSetEnrichment.

Definition nat_trans_with_set_enrichment_weq_nat_trans
           {C₁ C₂ : category}
           (F G : C₁ ⟶ C₂)
  : @nat_trans_with_enrichment
      _
      (C₁ ,, set_enrichment C₁)
      (C₂ ,, set_enrichment C₂)
      (F ,, functor_set_enrichment F)
      (G ,, functor_set_enrichment G)
    ≃
    F ⟹ G.
Proof.
  use weq_iso.
  - exact (λ τ, pr1 τ ,, is_nat_trans_from_enrichment (pr2 τ)).
  - exact (λ τ, pr1 τ ,, nat_trans_set_enrichment τ).
  - abstract
      (intro τ ;
       use eq_nat_trans_with_enrichment ;
       intro x ; cbn ;
       apply idpath).
  - abstract
      (intro τ ;
       use nat_trans_eq ; [ apply homset_property | ] ;
       intro x ; cbn ;
       apply idpath).
Defined.


From Coq.Logic Require Import ConstructiveEpsilon.
Require Import Lia Nat.
From stdpp Require Import numbers list list_numbers.
From Undecidability Require Import SemiDecidabilityFacts DecidabilityFacts EnumerabilityFacts reductions Axioms.bestaxioms halting.

(** * CT in relation to other axioms  *)

(** ** Provable choice axioms  *)

Lemma decidable_AC X :
  forall R : X -> nat -> Prop, decidable (curry R) -> (forall x, exists n, R x n) -> exists f, forall x, R x (f x).
Proof.
  intros R [f Hf] Htot.
  destruct (decider_AC _ f R) as [g Hg]; eauto.
Qed.

Lemma semi_decidable_AC X :
  forall R : X -> nat -> Prop, semi_decidable (curry R) -> (forall x, exists n, R x n) -> exists f, forall x, R x (f x).
Proof.
  intros R [f Hf] Htot.
  destruct (semi_decider_AC _ f R) as [g Hg]; eauto.
Qed.

Lemma sdec_compute_lor {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> (forall x, p x \/ q x) -> exists f : X -> bool, forall x, if f x then p x else q x.
Proof.
  intros Hp Hq Hpq.
  edestruct (semi_decidable_AC X (fun x n => if n is 0 then p x else q x)) as [f Hf].
  - destruct Hp as [f1 H1], Hq as [f2 H2]. red in H1, H2.
    exists (fun '(x,n) m => if n is 0 then f1 x m else f2 x m).
    now intros (x,[]); cbn; rewrite ?H1, ?H2.
  - intros x. destruct (Hpq x). now exists 0. now exists 1.
  - exists (fun x => if f x is 0 then true else false). intros x.
    specialize (Hf x). destruct (f x); firstorder.
Qed.

Lemma inspect_opt {X} (o : option X) :
  {x | o = Some x} + {o = None}.
Proof.
  destruct o; eauto.
Qed.

Lemma enumerable_AC :
  forall X, discrete X -> forall Y, forall R : X -> Y -> Prop, enumerable (curry R) -> (forall x, exists n, R x n) -> exists f, forall x, R x (f x).
Proof.
  intros X [d Hd] Y R [f Hf] Htot.
  destruct (enumerator_AC _ _ f d _ Hd Hf Htot) as [g Hg].
  now exists g.
Qed.

(** ** Extensionality axioms  *)

Definition Fext := forall X Y (f g : X -> Y), (forall x, f x = g x) -> f = g.
Definition Pext := forall P Q : Prop, P <-> Q -> P = Q.
Definition hProp (P : Prop) := forall x1 x2 : P, x1 = x2.
Definition PI := forall P : Prop, hProp P.

Lemma Pext_to_PI :
  Pext -> PI.
Proof.
  intros pext P x1 x2.
  assert (P = True) as -> by firstorder.
  now destruct x1, x2.
Qed.

Lemma hProp_disj P Q :
  hProp P -> hProp Q -> ~ (P /\ Q) -> hProp (P \/ Q).
Proof.
  unfold hProp.
  intros hP hQ H [H1 | H1] [H2 | H2]; f_equal; firstorder; exfalso; tauto.
Qed.

Lemma Fext_hProp_neg P :
  Fext -> hProp (~ P).
Proof.
  intros fext H1 H2.
  eapply fext. intros x. exfalso. tauto.
Qed.

Lemma Fext_hProp_disj P :
  Fext -> hProp P -> hProp (P \/ ~ P).
Proof.
  intros. now eapply hProp_disj; [ | eapply Fext_hProp_neg | ].
Qed.

Lemma Fext_hProp_wdisj P :
  Fext -> hProp (~ P \/ ~~ P).
Proof.
  intros. now eapply Fext_hProp_disj; [ | eapply Fext_hProp_neg].
Qed.

Section CT_wrong.

  Variable ϕ : nat -> nat -> nat -> option nat.
  Variable Hϕ : forall c x, monotonic (ϕ c x).

  Definition CT_Sigma := forall f : nat -> nat, {c : nat | forall x, exists n, ϕ c x n = Some (f x) }.

  Lemma CT_Sigma_wrong : CT_Sigma -> Fext -> False.
  Proof.
    intros CT fext.
    eapply K_nat_undec. {
      right. exists ϕ. split; try eassumption.
      intros f. unshelve eexists.
      + intros x. destruct (CT (f x)) as [c]. exact c.
      + intros x y. cbn. destruct (CT (f x)) as [c Hc]; eauto.
    }
    exists (fun f => Nat.eqb (proj1_sig (CT f)) (proj1_sig (CT (fun _ => 0)))).
    intros f.
    destruct (PeanoNat.Nat.eqb_spec (` (CT f)) (` (CT (fun _ : nat => 0)))).
    - unfold reflects. intuition.
      destruct (CT f) as [cf Hf].
      destruct (CT (fun _ => 0)) as [cc Hc]. cbn in *. subst.
      destruct (Hf n), (Hc n).
      eapply monotonic_agnostic; eauto.
    - unfold reflects. intuition try congruence.
      assert (f = fun x => 0) as -> by now apply fext.
      congruence.
  Qed.

End CT_wrong.

(** ** Classical logical axioms  *)

Definition LEM := forall P, P \/ ~ P.
Definition DNE := forall P, ~~P -> P.
Definition DGP := forall P Q : Prop, (P -> Q) \/ (Q -> P).
Definition WLEM := forall P, ~~P \/ ~ P.

Definition IP := forall (P : Prop), forall p : nat -> Prop, (P -> exists n, p n) -> exists n, P -> p n.

Lemma LEM_to_DGP :
  LEM -> DGP.
Proof.
  intros H P Q.
  destruct (H P), (H Q); tauto.
Qed.

Lemma DGP_to_WLEM :
  DGP -> WLEM.
Proof.
  intros H P.
  destruct (H P (~ P)); tauto.
Qed.

Lemma LEM_to_IP : LEM -> IP.
Proof.
  intros H P p.
  destruct (H P) as [H0 | H0].
  - intros [n H1] % (fun H1 => H1 H0). eauto.
  - exists 0. tauto.
Qed.

(*

    LEM --> DGP --> WLEM
     |               |
     |               |
     v               v
    LPO     -->    WLPO   -->   LLPO
     ^               ^
     |               |
     v               v
  MP /\ WLPO     PFP /\ LLPO

     ^
     |

  MP /\ IP

 *)

Definition LPO := forall f : nat -> bool, (exists n, f n = true) \/ ~ (exists n, f n = true).
Definition WLPO := forall f : nat -> bool, (forall n, f n = false) \/ ~ (forall n, f n = false).

Lemma forall_neg_exists_iff (f : nat -> bool) :
  (forall n, f n = false) <-> ~ exists n, f n = true.
Proof.
  split.
  - intros H [n Hn]. rewrite H in Hn. congruence.
  - intros H n. destruct (f n) eqn:E; try reflexivity.
    destruct H. eauto.
Qed.

Lemma LEM_to_LPO : LEM -> LPO.
Proof.
  cbv. intuition.
Qed.

Lemma WLEM_to_WLPO : WLEM -> WLPO.
Proof.
  intros H f. rewrite forall_neg_exists_iff.
  edestruct H; eauto.
Qed.

Lemma LPO_to_WLPO : LPO -> WLPO.
Proof.
  intros H f. rewrite forall_neg_exists_iff.
  edestruct H; eauto.
Qed.

Definition LPO_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, p x \/ ~ p x.

Lemma LPO_semidecidable_iff :
  LPO <-> LPO_semidecidable.
Proof.
  split.
  - intros H X p [f Hf] x. red in Hf.
    rewrite Hf. eapply H.
  - intros H f.
    eapply (H unit (fun _ => exists n, f n = true)).
    exists (fun _ => f). cbv. intuition. econstructor.
Qed.

Definition WLPO_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, ~ p x \/ ~~ p x.

Lemma WLPO_semidecidable_iff :
  WLPO <-> WLPO_semidecidable.
Proof.
  split.
  - intros H X p [f Hf] x. red in Hf.
    rewrite Hf. rewrite <- forall_neg_exists_iff.
    eapply H.
  - intros H f.
    rewrite forall_neg_exists_iff.
    eapply (H unit (fun _ => exists n, f n = true)).
    exists (fun _ => f). cbv. intuition. econstructor.
Qed.

Definition WLPO_cosemidecidable := forall X (p : X -> Prop), co_semi_decidable p -> forall x, p x \/ ~ p x.

Lemma WLPO_cosemidecidable_iff :
  WLPO_cosemidecidable <-> WLPO_semidecidable.
Proof.
  split.
  - intros H X p [f Hf] x. red in Hf.
    rewrite Hf. rewrite <- forall_neg_exists_iff.
    eapply (H _ (fun x => forall n, f x n = false)).
    exists f. red. reflexivity.
  - intros H X p [f Hf] x. red in Hf.
    rewrite Hf. rewrite forall_neg_exists_iff.
    eapply (H _ (fun x => exists n, f x n = true)).
    exists f. intros x'. reflexivity.
Qed.

Definition CODING :=
  exists F : (nat -> bool) -> nat, forall f, F f = F (fun _ => false) <-> forall n, f n = false.

Lemma no_CODING :
  CODING -> decidable (compl K_nat_bool).
Proof.
  intros [F HF].
  exists (fun f => Nat.eqb (F f) (F (fun _ => false))).
  intros f. unfold compl, K_nat_bool. red. rewrite <- forall_neg_exists_iff.
  destruct (Nat.eqb_spec (F f) (F (fun _ => false))); rewrite <- HF.
  all: firstorder.
Qed.

Definition LLPO := forall f g : nat -> bool, ((exists n, f n = true) -> (exists n, g n = true)) \/ ((exists n, g n = true) -> (exists n, f n = true)).
Definition DM_Sigma_0_1 := forall f g : nat -> bool, ~ ((exists n, f n = true) /\ (exists n, g n = true)) -> ~ (exists n, f n = true) \/ ~ (exists n, g n = true).
Definition DGP_sdec := forall X (p : X -> Prop), semi_decidable p -> forall x y, (p x -> p y) \/ (p y -> p x).
Definition DM_sdec := forall X (p q : X -> Prop), semi_decidable p -> semi_decidable q -> forall x, ~ (p x /\ q x) -> ~ p x \/ ~ q x.
Definition LLPO_split := forall f : nat -> bool, (forall n m, f n = true -> f m = true -> n = m) -> (forall n, f (2 * n) = false) \/ (forall n, f (1 + 2 * n) = false).

Lemma LLPO_to_DM_Sigma_0_1 :
  LLPO -> DM_Sigma_0_1.
Proof.
  intros H f g Hfg.
  destruct (H f g); tauto.
Qed.

Lemma LLPO_iff_DGP_sdec :
  LLPO <-> DGP_sdec.
Proof.
  split.
  - intros H X p [f Hf] x y.
    unfold semi_decider in *.
    rewrite !Hf. eapply H.
  - intros H f g.
    unshelve eapply (H bool (fun b => if b then exists n, f n = true else exists n, g n = true) _ true false).
    + exists (fun b : bool => if b then f else g). red. intros []; reflexivity.
Qed.

Lemma DM_Sigma_0_1_iff_DM_sdec :
  DM_Sigma_0_1 <-> DM_sdec.
Proof.
  split.
  - intros H X p q [f Hf] [g Hg] x.
    unfold semi_decider in *.
    rewrite Hf, Hg. eapply H.
  - intros H f g Hfg.
    eapply (H unit (fun _ => exists n, f n = true) (fun _ => exists n, g n = true)).
    + exists (fun _ => f). red. reflexivity.
    + exists (fun _ => g). red. reflexivity.
    + econstructor.
    + eassumption.
Qed.

Lemma neg_neg_XM P :
  ~~ (P \/ ~ P).
Proof.
  tauto.
Qed.

Lemma DM_Sigma_0_1_iff_totality :
  DM_Sigma_0_1 <-> (forall X (R : X -> bool -> Prop), co_semi_decidable (curry R) -> forall n, ~~ (exists b, R n b) -> exists b, R n b).
Proof.
  split.
  - intros H X R [f Hf'] n.
    assert (Hf : forall n b, R n b <-> forall m, f (n, b) m = false) by (intros; eapply (Hf' (_, b))).
    setoid_rewrite Hf. clear - H. intros Hb.
    destruct (H (f (n, true)) (f (n, false))) as [H1 | H1].
    + intros [ [n1 ?] [n2 ?]]. eapply Hb. intros [[] ?]; congruence.
    + exists true. now eapply forall_neg_exists_iff.
    + exists false. now eapply forall_neg_exists_iff.
  - intros H f g Hfg.
    edestruct (H nat (fun _ b => if b then forall n, f n = false else forall n, g n = false)) with (n := 0) as [[] H1].
    + exists (fun '(n,b) => if b : bool then f else g). now intros (n, []).
    + intros H0. eapply (neg_neg_XM (exists n, f n = true)). intros [H1 | H1].
      * eapply (neg_neg_XM (exists n, g n = true)). intros [H2 | H2].
        -- eauto.
        -- eapply H0. exists false. now eapply forall_neg_exists_iff.
      * eapply H0. exists true. now eapply forall_neg_exists_iff.
    + left. now eapply forall_neg_exists_iff.
    + right. now eapply forall_neg_exists_iff.
Qed.

Lemma DM_Sigma_0_1_to_LLPO_split :
  DM_Sigma_0_1 -> LLPO_split.
Proof.
  intros H f Huni.
  destruct (H (fun n => f (2 * n)) (fun n => (f (1 + 2 * n)))).
  - intros [[n Hn] [m Hm]].
    eapply Huni in Hn; eauto. lia.
  - left. now rewrite forall_neg_exists_iff.
  - right. now rewrite forall_neg_exists_iff.
Qed.

Lemma dec_bounded_quant P n :
  (forall m, m <= n -> P m \/ ~ P m) -> (forall m, m <= n -> ~ P m) \/ exists m, m <= n /\ P m.
Proof.
  intros H.
  induction n.
  - destruct (H 0 (Nat.le_refl 0)).
    + right. exists 0. split. lia. eauto.
    + left. intros m Hm. enough (m = 0) by now subst. lia.
  - destruct IHn as [H1 | [m [Hle Hm]]].
    + intros. eapply H. lia.
    + destruct (H (S n) (Nat.le_refl _)).
      * right. eauto.
      * left. intros m [Hle |  ->] % le_lt_or_eq; eauto.
        eapply H1. lia.
    + right. exists m. split. lia. eassumption.
Qed.

Lemma least_ex (P : nat -> Prop) n : P n -> (forall m, m < n -> P m \/~ P m) -> exists n, P n /\ forall m, P m -> m >= n.
Proof.
  induction n using lt_wf_rec.
  intros Hn Hlt.
  destruct n.
  - exists 0. split. eauto. intros. lia.
  - edestruct dec_bounded_quant with (n := n).
    + intros. eapply (Hlt m). lia.
    + exists (S n). split. eauto. intros.
      destruct (le_lt_dec (S n) m); eauto. eapply H0 in H1; lia.
    + destruct H0 as (m & Hle & Hm).
      eapply (H m).
      * lia.
      * eassumption.
      * intros. eapply Hlt. lia.
Qed.

Lemma LLPO_split_to_LLPO :
  LLPO_split -> LLPO.
Proof.
  intros H f g.
  pose (alpha := (fun n => if n `mod` 2 =? 0 then f (n `div` 2) else g (n `div` 2))).
  pose (alpha' n := alpha n && forallb negb (map alpha (seq 0 n))).
  destruct (H alpha') as [H0 | H0].
  - intros n m [Ha1 Ha2] % andb_true_iff [Ha3 Ha4] % andb_true_iff.
    destruct (lt_eq_lt_dec n m) as [ [Hl | ] | Hl]; eauto.
    + rewrite forallb_forall in Ha4.
      setoid_rewrite in_map_iff in Ha4.
      setoid_rewrite in_seq in Ha4.
      enough (false = true) by congruence.
      eapply (Ha4 true). cbn. exists n. repeat split; eauto with arith.
    + rewrite forallb_forall in Ha2.
      setoid_rewrite in_map_iff in Ha2.
      setoid_rewrite in_seq in Ha2.
      enough (false = true) by congruence.
      eapply (Ha2 true). cbn. exists m. repeat split; eauto with arith.
  - left. intros [m Hm].
    destruct (least_ex (fun n => f n = true) _ Hm) as [n [Hn Hle]].
    { intros x. destruct (f x); firstorder congruence. }
    clear m Hm.
    assert (alpha (n * 2) = true). {
      unfold alpha. rewrite Nat.mod_mul. rewrite Nat.eqb_refl.
      rewrite Nat.div_mul. eauto. lia. lia.
    }
    destruct (dec_bounded_quant (fun n => g n = true) n).
    + intros m ?; destruct (g m); firstorder congruence.
    + exfalso. enough (alpha' (2 * n) = true). rewrite H0 in H3. congruence.
      rewrite mult_comm. unfold alpha'.
      eapply andb_true_iff. split. eauto.
      eapply forallb_forall.
      intros b. rewrite in_map_iff. setoid_rewrite in_seq.
      intros [k [H3 [_ H4] ]]. destruct b; try reflexivity.
      unfold alpha in H3.
      exfalso. destruct (k `mod` 2) eqn:Em.
      * cbn [Nat.eqb] in H3. eapply Hle in H3. cbn in H4.
        pose proof (Nat.div_lt_upper_bound k 2 n).
        lia.
      * cbn [Nat.eqb] in H3. eapply H2 in H3. lia.
        eapply Nat.div_le_upper_bound. lia. lia.
    + firstorder.
  - right. intros [m Hm].
    destruct (least_ex (fun n => g n = true) _ Hm) as [n [Hn Hle]].
    { intros x. destruct (g x); firstorder congruence. }
    clear m Hm.
    assert (alpha (1 + n * 2) = true). {
      unfold alpha. rewrite Nat.mod_add; try lia.
      change (1 `mod` 2 =? 0) with false. hnf.
      rewrite Nat.div_add. cbn. eauto. lia.
    }
    destruct (dec_bounded_quant (fun n => f n = true) (S n)).
    + intros m ?; destruct (f m); firstorder congruence.
    + exfalso. enough (H3 : alpha' (1 + 2 * n) = true). rewrite H0 in H3. congruence.
      rewrite mult_comm. unfold alpha'.
      eapply andb_true_iff. split. eauto.
      eapply forallb_forall.
      intros b. rewrite in_map_iff. setoid_rewrite in_seq.
      intros [k [H3 [_ H4] ]]. destruct b; try reflexivity.
      unfold alpha in H3.
      exfalso. destruct (k `mod` 2) eqn:Em.
      * cbn [Nat.eqb] in H3. eapply H2 in H3. cbn in H4. eauto.
        eapply Nat.div_le_upper_bound. lia. lia.
      * cbn [Nat.eqb] in H3. eapply Hle in H3. cbn in H4.
        rewrite Nat.mod_eq in Em; lia.
    + firstorder.
Qed.

Definition PFP := forall f : nat -> bool, exists g : nat -> bool, (forall n, f n = false) <-> exists n, g n = true.

Lemma WLPO_PFP_LLPO_iff :
  WLPO <-> PFP /\ LLPO.
Proof.
  split.
  - intros H. split.
    + intros f. destruct (H f).
      * exists (fun _ => true).
        split.
        -- now exists 0.
        -- eauto.
      * exists (fun _ => false).
        split.
        -- tauto.
        -- intros [? [=]].
    + eapply LLPO_split_to_LLPO, DM_Sigma_0_1_to_LLPO_split.
      intros f g Hfg.
      destruct (H f).
      * left. firstorder congruence.
      * destruct (H g).
        -- right. firstorder congruence.
        -- left. intros Hf.
           assert (H2 : ~~ ((exists n, g n = true) \/ ~ (exists n, g n = true))) by tauto.
           eapply H2. intros [Hg | Hg].
           now eapply Hfg. now rewrite <- forall_neg_exists_iff in Hg.
  - intros [PFP LLPO % LLPO_to_DM_Sigma_0_1] f.
    destruct (PFP f) as [g Hg].
    destruct (LLPO f g).
    + rewrite <- Hg. intros [[n Hn] H]. rewrite H in Hn. congruence.
    + left. now rewrite forall_neg_exists_iff.
    + right. now rewrite <- Hg in H.
Qed.

Definition KS := forall P, exists f : nat -> bool, P <-> exists n, f n = true.

Lemma LEM_to_KS :
  LEM -> KS.
Proof.
  intros xm P.
  destruct (xm P) as [H | H].
  - exists (fun _ => true). firstorder. econstructor.
  - exists (fun _ => false). firstorder.
Qed.

Lemma KS_LPO_to_LEM :
  KS -> LPO -> LEM.
Proof.
  intros ks lpo P.
  destruct (ks P) as [f ->].
  eapply lpo.
Qed.

Lemma KS_WLPO_to_WLEM :
  KS -> LPO -> LEM.
Proof.
  intros ks lpo P.
  destruct (ks P) as [f ->].
  eapply lpo.
Qed.

Lemma KS_LLPO_to_DGP :
  KS -> LLPO -> DGP.
Proof.
  intros ks lpo P Q.
  destruct (ks P) as [f ->].
  destruct (ks Q) as [g ->].
  eapply lpo.
Qed.

(** ** Axioms of russian constructivism  *)

Definition MP := forall f : nat -> bool, ~~ (exists n, f n = true) -> exists n, f n = true.

Definition MP_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, ~~ p x -> p x.
Definition Post_logical := forall X (p : X -> Prop), semi_decidable p -> semi_decidable (compl p) -> forall x, p x \/ ~ p x.
Definition Post := forall X (p : X -> Prop), semi_decidable p -> semi_decidable (compl p) -> decidable p.

Lemma LPO_MP_WLPO_iff :
  LPO <-> MP /\ WLPO.
Proof.
  split.
  - intros H. split.
    + intros f Hf. destruct (H f); tauto.
    + intros f. rewrite forall_neg_exists_iff. destruct (H f); tauto.
  - intros [MP WLPO] f.
    destruct (WLPO f).
    + right. now rewrite <- forall_neg_exists_iff.
    + left. eapply MP. now rewrite <- forall_neg_exists_iff.
Qed.

Lemma MP_IP_LPO : IP -> MP -> LPO.
Proof.
  intros IP MP f.
  assert (exists n, forall k, f k = true -> f n = true) as [n Hn].
  - specialize (MP f). apply IP in MP as [n Hn].
    exists n. intros k H. apply Hn. intros H'. apply H'. now exists k.
  - destruct (f n) eqn:E.
    + eauto.
    + right. intros [m Hm].
      specialize (Hn m Hm). congruence.
Qed.

Lemma MP_to_MP_semidecidable :
  MP -> MP_semidecidable.
Proof.
  intros H X p [f Hf] x. red in Hf.
  rewrite Hf. eapply H.
Qed.

Definition MP_semidecidable_ex := forall (p : nat -> Prop), semi_decidable p -> ~~ (exists x, p x) -> exists x, p x.

Lemma MP_semidecidable_to_MP_semidecidable_ex :
  MP_semidecidable -> MP_semidecidable_ex.
Proof.
  intros mp p [f Hf]. red in Hf. setoid_rewrite Hf.
  eapply (mp unit (fun _ => exists x n, f x n = true)).
  exists (fun _ => fun! ⟨x,n⟩ => f x n). intros _.
  split.
  - intros (x & n & Hxn). exists ⟨x,n⟩. now rewrite embedP.
  - intros (xn & Hxn). destruct (unembed xn) as [x n]. eauto.
  - exact tt.
Qed.

Lemma MP_semidecidable_ex_to_MP_semidecidable :
  MP_semidecidable_ex -> MP_semidecidable.
Proof.
  intros mp X p [f Hf] x. red in Hf. setoid_rewrite Hf.
  eapply mp. eapply decidable_semi_decidable.
  exists (fun x0 => f x x0). intros ?. red. reflexivity.
Qed.

Lemma MP_semidecidable_to_Post_logical :
  MP_semidecidable -> Post_logical.
Proof.
  intros H X p Hp Hcp x. pattern x.
  eapply H.
  - now eapply semi_decidable_or.
  - tauto.
Qed
.
Definition MP_semidecidable_ex_enumerable := forall X (p : X -> Prop), enumerable p -> ~~ (exists x, p x) -> exists x, p x.

Lemma MP_bla :
  MP_semidecidable_ex -> MP_semidecidable_ex_enumerable.
Proof.
  intros mp X p [f Hf]. red in Hf.
  setoid_rewrite Hf. intros H.
  destruct (mp (fun n => f n <> None)) as [n Hn].
  - eapply decidable_semi_decidable. eapply decidable_iff.
    econstructor. intros n. destruct (f n); firstorder.
  - intros HH. apply H. intros (x & n & HHH). eapply HH. exists n. congruence.
  - destruct (f n) eqn:E; try congruence. now exists x, n.
Qed.

Lemma MP_blub :
  MP_semidecidable_ex_enumerable -> MP_semidecidable_ex.
Proof.
  intros mp p Hp.
  eapply mp. eapply semi_decidable_enumerable; eauto.
Qed.

Lemma Post_logical_to_Post :
  Post_logical -> Post.
Proof.
  intros H X p Hp Hcp.
  destruct (sdec_compute_lor Hp Hcp) as [f Hf].
  - eapply H; eauto.
  - exists f. intros x. red. specialize (Hf x). destruct (f x); firstorder congruence.
Qed.

Lemma Post_nempty_to_MP {X} (x0 : X) :
  (forall (p : X -> Prop), semi_decidable p -> semi_decidable (compl p) -> decidable p) -> MP.
Proof.
  intros H f Hf.
  destruct (H (fun _ => exists n, f n = true)) as [d Hd].
  - exists (fun _ => f). now intros x.
  - exists (fun _ _ => false). firstorder.
  - destruct (decider_decide Hd x0); tauto.
Qed.

Lemma Post_to_MP :
  Post -> MP.
Proof.
  intros H. apply (Post_nempty_to_MP tt). apply H.
Qed.

Lemma semi_decidable_ext {X} (p q : X -> Prop) :
  p ≡{X -> Prop} q -> semi_decidable p -> semi_decidable q.
Proof.
  intros H [f Hf]. exists f. intros x. cbv -[iff] in H.
  rewrite <- H. eapply Hf.
Qed.

Lemma MP_iff_sdec_weak_total :
  MP_semidecidable <-> (forall X (R : X -> bool -> Prop), semi_decidable (curry R) -> forall x, ~~ (exists b, R x b) -> exists b, R x b).
Proof.
  split.
  - intros H X R [f Hf] x Hx.
    eapply H with (x := x).
    eapply semi_decidable_ext.
    2: eapply (@semi_decidable_or _ (fun x => R x true) (fun x => R x false)).
    + clear. intros x. split. firstorder. intros [[] ?]; firstorder.
    + exists (fun x n => f (x, true) n). intros x0. red in Hf.
      now rewrite (Hf (x0, true)).
    + exists (fun x n => f (x, false) n). intros x0. red in Hf.
      now rewrite (Hf (x0, false)).
    + eassumption.
  - intros H X p [f Hf] x Hx.
    edestruct (H X (fun x b => p x)).
    + exists (fun '(x, b) n => f x n). intros (?, b). cbn. eapply Hf.
    + intros Hp. eapply Hx. intros Hpx. eapply Hp. exists true. eassumption.
    + eassumption.
Qed.

Lemma MP_cosdec_to_sdec :
  MP ->
  (forall X (p : X -> Prop), co_semi_decidable p -> semi_decidable (compl p)).
Proof.
  intros mp X p [f Hf]. exists f. unfold semi_decider, compl.
  intros x. red in Hf. rewrite Hf. rewrite forall_neg_exists_iff.
  split; eauto.
Qed.

Lemma MP_partial_to_MP {Part : partiality} X (x0 : X) :
  (forall x : part X, ~~ ter x -> ter x) -> MP.
Proof.
  intros mp f Hf.
  destruct (mp (bind (mu_tot f) (fun _ => ret x0))) as [? H].
  intros H. apply Hf. intros [n [m Hm] % mu_tot_ter].
  apply H. exists x0.
  eapply bind_hasvalue.
  exists m. split; eauto. eapply ret_hasvalue.
  eapply bind_hasvalue in H as (? & [] % mu_tot_hasvalue & ?).
  eauto.
Qed.

Lemma MP_to_MP_partial {Part : partiality} :
  MP -> (forall X, forall x : part X, ~~ ter x -> ter x).
Proof.
  intros MP X x.
  assert (ter x <-> exists n, (if seval x n is Some x then true else false) = true). {
    split.
    - intros [a [n H] % seval_hasvalue]. exists n. now rewrite H.
    - intros [n H]. destruct seval as [ a | ] eqn:E; try congruence.
      exists a. eapply seval_hasvalue. eauto.
  }
  rewrite H.
  eapply MP.
Qed.

Lemma DNE_sdec_to_cosdec :
  DNE ->
  (forall X (p : X -> Prop), semi_decidable (compl p) -> co_semi_decidable p).
Proof.
  intros mp X p [f Hf]. exists f. unfold semi_decider, compl in *.
  intros x. rewrite forall_neg_exists_iff. rewrite <- Hf.
  split; eauto. eapply mp.
Qed.

Require Import Undecidability.Synthetic.FinitenessFacts.

Require Import Undecidability.Shared.Dec.

Lemma semi_decidable_generative (p : nat -> Prop) :
  MP -> semi_decidable p ->
  ~ exhaustible p -> generative p.
Proof.
  intros mp % MP_to_MP_semidecidable % MP_semidecidable_to_MP_semidecidable_ex Hs Hl l.
  eapply mp.
  - eapply semi_decidable_and. eauto. eapply decidable_semi_decidable, decidable_complement, listable_decidable.
    eapply discrete_nat. exists l. red. reflexivity.
  - apply non_finite_spec; eauto. intros. destruct (Nat.eqb_spec x1 x2); firstorder.
Qed.

(*
Lemma rev :
  (forall X (p : X -> Prop), discrete X -> semi_decidable p -> ~ exhaustible p -> generative p) ->
  MP_semidecidable.
Proof.
  intros H X p Hp x Hx.
  destruct (P_inf_spec (p x)) as [_ [HH | HH]]; try tauto.
  eapply unbounded_inhabited, generative_unbounded, H.
  - exact discrete_nat.
  - eapply decidable_semi_decidable. exists Nat.even.
    intros n. red. unfold P_inf. destruct Nat.even; try now firstorder congruence.
*)

(** ** Choice axioms *)

Definition AC_on X Y :=
  forall R : X -> Y -> Prop, (forall x, exists y, R x y) -> exists f : X -> Y, forall x, R x (f x).

Definition AC := forall X Y, AC_on X Y.

Definition AUC_on X Y :=
  forall R : X -> Y -> Prop, (forall x, exists! y, R x y) -> exists f : X -> Y, forall x, R x (f x).

Definition AC_0_0 :=
  AC_on nat nat.

Definition AC_1_0 :=
  AC_on (nat -> nat) nat.

Definition ADC_on X := forall R : X -> X -> Prop, forall x0, (forall x, exists x', R x x') -> exists f : nat -> X, f 0 = x0 /\ forall n, R (f n) (f (S n)).

Definition ADC := forall X, ADC_on X.
Definition ACC := forall X, AC_on nat X.

Lemma total_list {X Y} {R : X -> Y -> Prop} L :
  (forall x, exists y, R x y) -> exists L', Forall2 R L L'.
Proof.
  intros HTot. induction L as [ | x L [L' IH]].
  - exists []. econstructor.
  - destruct (HTot x) as [y H]. exists (y :: L').
    now econstructor.
Qed.

Lemma AC_rel_to_ADC : forall X, AC_on X X -> ADC_on X.
Proof.
  intros X C R x0 Htot.
  eapply C in Htot as [f].
  exists (fun n => Nat.iter n f x0).
  split. reflexivity. intros n. eapply H.
Qed.

Lemma AC_on_to_AUC_on : forall X Y, AC_on X Y -> AUC_on X Y.
Proof.
  intros X Y C R H. eapply C. firstorder.
Qed.

Goal AC -> ADC.
Proof.
  intros ? X Inh.
  eapply AC_rel_to_ADC, H.
Qed.

Goal ADC -> ACC.
Proof.
  intros C X R Htot.
  destruct (Htot 0) as [y0 Hy0].
  unshelve specialize (C (∑ '(n, x), R n x) (fun '(exist _  (n, x) H) '(exist _ (m, y) H2) => m = S n)) as [f].
  - eexists (_, _). eauto.
  - intros [(n, x) H]. destruct (Htot (S n)) as [y Hy]. now exists (exist _ (S n, y) Hy).
  - destruct H as [H0 H].
    pose (N n := fst (proj1_sig (f n))).
    pose (s n := snd (proj1_sig (f n))).
    assert (HN : forall n, N (S n) = S (N n)). {
      intros n. cbv.
      pose proof (H (S n)) as Hsn.
      pose proof (H n) as Hn.
      destruct (f n) as [(m', y') H'].
      destruct (f (S n)) as [(m, y) Hmy]. eassumption.
    }
    assert (HN0 : forall n, N n = N 0 + n) by (induction n; rewrite ?HN; lia).
    assert (H1 : forall n, R (N n) (s n)). {
      intros n. unfold N, s.
      specialize (H n).
      destruct (f n) as [(m, y) Hmy]. exact Hmy.
    }
    pose proof (total_list (seq 0 (N 0)) Htot) as [L' HL'].
    exists (fun n => if le_lt_dec (N 0) n is left _ then s (n - N 0) else (nth n L' (s 0))). intros n.
    destruct (le_lt_dec (N 0) n) as [Hl | Hl].
    + specialize (H1 (n - N 0)). rewrite HN0 in H1.
      now replace n with (N 0 + (n - N 0)) at 1 by lia.
    + rewrite nth_lookup.
      destruct (L' !! n) as [x|] eqn:E.
      * cbn.
        edestruct (Forall2_lookup_l R (seq 0 (N 0)) L') as [? []]. eassumption.
        rewrite lookup_seq; eauto.
        rewrite E in H2. inv H2. eassumption.
      * eapply lookup_ge_None in E. erewrite <- Forall2_length in E; eauto.
        rewrite seq_length in E. lia.
Qed.

Goal ACC -> AC_0_0.
Proof.
  unfold ACC, AC_0_0.
  intros H. eapply H.
Qed.

Lemma AC_1_0_to_AC_0_0 : AC_1_0 -> AC_0_0.
Proof.
  intros C R Htot.
  destruct (C (fun g x => R (g 0) x)) as [f].
  - intros g. eapply Htot.
  - exists (fun x => f (fun _ => x)).
    intros x. eapply (H (fun _ => x)).
Qed.

Lemma AC_0_0_to_AC_nat_bool : AC_0_0 -> AC_on nat bool.
Proof.
  intros C R Htot.
  destruct (C (fun n m => R n (Nat.eqb m 0))) as [f].
  - intros x. destruct (Htot x) as [ [] ].
    + exists 0. firstorder.
    + exists 1. firstorder.
  - eexists. eapply H.
Qed.

Lemma Diaconescu :
  (forall X Y, AC_on X Y) -> Fext -> Pext -> LEM.
Proof.
  intros C fext pext P.
  pose (U (x : bool) := x = true \/ P).
  pose (V (x : bool) := x = false \/ P).
  destruct (C ({ p : bool -> Prop | p = U \/ p = V}) bool (fun p b => (proj1_sig p b))) as [f Hf].
  - intros (p & [-> | ->]); cbn.
    + exists true. now left.
    + exists false. now left.
  - pose proof (Hf (exist _ U (or_introl eq_refl))) as H1.
    pose proof (Hf (exist _ V (or_intror eq_refl))) as H2. cbn in *.
    assert (f (exist _ U (or_introl eq_refl)) <> f (exist _ V (or_intror eq_refl)) \/ P) as [H3 | H3]; eauto.
    {
      destruct H1 as [H1 | H1], H2 as [H2 | H2]; eauto.
      firstorder congruence.
    }
    right. intros H.
    assert (U = V) as ->. {
      eapply fext. intros b. eapply pext.
      unfold U, V. intuition.
    }
    eapply H3. repeat f_equal.
    eapply (Pext_to_PI pext).
Qed.

(* *** Compatibility  *)
(*
Lemma AC_1_0_Fext :
  AC_1_0 -> Fext -> EA -> decidable (compl K_nat_nat).
Proof.
  intros C Fext EA.
  pose proof (fun f => enumerable_code EA _ (enumerable_graph' f)).
  eapply C in H as [code Hcode].
  exists (fun f => Nat.eqb (code f) (code (fun _ => 0))).
  eapply Proper_decider. intros ?. reflexivity.
  eapply (K_nat_equiv).
  intros f. split; rewrite NPeano.Nat.eqb_eq.
  - intros E.
    eapply f_equal, Fext, E.
  - intros E n.
    generalize (Hcode f), (Hcode (fun _ => 0)).
    rewrite E. clear E.
    intros Hf H.
    pose proof(enumerator_ext Hf H (ltac:(reflexivity)) ⟨ n, f n ⟩) as E.
    destruct E as [[x E%(f_equal unembed)] _]; eauto.
    rewrite !embedP in E. now inv E.
Qed. *)

Lemma AUC_to_dec (p : nat -> Prop) :
  AUC_on nat bool -> (forall n, p n \/ ~ p n) -> decidable p.
Proof.
  intros C Hp.
  destruct (C (fun n b => (p n /\ b = true) \/ (~ p n /\ b = false))) as [f Hf].
  - intros n. destruct (Hp n) as [H | H].
    + exists true.  split. left. eauto. intros [];  firstorder congruence. congruence.
    + exists false. split. right. eauto. intros []; firstorder congruence. congruence.
  - exists f. intros n. destruct (Hf n) as [[H ->] | [H ->]]; firstorder congruence. congruence.
Qed.

Lemma AC_0_0_LPO_incompat'  :
  AUC_on nat bool -> WLPO -> EPF_bool -> forall p : nat -> Prop,
    semi_decidable p -> decidable (compl p).
Proof.
  intros C LPO % WLPO_semidecidable_iff EPF p Hp.
  eapply AUC_to_dec; eauto.
Qed.

Lemma AC_0_0_LPO_incompat :
  AUC_on nat bool -> WLPO -> EPF_bool -> False.
Proof.
  intros C LPO EPF_bool.
  destruct (EPF_SCT_halting) as (K & H1 & H2 & H3 & H4); [eauto|].
  eapply H4. eapply AC_0_0_LPO_incompat'; eauto.
Qed.

Lemma AC_1_0_Fext_CODING :
  AC_1_0 -> Fext -> SCT -> CODING.
Proof.
  intros C Fext (ϕ & Hmono & Hϕ).
  assert (forall f : nat -> nat, exists c, forall x, exists n, ϕ c x n = Some (f x)) as [F HF] % C. {
    intros f. destruct (Hϕ (fun _ => f)) as [c Hc].
    eexists. eapply (Hc 0).
  }
  exists (fun (f : nat -> bool) => F (fun x : nat => if f x then 0 else 1)).
  intros f. split.
  + intros H x.
    pose proof (HF (λ _ : nat, 1) x) as [n1 Hn1]. rewrite <- H in Hn1.
    pose proof (HF (λ x : nat, if f x then 0 else 1) x) as [n2 Hn2].
    eapply monotonic_agnostic in Hn1. 2: eapply Hmono.
    eapply Hn1 in Hn2. destruct (f x); congruence.
  + intros H2. f_equal. eapply Fext. intros x. rewrite H2. reflexivity.
Qed.

Lemma AC_1_0_Fext_incompat :
  AC_1_0 -> Fext -> SCT -> False.
Proof.
  intros C funext ct.
  eapply K_nat_bool_undec; [ eauto | ].
  now eapply no_CODING, AC_1_0_Fext_CODING.
Qed.

(** ** Brouwer's intuitionism *)

Definition WC_N :=
  forall R : (nat -> nat) -> nat -> Prop,
    (forall α, exists x, R α x) -> forall α, exists L, exists y, forall β, map α L = map β L -> R β y.

Lemma max_list_with_spec' {X} (l : list X) f :
  l <> nil -> In (max_list_with f l) (map f l).
Proof.
  destruct l as [ | x l] using rev_ind; try congruence.
  clear IHl. intros _. induction l; cbn in *.
  - lia.
  - destruct (Nat.max_dec (f a) (max_list_with f (l ++ [x]))) as [H1 | H1].
    + now left.
    + right. rewrite H1 in *. eauto.
Qed.

Lemma max_list_spec' l :
  l <> nil -> In (max_list l) l.
Proof.
  intros H % (max_list_with_spec' _ id).
  now rewrite map_id in H.
Qed.

Lemma max_list_with_spec {X} (x : X) l f :
  In x l -> f x <= max_list_with f l.
Proof.
  intros H.
  induction l in x, H |- *.
  - inv H.
  - inv H; cbn.
    + lia.
    + eapply IHl in H0. lia.
Qed.

Lemma max_list_spec x l :
  In x l -> x <= max_list l.
Proof.
  eapply (max_list_with_spec x l id).
Qed.

Lemma WC_N_CT_inc :
  WC_N -> SCT -> False.
Proof.
  intros WC [ϕ [Hm CT]].
  edestruct (WC (fun α c => forall x, exists n, ϕ c x n = Some (α x))) with (α := fun x : nat => 0) as [L [c H]].
  - intros f. destruct (CT (fun _ => f)) as [c]. eexists. eapply (H 0).
  - unshelve epose proof (H (fun x => if ListDec.In_dec Nat.eq_dec x L is left _ then 0 else 1) _).
    + eapply map_ext_in. intros a Ha. now destruct List.In_dec.
    + destruct (H0 (1 + max_list L)).
      destruct (H _ eq_refl (1 + max_list L)).
      enough (1 = 0) by lia.
      eapply monotonic_agnostic.
      * eapply Hm.
      * rewrite H1. destruct ListDec.In_dec as [HH | HH].
        -- eapply max_list_spec in HH. lia.
        -- reflexivity.
      * eauto.
Qed.

Definition Cont := forall F : (nat -> nat) -> nat, forall f, exists L, forall g, map f L = map g L -> F f = F g.

Lemma WC_N_to_Cont :
  WC_N -> Cont.
Proof.
  intros H F f.
  edestruct (H (fun f n => F f = n)) as (L & c & Hc).
  + eauto.
  + exists L. intros g Hg.
    eapply Hc in Hg. rewrite Hg.
    now eapply Hc.
Qed.

Definition ADC_on' X := forall R : list X -> X -> Prop, (forall x, exists x', R x x') -> exists f : nat -> X, forall n, R (map f (seq 0 n)) (f n).

Lemma ADC_on'_iff :
  AC_on nat bool -> ADC_on' bool.
Proof.
  intros C R Htot.
  assert (datatype (list bool)) as (G & F & HFG). {
      eapply enumerable_discrete_datatype; eauto.
      eapply discrete_iff. econstructor. exact _.
  }
  pose (F' n := match F n with Some u => u | _ => [] end).
  destruct (C (fun n b => R (F' n) b)) as [f Hf]; eauto.
  pose (f' := fix f' n := match n with 0 => [] | S n => f' n ++ [f (G (f' n))] end).
  assert (Hlen : forall n, length (f' n) = n) by (induction n; cbn; rewrite ?app_length; cbn; lia).
  exists (fun n => nth n (f' (S n)) false).
  cbn. intros n.
  rewrite app_nth2. 2: rewrite Hlen; lia.
  assert (n - length (f' n) = 0) as -> by (rewrite Hlen; lia). cbn.
  specialize (Hf (G (f' n))).
  enough ((F' (G (f' n))) = map (λ n0 : nat, nth n0 (f' n0 ++ [f (G (f' n0))]) false) (seq 0 n)) by congruence.
  unfold F'. rewrite HFG.
  erewrite map_ext. 2:{
    intros a. rewrite app_nth2. 2: rewrite Hlen; lia.
    assert (a - length (f' a) = 0) as -> by (rewrite Hlen; lia). cbn. reflexivity.
  }
  clear.
  induction n.
  - reflexivity.
  - cbn [f']. replace (S n) with (n + 1) by lia.
    rewrite seq_app, map_app. cbn. congruence.
Qed.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_equ_equ_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_equ x1 L1 T1') ->
                  forall T2 L2 T2', T2 = (t_equ L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.


From Heapster Require Import
     Permissions
     PermissionsSpred2.

From Coq Require Import
     Classes.RelationClasses.

Section PermSet.
  Context {config : Type}.

  Record Perms2 :=
    {
      in_Perms2 : forall {spred}, @perm { x | spred x } -> Prop;
      (* Perms_upwards_closed1 : forall (spred1 spred2 : config -> Prop) *)
      (*                           (Hspred : forall x, spred1 x -> spred2 x) *)
      (*                           (p1 : @perm {x | spred1 x}) (p2 : @perm {x | spred2 x}), *)
      (*   in_Perms2 p1 -> *)
      (*   hlte_perm1 config spred1 spred2 Hspred p1 p2 -> *)
      (*   in_Perms2 p2 (* p2 has bigger spred *); *)
      Perms_upwards_closed2 : forall (spred1 spred2 : config -> Prop)
                                (Hspred : forall x, spred1 x -> spred2 x)
                                (p1 : @perm {x | spred2 x}) (p2 : @perm {x | spred1 x}),
        in_Perms2 p1 ->
        hlte_perm2 config spred1 spred2 Hspred p1 p2 ->
        in_Perms2 p2 (* p2 has smaller spred *)
    }.
  Notation "p ∈2 P" := (in_Perms2 P p) (at level 60).

  Definition lte_Perms2 (P Q : Perms2) : Prop :=
    forall spred (p : @perm {x | spred x}), p ∈2 Q -> p ∈2 P.
  Notation "P ⊑2 Q" := (lte_Perms2 P Q) (at level 60).

  Program Definition top_Perms2 : Perms2 :=
    {|
      in_Perms2 := fun _ _ => False
    |}.
  Program Definition bottom_Perms2 : Perms2 :=
    {|
      in_Perms2 := fun _ _ => True
    |}.

  Program Definition sep_conj_Perms2 (P Q : Perms2) : Perms2 :=
    {|
      in_Perms2 := fun spred r =>
                     exists spred' Hspred (p q : @perm {x | spred' x}),
                       in_Perms2 P p /\
                         in_Perms2 Q q /\
                         hlte_perm2 config spred spred' Hspred (p ** q) r
    |}.
  Next Obligation.
    rename H into spred', H1 into Hspred', H2 into p, H3 into q.
    exists spred'. eexists. Unshelve.
    2: { intros. auto. }
    exists p, q. split; [| split]; auto. eapply hlte_perm2_transitive; eauto.
  Qed.

End PermSet.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__collinearorder.
Require Export lemma__inequalitysymmetric.
Require Export lemma__samesidesymmetric.
Require Export logic.
Definition lemma__tarskiparallelflip : forall A B C D, (euclidean__defs.TP A B C D) -> ((euclidean__defs.TP B A C D) /\ ((euclidean__defs.TP A B D C) /\ (euclidean__defs.TP B A D C))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((~(euclidean__defs.Meet A B C D)) /\ (euclidean__defs.OS C D A B)))) as H0.
- assert ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((~(euclidean__defs.Meet A B C D)) /\ (euclidean__defs.OS C D A B)))) as H0 by exact H.
assert ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((~(euclidean__defs.Meet A B C D)) /\ (euclidean__defs.OS C D A B)))) as __TmpHyp by exact H0.
destruct __TmpHyp as [H1 H2].
destruct H2 as [H3 H4].
destruct H4 as [H5 H6].
split.
-- exact H1.
-- split.
--- exact H3.
--- split.
---- exact H5.
---- exact H6.
- assert (* Cut *) (euclidean__defs.OS D C A B) as H1.
-- destruct H0 as [H1 H2].
destruct H2 as [H3 H4].
destruct H4 as [H5 H6].
assert (* Cut *) ((euclidean__defs.OS D C A B) /\ ((euclidean__defs.OS C D B A) /\ (euclidean__defs.OS D C B A))) as H7.
--- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric A B C D H6).
--- destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
exact H8.
-- assert (* Cut *) (euclidean__axioms.neq D C) as H2.
--- destruct H0 as [H2 H3].
destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C D H4).
--- assert (* Cut *) (~(euclidean__defs.Meet A B D C)) as H3.
---- intro H3.
assert (* Cut *) (exists T, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.Col A B T) /\ (euclidean__axioms.Col D C T)))) as H4.
----- destruct H0 as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
exact H3.
----- destruct H4 as [T H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H0 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
assert (* Cut *) (euclidean__axioms.Col C D T) as H18.
------ assert (* Cut *) ((euclidean__axioms.Col C D T) /\ ((euclidean__axioms.Col C T D) /\ ((euclidean__axioms.Col T D C) /\ ((euclidean__axioms.Col D T C) /\ (euclidean__axioms.Col T C D))))) as H18.
------- apply (@lemma__collinearorder.lemma__collinearorder D C T H11).
------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
exact H19.
------ assert (euclidean__axioms.neq C D) as H19 by exact H14.
assert (* Cut *) (euclidean__defs.Meet A B C D) as H20.
------- exists T.
split.
-------- exact H6.
-------- split.
--------- exact H19.
--------- split.
---------- exact H10.
---------- exact H18.
------- apply (@H16 H20).
---- assert (* Cut *) (euclidean__defs.TP A B D C) as H4.
----- destruct H0 as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
split.
------ exact H4.
------ split.
------- exact H2.
------- split.
-------- intro H10.
assert (* Cut *) (False) as H11.
--------- apply (@H3 H10).
--------- contradiction H11.
-------- exact H1.
----- assert (* Cut *) (~(euclidean__defs.Meet B A C D)) as H5.
------ intro H5.
assert (* Cut *) (exists T, (euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col B A T) /\ (euclidean__axioms.Col C D T)))) as H6.
------- destruct H0 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
exact H5.
------- destruct H6 as [T H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H0 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
assert (* Cut *) (euclidean__axioms.Col A B T) as H20.
-------- assert (* Cut *) ((euclidean__axioms.Col A B T) /\ ((euclidean__axioms.Col A T B) /\ ((euclidean__axioms.Col T B A) /\ ((euclidean__axioms.Col B T A) /\ (euclidean__axioms.Col T A B))))) as H20.
--------- apply (@lemma__collinearorder.lemma__collinearorder B A T H12).
--------- destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
exact H21.
-------- assert (* Cut *) (euclidean__defs.Meet A B C D) as H21.
--------- exists T.
split.
---------- exact H14.
---------- split.
----------- exact H10.
----------- split.
------------ exact H20.
------------ exact H13.
--------- apply (@H18 H21).
------ assert (* Cut *) (euclidean__axioms.neq B A) as H6.
------- destruct H0 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A B H6).
------- assert (* Cut *) (euclidean__defs.OS D C A B) as H7.
-------- destruct H0 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
assert (* Cut *) ((euclidean__defs.OS D C A B) /\ ((euclidean__defs.OS C D B A) /\ (euclidean__defs.OS D C B A))) as H13.
--------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric A B C D H12).
--------- destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H1.
-------- assert (* Cut *) (euclidean__defs.OS C D B A) as H8.
--------- destruct H0 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
assert (* Cut *) ((euclidean__defs.OS C D A B) /\ ((euclidean__defs.OS D C B A) /\ (euclidean__defs.OS C D B A))) as H14.
---------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric A B D C H7).
---------- destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
exact H18.
--------- assert (* Cut *) (euclidean__defs.OS D C B A) as H9.
---------- destruct H0 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
assert (* Cut *) ((euclidean__defs.OS D C B A) /\ ((euclidean__defs.OS C D A B) /\ (euclidean__defs.OS D C A B))) as H15.
----------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric B A C D H8).
----------- destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
exact H16.
---------- assert (* Cut *) (euclidean__defs.TP B A C D) as H10.
----------- destruct H0 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
split.
------------ exact H6.
------------ split.
------------- exact H12.
------------- split.
-------------- intro H16.
assert (* Cut *) (False) as H17.
--------------- apply (@H5 H16).
--------------- contradiction H17.
-------------- exact H8.
----------- assert (* Cut *) (~(euclidean__defs.Meet B A D C)) as H11.
------------ intro H11.
assert (* Cut *) (exists T, (euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.Col B A T) /\ (euclidean__axioms.Col D C T)))) as H12.
------------- destruct H0 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H11.
------------- destruct H12 as [T H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H0 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
assert (* Cut *) (euclidean__axioms.Col A B T) as H26.
-------------- assert (* Cut *) ((euclidean__axioms.Col A B T) /\ ((euclidean__axioms.Col A T B) /\ ((euclidean__axioms.Col T B A) /\ ((euclidean__axioms.Col B T A) /\ (euclidean__axioms.Col T A B))))) as H26.
--------------- apply (@lemma__collinearorder.lemma__collinearorder B A T H18).
--------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
exact H27.
-------------- assert (* Cut *) (euclidean__axioms.Col C D T) as H27.
--------------- assert (* Cut *) ((euclidean__axioms.Col C D T) /\ ((euclidean__axioms.Col C T D) /\ ((euclidean__axioms.Col T D C) /\ ((euclidean__axioms.Col D T C) /\ (euclidean__axioms.Col T C D))))) as H27.
---------------- apply (@lemma__collinearorder.lemma__collinearorder D C T H19).
---------------- destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
exact H28.
--------------- assert (* Cut *) (euclidean__defs.Meet A B C D) as H28.
---------------- exists T.
split.
----------------- exact H20.
----------------- split.
------------------ exact H22.
------------------ split.
------------------- exact H26.
------------------- exact H27.
---------------- apply (@H24 H28).
------------ assert (* Cut *) (euclidean__defs.TP B A D C) as H12.
------------- split.
-------------- exact H6.
-------------- split.
--------------- exact H2.
--------------- split.
---------------- exact H11.
---------------- exact H9.
------------- assert (* Cut *) (exists Q P R, (euclidean__axioms.Col A B P) /\ ((euclidean__axioms.Col A B R) /\ ((euclidean__axioms.BetS C P Q) /\ ((euclidean__axioms.BetS D R Q) /\ ((euclidean__axioms.nCol A B C) /\ (euclidean__axioms.nCol A B D)))))) as H13.
-------------- destruct H0 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
exact H18.
-------------- destruct H13 as [P H14].
destruct H14 as [Q H15].
destruct H15 as [R H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H0 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
split.
--------------- exact H10.
--------------- split.
---------------- exact H4.
---------------- exact H12.
Qed.


Require Import Eqdep_dec.
Require Import PArith.
From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Open Scope positive_scope.

Section Section.
Context {A:Type}.

Definition eqb_correct_on (eqb : A -> A -> bool) (a1:A) :=
   forall a2, eqb a1 a2 -> a1 = a2.

Definition eqb_refl_on (eqb : A -> A -> bool) (a:A) :=
  eqb a a.

Definition eqax_on (eqb : A -> A -> bool) (a1:A) :=
   forall a2, reflect (a1 = a2) (eqb a1 a2).

Class obj :=
  { tag       : A -> positive
  ; fields_t  : positive -> Type
  ; fields    : forall a, fields_t (tag a)
  ; construct : forall t, fields_t t -> option A
  ; constructP : forall a, construct (fields a) = Some a }.

Context {o:obj} (eqb_fields : forall t, fields_t t -> fields_t t -> bool).

Definition eqb_body (t1:positive) (f1:fields_t t1) (x2:A) :=
  let t2 := tag x2 in
  match Pos.eq_dec t2 t1 with
  | left heq =>
    let f2 := fields x2 in
    @eqb_fields t1 f1 (@eq_rect positive t2 fields_t f2 t1 heq)
  | right _ => false
  end.

Definition eqb_fields_correct_on (a:A) :=
  forall f : fields_t (tag a),
    eqb_fields (fields a) f -> Some a = construct f.

Lemma eqb_body_correct a1 :
  eqb_fields_correct_on a1 ->
  forall a2, eqb_body (fields a1) a2 -> a1 = a2.
Proof.
  move=> hf a2 hb.
  suff : Some a1 = Some a2 by move=> [->].
  rewrite -(constructP a2); move: hb; rewrite /eqb_body.
  case: Pos.eq_dec => // heq.
  move: (tag a2) heq (fields a2) => t2 ?; subst t2 => f2 /=; apply hf.
Qed.

Definition eqb_fields_refl_on (a:A) :=
  eqb_fields (fields a) (fields a).

Lemma eqb_body_refl a :
  eqb_fields_refl_on a ->
  eqb_body (fields a) a.
Proof.
  rewrite /eqb_body => hf.
  case: Pos.eq_dec => // heq.
  have -> /= := Eqdep_dec.UIP_dec Pos.eq_dec heq erefl; apply hf.
Qed.

End Section.


Require Import simple.

Require Import List.
Require Import ZArith.

Definition f_code :=
  SReturn (EPlus (EVar "x") (EPlus (EVar "y") (EMult (EVar "x") (EVar "y")))).

Definition comm_assoc_code :=
  SIf
    (BAnd (BEq (ECall "f" (EVar "x" :: EVar "y" :: nil))
               (ECall "f" (EVar "y" :: EVar "x" :: nil)))
          (BEq (ECall "f" (EVar "x" :: ECall "f" (EVar "y" :: EVar "z" :: nil) :: nil))
               (ECall "f" (ECall "f" (EVar "x" :: EVar "y" :: nil) :: EVar "z" :: nil))))

    (SReturn (ECon 1))
    (SReturn (ECon 0)).

Require Import Setoid.

Lemma comm_assoc_spec : forall c, kcell c = kra (KStmt comm_assoc_code) kdot ->
  forall xv yv zv, store c ~=
    ("x" s|-> KInt xv :* "y" s|-> KInt yv :* "z" s|-> KInt zv) ->
    functions c ~= ("f" s|-> FunDef "f" ["x";"y"] f_code) ->
  sound kstep (returns c 1).
Proof.
simple_solver.
Qed.


Require Export LovaszExp.
Require Export GraphCovers.
Set Implicit Arguments.

Section MeetsDef.
  Context { A: ordType }.

  Definition meets (K I: list A):= exists a:A, In a K /\ In a I.

  End MeetsDef.

Section ExistsCliq.

  Context { A: ordType }.
  Variable G: (@UG A).

  Hypothesis Gnil: (nodes G) <> nil.
  Hypothesis GPerfect: Perfect G.

  Let C:= max_subs_of G (fun I => stable G I).
  Let C':= mk_disj C.

  Let N:= union_over C.
  Let N':= union_over C'.

  Let H:= (ind_at N G).
  Let E:= (edg H).

  Let g:= fun (x: A*nat) => fst x.

  Let E1:= fun (x y: A*nat) => match (g x == g y) with
                          | true => match (snd x == snd y) with
                                   |true => false
                                   |false => true
                                   end
                          |false => E (g x) (g y)
                          end.

  Lemma N'IsOrd: IsOrd N'.
  Proof. subst N'. auto. Qed.

  Lemma NIsOrd: IsOrd N.
  Proof. subst N. auto. Qed.

  Hint Resolve N'IsOrd NIsOrd.

  Lemma E1_irefl: irefl E1.
  Proof. { unfold irefl. intro p. unfold E1.
           replace (g p == g p) with true.
           assert (h1: snd p == snd p). apply /eqP;auto.
           rewrite h1. auto. symmetry;auto. } Qed.

  Lemma E1_sym: sym E1.
  Proof. { unfold sym. intros x y. unfold E1.
         destruct (g x == g y) eqn: h1; destruct (snd x == snd y) eqn: h2.
         { move /eqP in h1. symmetry in h1. move /eqP in h1. rewrite h1. rewrite h2.
           move /eqP in h2. symmetry in h2. move /eqP in h2. rewrite h2. auto. }
         { rewrite h2. move /eqP in h1. symmetry in h1. move /eqP in h1. rewrite h1.
           assert (h3: (snd y == snd x) = false).
           switch. switch_in h2. intro h3; apply h2; eauto. rewrite h3;auto. }
         { move /eqP in h2. symmetry in h2. move /eqP in h2. rewrite h2.
           assert (h3: (g y == g x) = false).
           switch. switch_in h1. intro h3; apply h1; eauto. rewrite h3.
           unfold E. auto. }
         { assert (h3: (g y == g x) = false).
           switch. switch_in h1. intro h3; apply h1; eauto. rewrite h3.
           unfold E. auto. } } Qed.

  (*-----Some  more properties of the new edg relation (E1 x y)------------*)
  Lemma E1_P1: forall x y, x <> y -> g x = g y -> E1 x y.
  Proof. { intros x y h1 h2. unfold E1.
           replace (g x == g y) with true. replace (snd x == snd y) with false.
           auto. symmetry;switch. move /eqP. intro h3.
           absurd (x = y). auto.
           destruct x as [x1 x2]; destruct y as [y1 y2]; simpl in h2,h3.
           subst x1; subst x2. auto. symmetry;auto. } Qed.

  Lemma E1_P2: forall x y, g x <> g y -> E1 x y = E (g x) (g y).
  Proof. { intros x y h1. unfold E1. replace ( g x == g y) with false. auto.
           symmetry;auto. } Qed.

  Hint Immediate E1_P1 E1_P2.

  (*------ The edge relation E1 when restricted to N' is denoted as E' --------*)

  Let E':= E1 at_ N'.

  Lemma E'_out: E' only_at N'.
  Proof. unfold E'. auto. Qed.

  Lemma E'_irefl: irefl E'.
  Proof. unfold E'. cut (irefl E1). auto. apply E1_irefl. Qed.

  Lemma E'_sym: sym E'.
  Proof. unfold E'. cut (sym E1). auto. apply E1_sym. Qed.

  Definition H' := ({| nodes:= N'; edg:= E'; nodes_IsOrd:= N'IsOrd;
                       edg_irefl:= E'_irefl; edg_sym:= E'_sym; out_edg:= E'_out |}).

  (*-------- nodes of H and H' are related via stable sets in C and C' respectievly ------*)

  Lemma N_sub_G: N [<=] G.
  Proof. subst N. cut (forall I, In I C -> I [<=] G). auto.
         intros I h1. subst C. eauto. Qed.

  Hint Resolve N_sub_G.

  Lemma NG_N: N [i] G = N.
  Proof. symmetry. cut (N [<=] G). all: auto. Qed.

  Hint Resolve N_sub_G NG_N.

  Lemma mem_of_C: forall I, In I C -> Max_I_in G I.
  Proof.  intros I h1. unfold C in h1. unfold Max_I_in.
          apply max_subs_of_elim; auto. Qed.

  Lemma max_I_of_H: forall I, In I C -> Max_I_in H I.
  Proof. { intros I h1.
           assert (h2: I [<=] H).
           { simpl. rewrite NG_N. unfold N.
             intros x h2. eapply union_over_intro;eauto. }
           apply mem_of_C in h1 as h3.
           apply Max_I_in_intro.
           eapply Stable_in_GH with (G0:= G).
           unfold H. auto. auto. auto.
           intros I' h4. cut (Stable_in G I'). eauto.
           eapply Stable_in_HG with (H0:= H). unfold H. all: auto. } Qed.

  Lemma mem_of_C': forall I, In I C -> In (I [,] (idx I C)) C'.
  Proof. subst C'. intros I h1.  apply mk_disj_intro. auto. Qed.

  Lemma C'_map_to_C: forall I, In I C -> I = img g (I [,] (idx I C)).
  Proof. intros I h1. unfold g. apply fix_nat_prop2.
         subst C. cut (IsOrd G). eauto. auto. Qed.

  Hint Resolve mem_of_C max_I_of_H mem_of_C' C'_map_to_C.

  Lemma C_and_C': (nodes H) = img g H'.
  Proof. simpl. rewrite NG_N. subst N. subst N'. subst C'. unfold g.  auto.  Qed.

  Lemma E'_P1: forall x y, In x H' -> In y H' -> x <> y -> g x = g y -> edg H' x y.
  Proof. intros x y hx hy h1 h2. simpl. replace ( E' x y) with (E1 x y).
         Focus 2. unfold E'. simpl in hx, hy. auto. auto. Qed.

  Lemma E'_P2:  forall x y, In x H' -> In y H' -> g x <> g y -> edg H (g x) (g y) = edg H' x y.
  Proof. intros x y hx hy h1. symmetry. simpl (edg H' x y).
         replace ( E' x y) with (E1 x y). Focus 2. unfold E'. simpl in hx, hy. auto.
         auto. Qed.

  Hint Resolve C_and_C'.
  Hint Immediate E'_P1 E'_P2.

  Lemma H'_exp_of_H: Exp_of H H' g.
  Proof. { unfold Exp_of.
           split.
           {(*- H = img g H' ---*)
             auto. }
           split.
           { (*- In x H' -> In y H' -> x <> y -> g x = g y -> edg H' x y -*)
             apply E'_P1. }
           { (*- In x H' -> In y H' -> g x <> g y -> edg H (g x) (g y) = edg H' x y -*)
             apply E'_P2. } } Qed.

  Hint Resolve H'_exp_of_H.

  Lemma C'_is_disj: forall I1 I2, In I1 C' -> In I2 C' -> I1 <> I2 -> I1 [i] I2 = nil.
  Proof. { intros I1' I2' h1 h2 h3.
           assert (h4:  I1' [i] I2' = nil \/  I1' [i] I2' <> nil). eauto.
           destruct h4 as [h4 |h4].
           { auto. }
           assert (h4a: exists y, In y (I1' [i] I2')). auto.
           destruct h4a as [y h4a].
           assert (h4b: In y I1'). eauto. assert (h4c: In y I2'). eauto.
           unfold C' in h1, h2.
           apply mk_disj_elim in h1 as h1a.
           apply mk_disj_elim in h2 as h2a.
           destruct h1a as [I1 h1a]; destruct h1a as [h1a h1b].
           destruct h2a as [I2 h2a]; destruct h2a as [h2a h2b].
           subst I1'. subst I2'. destruct y as [y1 y2].
           assert (h5: I1 <> I2).
           { intros h5. subst I1.
             absurd (I2 [,] idx I2 C = I2 [,] idx I2 C);auto. }
           assert (h6a: y2 = idx I1 C).
           eapply fix_nat_elim1. apply h4b.
           assert (h6b: y2 = idx I2 C).
           eapply fix_nat_elim1. apply h4c.
           assert (h7: I1 = I2).
           { cut (idx I1 C = idx I2 C).
             eapply same_index;auto. omega. }
           contradiction. } Qed.

  Lemma Stable_cover_C'_H': Stable_cover C' H'.
  Proof. { unfold Stable_cover.
           split.
           { simpl. unfold Set_cover. unfold N';auto. }
           { intros I' h1. unfold C' in h1.
             apply mk_disj_elim in h1 as h1a.
             destruct h1a as [I h1a]. destruct h1a as [h1a h1b].
             split. Focus 2. rewrite h1b. cut (IsOrd I). auto.
             assert (h1c: Max_I_in G I). auto. eauto.
             assert (h2: I = img g I').
             { rewrite h1b. auto. }
             assert (h3: Exp_of H H' g). auto.
             assert (h4: Stable_in H I). auto.
             assert (h5: I' [<=] H').
             { simpl. unfold N'. unfold C'.
               intros x h5. eapply union_over_intro;eauto. }
             unfold Stable. intros x y hx hy.
             destruct h4 as [h4a h4]. unfold Stable in h4.
             assert (h6: g x = g y \/ g x <> g y). eauto.
             destruct h6 as [h6a | h6b].
             { assert (h6b: x = y).
               { destruct x as [x1 x2]; destruct y as [y1 y2].
                 cut (x1 = y1). cut (x2 = y2).
                 intros h7 h8;subst x1;subst x2; auto.
                 subst I'. replace y2 with (idx I C). eapply fix_nat_elim1; apply hx.
                 symmetry; eapply fix_nat_elim1; apply hy. simpl in h6a. auto. }
               rewrite h6b. auto. }
             { replace ( edg H' x y) with ( edg H (g x) (g y)).
               apply h4; subst I;auto. apply E'_P2;auto. } } } Qed.

  Lemma C'_mem_stable: forall I, In I C' -> Stable_in H' I.
  Proof. intros I h1. specialize Stable_cover_C'_H' as h2. eauto. Qed.

  Hint Resolve Stable_cover_C'_H' C'_mem_stable.

  Lemma g_one_one_on_I': forall I', Stable_in H' I' -> one_one_on I' g.
  Proof. { intros I' h1. unfold one_one_on.
           destruct h1 as [h1 h2]. unfold Stable in h2.
           intros x y hx hy h3 h4.
           absurd (edg H' x y). switch. apply h2;auto.
           apply E'_P1. all: eauto. } Qed.

  Lemma img_of_I'_is_I: forall I', Stable_in H' I' -> Stable_in H (img g I').
  Proof. { intros I' h1.
           assert (H1: one_one_on I' g).
           { apply g_one_one_on_I';auto. }
           assert (h1a: I' [<=] H'). auto.
           assert (h2: (nodes H) = img g H'). auto.
           unfold Stable_in.
           assert (h3: img g I' [<=] H).
           { rewrite h2;auto. } split. auto.
           split. cut (IsOrd I'); auto. eauto.
           unfold Stable. intros gx gy h4 h5.
           assert (h4a: exists x, In x I' /\ gx = g x). auto.
           destruct h4a as [x h4a]. destruct h4a as [h4a h4b].
           assert (h5a: exists y, In y I' /\ gy = g y). auto.
           destruct h5a as [y h5a]. destruct h5a as [h5a h5b].
           subst gx; subst gy.
           destruct h1 as [h1b h1]. unfold Stable in h1.
           assert (h6: x = y \/ x <> y). eauto.
           destruct h6 as [h6a | h6b].
           { subst x. auto. }
           { replace (edg H (g x) (g y)) with (edg H' x y).
             apply h1;auto. symmetry;apply E'_P2;auto. } } Qed.

  Lemma Stable_in_H': forall I, In I C' -> Max_I_in H' I.
  Proof. { intros I' h1. apply Max_I_in_intro. auto.
           intros I1 h2.
           assert (h3: exists I, In I C /\ I' = I [,] (idx I C)). auto.
           destruct h3 as [I h3]. destruct h3 as [h3a h3].
           assert (h4: I = img g I'). rewrite h3. auto.
           apply max_I_of_H in h3a as h3b.
           set (I0 := img g I1).
           assert (h5: Stable_in H I0).
           { unfold I0. apply img_of_I'_is_I. auto. }
           assert (hI': Stable_in H' I'). auto.
           assert (h8: one_one_on I' g).
           { apply g_one_one_on_I'; auto. }
            assert (h9: one_one_on I1 g).
           { apply g_one_one_on_I'; auto. }
           assert (h6: |I'| = |I|).
           { subst I. cut(IsOrd I'). auto. eauto. }
           assert (h7: |I1| = |I0|).
           { subst I0. cut(IsOrd I1). auto. eauto. }
           rewrite h6; rewrite h7. eauto. } Qed.

  Lemma PerfectH': Perfect H'.
  Proof. cut (Perfect H). eapply LovaszExpLemma. apply H'_exp_of_H.
         cut (Ind_subgraph H G). eauto. unfold H. auto. Qed.

  Lemma K'_meets_all_in_C': (exists K', Cliq_in H' K' /\ (forall I, In I C' -> meets K' I)).
  Proof. { destruct (i_num_of G) as [n h1].
           assert (hn: n >= 1).
           { eapply i_num_gt; eauto. }
           assert (h2: i_num H n).
           { destruct h1 as [I h1]. exists I.
             split. Focus 2. apply h1.
             destruct h1 as [h1a h1].
             apply Max_I_in_intro. cut (I [<=] H). cut (Stable_in G I).
             cut (Ind_subgraph H G). eauto. unfold H. auto. auto.
             simpl. rewrite NG_N. unfold N.
             cut (In I C). intros h2 x h3. eauto. unfold C. auto.
             intros I' h2.
             assert (h3: Stable_in G I').
             { eapply Stable_in_HG with (H0:= H). unfold H. auto. auto. }
             eapply Max_I_in_elim. apply h1a. auto. }

           assert (h3: i_num H' n).
           { destruct h1 as [I h1].  destruct h1 as [h1a h1].
             assert (h2b: In I C).
             { unfold C. auto. }
             apply mem_of_C' in h2b as h3.
             set(I':=  (I [,] idx I C)). fold I' in h3.
             assert (h4: |I| = |I'|).
             { unfold I'. apply fix_nat_size. }
             exists I'. split. apply Stable_in_H'. auto.
             subst n. symmetry. apply h4. }

           assert (h4: Perfect H').
           { apply PerfectH'. }

           assert (h5: chrom_num H' (|C'|)).
           { assert (h6: exists f, Coloring_of H' f /\ |clrs_of f H'| = |C'|).
             { eapply disj_cover_to_color.
               { apply Stable_cover_C'_H'. }
               { cut (IsOrd C'). auto. unfold C'. cut (IsOrd C).
                 auto. unfold C. unfold max_subs_of. auto. }
               { apply C'_is_disj. }
               { intros I h5 h6.
                 specialize (Stable_in_H' I h5) as h7.
                 destruct h3 as [I' h3]. destruct h3 as [h3a h3].
                 assert(h8: n <= |I|).
                 { rewrite <- h3. apply h7.
                   cut (I' [<=] H'). cut (IsOrd I').  eauto. eauto. auto.
                   apply /stableP. auto. }
                 subst I. simpl in h8. omega. } }

             destruct h6 as [f h6]. destruct h6 as [h6a h6].
             exists f. split.
             { unfold Best_coloring_of.
               split.
               auto.
               intros f1 h7. rewrite h6.
               assert (h8: (| C' |) <= (| clrs_of f1 H' |) \/ ~ (| C' |) <= (| clrs_of f1 H' |)).
               eauto. destruct h8 as [h8 |h8]. auto.
               assert (h8a: (| C' |) > (| clrs_of f1 H' |)). omega.
               specialize (color_to_cover h7) as h9.
               destruct h9 as [C1 h9]. destruct h9 as [h9a h9b].
               rewrite <- h9b. rewrite <- h9b in h8a.
               assert (h9c:  exists I1, In I1 C1 /\ (|I1| * |C1|) >= |N'|).
               { (*- proof using lemma large_set_in_cover --*)
                 apply large_set_in_cover.
                 { (*-- N' <> nil -*)
                   destruct h1 as [I h1]. destruct h1 as [h1a h1].
                   destruct I as [|a I'] eqn: HI. rewrite <- h1 in hn.
                   simpl in hn. inversion hn.
                   assert (h1b: In I C).
                   { unfold C.  apply max_subs_of_intro. auto.
                     rewrite <- HI in h1a. auto. }
                   assert (h1c: In a I).
                   { subst I. auto. }
                   set (i:= idx I C).
                   assert (h1d: In (a,i) (I [,] i)).
                   { unfold i. auto. }
                   assert (h1e: In (I [,] i) C').
                   { unfold C'. unfold i. auto. }
                   assert (h1f: In (a,i) N').
                   { unfold N'. eauto. }
                   intro h10. rewrite h10 in h1f. simpl in h1f. auto. }
                 { (*-- In x C1 -> IsOrd x -*)
                   intros I hI. cut(Stable_in H' I). eauto. eauto. }
                 { apply h9a. } }

               destruct h9c as [I1 h9c]. destruct h9c as [h9c h9d].

               assert (h9e: Stable_in H' I1).
               { eauto. }

               assert (h9f: |I1| <= n).
               { destruct h3 as [I h3]. destruct h3 as [h3a h3b].
                 rewrite <- h3b. apply h3a. cut (I1 [<=] H'). cut (IsOrd I1).
                 auto. eauto. eauto. apply /stableP. auto. }

               assert (h10: Stable_cover C' H').
               { apply Stable_cover_C'_H'. }

               assert (h10a:  |N'| = |C'| * n).
               { (*-- proof using lemma disj_cover_card ---*)
                 apply disj_cover_card.
                 { unfold Stable_cover in h10. apply h10. }
                 { unfold C'. cut (IsOrd C). auto.
                   unfold C. unfold max_subs_of. auto. }
                 { intros I h11. apply Stable_in_H' in h11 as h12.
                   split. eauto.  symmetry. eauto. }
                 { apply C'_is_disj. } }

               rewrite h10a in h9d.
               assert(h11: (| I1 |) * (| C1 |) <= n * (| C1 |)).
               { auto with arith. }
               assert (h12:  n * (| C1 |) <  n * (| C' |)).
               { auto with arith. }
               assert (h13:  (| I1 |) * (| C1 |) < (| C' |) * n).
               { replace ((| C' |) * n) with (n*(| C' |)). omega.
                 auto with arith. } omega. }
             { auto. } }

           assert (h6: cliq_num H' (|C'|)).
           {  assert (h6: Nice H'). auto.
              apply nice_elim;auto. }

           destruct h6 as [K' h6]. destruct h6 as [h6a h6].
           exists K'. split. auto. intros I h7.
           unfold meets. eapply php_eq with (s:= C').
           { eauto. }
           { unfold C'. cut (IsOrd C). auto.
             unfold C. unfold max_subs_of. auto. }
           { auto. }
           { intros x h8. unfold Max_K_in in h6a.
             assert (h6b: K' [<=] H'). apply h6a.
             assert (h8a: In x H'). auto.
             unfold H' in h8a. simpl in h8a. unfold N' in h8a.
             apply union_over_elim. auto.  }
           { intros x y I1 hxk hyk h8 hxi hyi.
             assert (h9: Cliq H' K').
             { cut(Cliq_in H' K'). auto. auto. }
             assert (h9a: Stable H' I1).
             { cut (Stable_in H' I1). auto. cut (Max_I_in H' I1).
               auto. apply Stable_in_H'. auto. }
             unfold Cliq in h9. unfold Stable in h9a.
             specialize (h9 x y hxk hyk) as h9b.
             destruct h9b as [h9b | h9b].
             auto. absurd (edg H' x y). switch. all: auto. } auto. } Qed.

   Lemma K_meets_all_in_C: (exists K, Cliq_in H K /\ (forall I, In I C -> meets K I)).
  Proof. { destruct K'_meets_all_in_C' as [K' h1].
           destruct h1 as [h1 h2].
           set (K:= img g K').
           exists K.
           split.
           { (*-- Cliq_in H K --*)
             unfold Cliq_in.
             assert (h3: K [<=] H).
             { rewrite C_and_C'. subst K. cut (K' [<=] H'). auto. auto. }
             split.
             { auto. }
             split.
             { subst K. auto. }
             { unfold Cliq. intros gx gy h4 h5.
               assert (h4a: exists x, In x K' /\ gx = g x).
               { unfold K in h4. auto. }
               assert (h5a: exists y, In y K' /\ gy = g y).
               { unfold K in h5. auto. }
               destruct h4a as [x h4a]. destruct h4a as [h4a h4b].
               destruct h5a as [y h5a]. destruct h5a as [h5a h5b].
               assert (h6: gx = gy \/ gx <> gy). eauto.
               destruct h6 as [h6 | h6].
               { left. auto. }
               { right. subst gx. subst gy.
                 replace (edg H (g x) (g y)) with (edg H' x y).
                 unfold Cliq_in in h1. unfold Cliq in h1.
                 assert (h7: x = y \/ edg H' x y). apply h1;auto.
                 destruct h7 as [h7 |h7]. subst x.
                 absurd (g y = g y);auto. auto.
                 assert (h7: K' [<=] H'). apply h1.
                 symmetry. apply E'_P2. all: eauto. } } }
           { (*--- forall I : list A, In I C -> meets K I -- *)
             intros I h3.
             specialize (C'_map_to_C I h3) as h4.
             set (I':=  (I [,] idx I C)).
             assert (h5: meets K' I').
             { apply h2. unfold C'. unfold I'. auto. }
             destruct h5 as [x h5]. destruct h5 as [h5 h6].
             exists (g x). split. subst K. auto. rewrite h4. fold I'. auto. } } Qed.

  Lemma Cliq_meets_all_MaxI: (exists K, Cliq_in G K /\ (forall I, Max_I_in G I -> meets K I)).
  Proof. { destruct K_meets_all_in_C as [K h1].
           destruct h1 as [h1 h2].
           exists K.
           split.
           { (*-- Cliq_in H K -> Cliq_in G K --*)
             assert (h3: Ind_subgraph H G). subst H. auto. eauto. }
           { (*-- forall I : list A, Max_I_in G I -> meets K I --*)
             intros I h3. apply h2. subst C. apply max_subs_of_intro.
             auto. unfold Max_I_in in h3. auto. } } Qed.

End ExistsCliq.

Section WPerfect.

  Context { A: ordType }.

  Lemma cliq_meets_stable_once (G: @UG A)(K: list A)(I: list A)(x y: A):
    Cliq G K -> Stable G I -> In x K -> In y K -> In x I -> In y I -> x = y.
  Proof. { intros h1 h2 hxk hyk hxi hyi. unfold Cliq in h1;unfold Stable in h2.
           specialize (h1 x y hxk hyk) as h1a.
           destruct h1a as [h1a | h1b].
           { auto. }
           { absurd (edg G x y). switch;apply h2;auto. auto. } } Qed.

  Lemma i_num_cliq_cover (G: @UG A)(n: nat):
    Perfect G -> i_num G n -> (exists C, Cliq_cover C G /\ |C| = n).
  Proof. { revert G. induction n using strong_induction.
           intros G h1 h2.
           destruct h2 as [I h2]. destruct h2 as [h2a h2].
           assert (hN: nodes G = nil \/ nodes G <> nil). eauto.
           destruct hN as [hNa | hNb].
           {(*---- When the graph is empty Graph i.e nodes G = nil  ---------*)
             exists nil. split.
             { (*-- Cliq_cover nil G --*)
               unfold Cliq_cover. split.
               unfold Set_cover. rewrite hNa. simpl. auto.
               simpl. tauto. }
             { (*---  (| nil |) = n ----*)
               simpl.
               assert (hI: I = nil).
               { destruct h2a as [h2a h2b]. rewrite hNa in h2a.
                 apply set_equal. apply h2b. constructor. split; auto. }
               subst I. simpl in h2. auto. }   }

           {(*----- When the graph is non-empty i.e nodes G <> nil ----------*)
             specialize (Cliq_meets_all_MaxI hNb h1) as h1a.
             destruct h1a as [K h1a]. destruct h1a as [h1a h1b].
             assert (hg: exists g, In g G). auto.
             destruct hg as [g hg].

             assert (hn: n >= 1).
             { set (I':= g::nil).
               assert (hI': Stable_in G I').
               { unfold Stable_in. subst I'.
                 split.
                 { intros x hx. destruct hx as [hx |hx];simpl in hx. subst x;auto. tauto. }
                 split.
                 { constructor. }
                 { unfold Stable. intros x y hx hy.
                   assert (hxy: x = y).
                   { destruct hx as [hx | hx];destruct hy as [hy | hy].
                     subst x; auto. simpl in hy;tauto. all: simpl in hx;tauto. }
                    subst x. auto. } }
               assert (h3: |I'| <= |I|).
               { eauto. }
               subst I'. simpl in h3. rewrite h2 in h3.
               auto. }

             assert (h1c: K [<=] G). auto.
             assert (h1d: K = K [i] G). eauto.

             (* G_K represents the graph obtained by removing cliq K from graph G *)
             set (G_K:= ind_at (G [\] K) G).
             assert (hg_k: Ind_subgraph G_K G).
             { subst G_K. auto. }

             assert (hG_K: Perfect G_K).
             { cut (Ind_subgraph G_K G). eauto. unfold G_K; auto. }

             assert (h3: i_num G_K (n-1)).
             { specialize (h1b I h2a) as hKI.
               destruct hKI as [k hKI].
               set (I_k:= rmv k I).
               exists I_k.
               split.
               { (*--  Max_I_in G_K I_k --*)
                 assert (h3: Stable_in G I). auto. unfold Stable_in in h3.
                 assert (h3a: Stable G I). apply h3. unfold Stable in h3a.
                 assert (h9: I_k [<=] G_K ).
                 { subst I_k; subst G_K. simpl.
                   replace ((G [\] K) [i] G) with (G [\] K).
                   Focus 2. cut (G [\] K [<=] G); auto.
                   intros x hx.
                   assert (hx1: In x I). eauto.
                   assert (hxk: x <> k).
                   { cut (NoDup I).  eauto. cut (IsOrd I). auto. apply h3. }
                   cut (In x G). cut (~ In x K). auto.
                   intro h4. absurd (x = k). auto.
                   eapply cliq_meets_stable_once with (G:= G)(K:= K)(I:= I).
                   all: auto. apply hKI. apply hKI. cut (I [<=] G ). auto.
                   apply h3. }
                 assert (h10:  (| I_k |) = n - 1).
                 { subst I_k. cut (In k I).  rewrite <- h2. eauto.
                   apply hKI. }
                 split.
                 { (*-- I_k [<=] G_K --*)
                   apply h9. }
                 split.
                 { (*--- IsOrd I_k---*)
                   subst I_k. cut (IsOrd I). auto. apply h3. }
                 split.
                 { (*--- stable G_K I_k----*)
                   apply /stableP. unfold Stable.
                   intros x y hx hy. replace (edg G_K x y) with (edg G x y).
                   apply h3a; unfold I_k in hx, hy;eauto.
                   symmetry. cut (In x G_K). cut (In y G_K). all: auto. }
                 { (*- (forall I' :list A, In I' (pw G_K)-> stable G_K I'-> (|I'|)<=(|I_k|)) -*)
                   intros I' h11 h12. move /stableP in h12.
                   assert (h13: Stable_in G I').
                   { cut (Stable_in G_K I'). eauto.
                     unfold Stable_in. split. auto. split;auto.
                     cut (IsOrd G_K). eauto. subst G_K;simpl. auto. }
                   cut ( ~ (| I' |) > (| I_k |)). omega.
                   intros h14.
                   assert (h15: (|I'|) <= n).
                   { rewrite <- h2. eauto. }
                   rewrite h10 in h14.
                   assert (h16: |I'| = n). omega.
                   assert (h17: Max_I_in G I').
                   { apply Max_I_in_intro. auto.
                     rewrite h16. rewrite <- h2. intros I0' h17. eauto. }
                   specialize (h1b I' h17) as h18. destruct h18 as [k' h18].
                   assert (h19: I' [<=] G_K).
                   { cut (IsOrd G_K). eauto. subst G_K;simpl. auto. }
                   absurd (In k' K). cut (In k' G_K).
                   subst G_K. simpl.
                   replace ((G [\] K) [i] G) with (G [\] K).
                   Focus 2. cut (G [\] K [<=] G); auto.
                   intros h20. eauto. cut (In k' I'). auto. all: apply h18. } }

               { (*--- (| I_k |) = n - 1 --*)
                  subst I_k. cut (In k I).  rewrite <- h2. eauto.
                  apply hKI.  } }

             assert (h4: n - 1 < n). omega.

             specialize (H (n-1) h4 G_K hG_K h3) as h5.
             destruct h5 as [C_K h5].

             exists (K::C_K).
             split.
             { (*--- Cliq_cover (K :: C_K) G -----*)
               unfold Cliq_cover.
               split.
               {(*---- Set_cover (K :: C_K) G ----*)
                 unfold Set_cover.
                 assert (h6: nodes G_K = G [\] K).
                 { unfold G_K. simpl. symmetry.
                   cut ((G [\] K) [<=] G). auto. auto. }
                 replace (nodes G) with (K [u] (G [\] K)).
                 Focus 2. symmetry;auto. simpl.
                 replace ((G [\] K)) with (union_over C_K).
                 Focus 2. symmetry. rewrite <- h6.   apply h5.
                 auto. }

               {(*---- (forall I0 : list A, In I0 (K :: C_K) -> Cliq G I0 /\ IsOrd I0) ---*)
                 intros Kx h6. destruct h6 as [h6 | h6].
                 { rewrite <- h6. split;auto. eauto. }
                 { assert (h5c: Cliq_cover C_K G_K). apply h5.
                   split. cut (Cliq_in G Kx). auto.
                   cut (Cliq_in G_K Kx). all: eauto. }  } }

             { (*---- (| K :: C_K |) = n ---------*)
               destruct h5 as [h5a h5].
               simpl. rewrite h5. omega. }   } } Qed.

End WPerfect.

Section WPGT.

  Context { A: ordType }.

  Lemma wpgt (G G': @UG A): Perfect G -> Compl G G'-> Perfect G'.
  Proof.
    { (* We will prove the result by well founded induction on G'.
      To use the well founded induction we first need to prove that the relation
      lt_graph is well founded on UG. This is proved as Lemma lt_graph_is_well_founded
      in the file DecUG.v. *)
      revert G. pattern G'. revert G'.
      eapply well_founded_ind with (R:= @lt_graph A).
      apply lt_graph_is_well_founded.
      unfold lt_graph. intros G' IH G h2 h.

      assert (gg': nodes G = nodes G'). apply h.

      unfold Perfect. intros H' h3.

      assert (heq: nodes H' = nodes G' \/ nodes H' <> nodes G'). eauto.

      destruct heq as [heq | neq].
      { (*--- H' = G' ---*)
        (*---- In this case the proof uses the lemma i_num_cliq_cover ----*)
        cut (Nice G').
        { cut (iso  G' H'). eauto. cut (iso H' G'). auto. auto using ind_sub_eq_iso. }

        destruct (cliq_num_of G') as [n' hn'].

        assert (h4: i_num G n').
        { (* cliq_num G' n' -> i_num G n' *)
          eapply cliq_num_i_num with (G0:= G').
          apply compl_commute;auto. auto. }
        eapply nice_intro1. exact hn'.
        specialize (i_num_cliq_cover h2 h4) as h5.
        destruct h5 as [C h5]. destruct h5 as [h5 h5a].
        exists C.
        split.
        {(* Cliq_cover C G -> Stable_cover C G' *)
          unfold Cliq_cover in h5. destruct h5 as [h5 h5b].
          unfold Stable_cover.
          split.
          { rewrite <- gg'. auto. }
          { intros I h6.
            split. eapply cliq_is_stable. exact h. unfold Cliq_in.
            split. eauto. split;apply h5b;auto. apply h5b;auto. } }
        { (*--  (| C |) = n' ---*)
          auto. }  }

      { (*----  H' <> G' ----*)
        assert (hsize: | H'| < | G'|).
        { assert (h3a: H' [<=] G'). apply h3.
          apply sub_neq_lt. all: auto. }

        set (H:= ind_at H' G).
        assert (h4: Ind_subgraph H G).
        { subst H. auto. }

        assert (h5: Perfect H).
        { eauto. }

        assert (h6: Compl H H').
        { subst H. unfold Compl.
          split.
          { simpl. symmetry; cut (H' [<=] G). auto. rewrite gg'; auto. }
          { intros x y hx hy. replace (edg (ind_at H' G) x y) with (edg G x y).
            replace (edg H' x y) with (edg G' x y).
            apply h;simpl in hx, hy. all: auto.   eauto.  eauto.
            symmetry;apply h3; simpl in hx, hy;eauto. }  }

        cut (Perfect H'). auto.
        eapply IH. exact hsize. exact h5. auto. }   } Qed.

 End WPGT.