Require Import pre2.

(* while it ought to be evident, we've neglected to state
   this fact as an object which may be referred to. *)
Remark negb_eqv : 𝟚 ≃ 𝟚.
Proof.
  exists negb; apply equiv_from_qinv; exists negb;
    split; intros [|]; trivial.
Defined.

Section Sets_and_n_Types.

  (* def_3_1_1 *)
  Definition isSet (A : UU) := ∏ (x y : A) (p q : x=y), p=q.

  (* example_3_1_2 *)
  Example unit_isSet_using_ua : isSet 𝟙.
  Proof. intros x y;
           rewrite (ua uniteq_is_unit); apply uniteq. Defined.

  (* note that the above proof uses the univalence axiom to
     do the rewrite.  Can we work around that?  Not that we
     need to, but it's an interesting challenge. *)
  Example unit_isSet : isSet 𝟙.
  Proof.
    intros x y p q.
    set (E := uniteq (uniteq_is_unit.1 p) (uniteq_is_unit.1 q)).
    set (Ladj := snd (@uniteq_is_unit x y).2 ).
    apply (inv (Ladj.2 p) ∙ ap Ladj.1 E ∙ Ladj.2 q).
  Defined.
  (* so, yes. We can use the computation/uniqueness rule of
     the eqiuvalence to reach the same end, although we have to
     plan the proof a little more deliberately rather than
     pointing at some part of the goal and saying "I want that to
     be this other thing seemingly magically." *)

  (* example_3_1_3 *)
  Example empty_isSet : isSet 𝟘.
  Proof. intros x y; apply empty_rect; exact x. Defined.

  (* example_3_1_4 *)
  Example nat_isSet : isSet ℕ.
  Proof. intro n; induction n; intro m; induction m;
           rewrite (ua (nat_eqvcoding _ _));
           try apply uniteq;
           try (intros p q; apply empty_rect; assumption);
           simpl; rewrite <- (ua (nat_eqvcoding _ _)); apply IHn.
  Defined.

  (* example_3_1_5 *)
  Example prod_isSet {A B : UU} : isSet A -> isSet B -> isSet (A×B).
  Proof.
    intros sA sB x y p q; destruct x as (xa,xb); destruct y as (ya,yb);
      rewrite <- (prodeq_uniq p); rewrite <- (prodeq_uniq q);
        apply ap2; [apply sA | apply sB].
  Defined.

  (* WARNING: skip the following, or just go to the exercises
     and do the corresponding exercise first *)
  Example sig_isSet {A : UU} {B : A -> UU}
    : isSet A -> (∏ x:A, isSet (B x)) -> isSet (total B).
  Proof.
    intros sA sB x y p q; destruct x as (xa,xb); destruct y as (ya,yb);
      rewrite <- (sigeq_uniq p); rewrite <- (sigeq_uniq q);
        set (baseeq := sA _ _ (proj1eq p) (proj1eq q));
        set (fibereq := sB ya _ _
                           ( transport (λ pp, transport _ pp _ = _)
                                       baseeq (proj2eq p) )
                           (proj2eq q)
            );
        apply (ap (siguncurry spaireq) (spaireq baseeq fibereq)).
  Defined.

  (* example_3_1_6 *)
  Example fun_isSet {A : UU} {B : A -> UU}
    : (∏ x:A, isSet (B x)) -> isSet (section B).
  Proof.
    intros sB f g p q;
      rewrite (funext_uniq q); rewrite (funext_uniq p);
        apply ap; apply funext; intro x; apply sB.
  Defined.

  (* def_3_1_7 *)
  Definition is1Type (A : UU) :=
    ∏ (x y : A) (p q : x=y) (r s : p=q), r=s.

  (* lem_3_1_8 *)
  Lemma sets_are_1types {A : UU} : isSet A -> is1Type A.
  Proof.
    intros sA x y p q r s;
      set (g := sA x y p);
      apply (cancel_whisker_l (g p));
      chain (r # (g p)) by symmetry; apply transport_eq_r.
        chain (g q) by apply apd.
        chain (s # (g p)) by symmetry; apply apd.
          apply transport_eq_r.
  Defined.

  (* example_3_1_9 *)
  Example UU_is_not_a_set : ¬ (isSet UU).
  Proof.
    intro sUU.
    set (badeq := sUU 𝟚 𝟚 (ua negb_eqv) idpath).
    set (badeq2 := happly (ap (transport idfun) badeq) false).
    rewrite ua_compute_transport in badeq2.
    simpl in badeq2.
    apply true_is_not_false; assumption.
  Qed.
End Sets_and_n_Types.

Section Propositions_as_Types_or_not.
  (* thm_3_2_2 *)
  Theorem general_double_negation_elim_not_admissable
  : ¬ ∏ A:UU, ¬¬A -> A.
  Proof.
    intro f;
      set (p := ua negb_eqv);
      set (u := (λ n, n true):¬¬𝟚);
      set (q := happly (apd f p) u);
      rewrite (transport_f (λ X, ¬¬X)) in q.
    assert (∏ u' v:¬¬𝟚, u' = v) as negProp.
    { intros u' v; apply funext; intro x; apply empty_rect. }
    assert (transport' (λ X, ¬¬X) p = idfun) as q2.
    { apply funext; intro; apply negProp. }
    rewrite q2 in q; simpl in q; unfold p in q;
      rewrite ua_compute_transport in q.
    assert (∏ x:𝟚, negb_eqv.1 x ≠ x) as noFix.
    { intros x; destruct x; simpl; intro badEq;
        [symmetry in badEq|]; apply (true_is_not_false badEq). }
    apply (noFix (f 𝟚 u) q).
  Qed.

  (* cor_3_2_7 *)
  Theorem general_LEM_not_admissable : ¬ ∏ A:UU, A + ¬A.
  Proof.
    intro g;
      apply general_double_negation_elim_not_admissable.
    intros A u;
      destruct (g A) as [a|na];
      [ assumption | apply empty_rect; apply (u na) ].
  Qed.
End Propositions_as_Types_or_not.

Section Mere_Propositions.
  (* def_3_3_1 *)
  Definition isProp (A : UU) := ∏ x y : A, x = y.

  (* note we already proved this for 𝟙 under a different name *)
  Check uniteq : isProp 𝟙.
  Definition unit_isProp : isProp 𝟙 := uniteq.

  (* lem_3_3_2 *)
  (* lem_3_3_3 *)
  Lemma prop_eqv {P Q : UU}
        (p : isProp P) (q : isProp Q)
        (f : P -> Q) (g : Q -> P)
    : P ≃ Q.
  Proof.
    exists f; apply equiv_from_qinv; exists g;
      split; intro x; try apply p; try apply q.
  Defined.
  Corollary prop_is_unit {P : UU}
            (p : isProp P) (x : P)
    : P ≃ 𝟙.
  Proof.
    exact (prop_eqv p
                    unit_isProp
                    (λ _, tt)
                    (λ _, x)).
  Defined.

  (* lem_3_3_4 *)
  Lemma props_are_sets {A : UU} : isProp A -> isSet A.
  Proof.
    intros pA x y p q;
      set (g := pA x);
      apply (cancel_whisker_l (g x));
      chain (p # (g x)) by symmetry; apply transport_eq_r.
    chain (g y) by apply apd.
    chain (q # (g x)) by symmetry; apply apd.
    apply transport_eq_r.
  Defined.

  (* lem_3_3_5 *)
  Lemma isProp_isProp {A : UU} : isProp (isProp A).
  Proof.
    intros f g.
    apply funext; intro x; apply funext; intro y.
    apply (props_are_sets f).
  Defined.
  Lemma isSet_isProp {A : UU} : isProp (isSet A).
  Proof.
    intros f g.
    apply funext; intro x; apply funext; intro y;
      apply funext; intro p; apply funext; intro q.
    apply (sets_are_1types f).
  Defined.
End Mere_Propositions.

Section Classical_vs_Intuitionistic_Logic.
  Definition LEM_Statement
    := ∏ A:UU, isProp A -> (A + ¬A).
  Definition Law_of_Double_Negation_Statement
    := ∏ A:UU, isProp A -> (¬¬A -> A).

  Definition Decidable (A : UU) := (A + ¬A)%type.
  Definition DecidableFibration {A : UU} (B : A -> UU)
    := ∏ x:A, Decidable (B x).
  Definition DecidableEq (A : UU) := ∏ a b : A, Decidable (a=b).
End Classical_vs_Intuitionistic_Logic.

Section Subsets_and_Propositional_Resizing.
  (* lem_3_5_1 *)
  Lemma subseteq {A : UU} (P : A -> UU)
        (Pprop : ∏ x:A, isProp (P x))
        (u v : total P)
  : u.1 = v.1 -> u = v.
  Proof.
    intro p.
    apply (spaireq p).
    apply (Pprop v.1).
  Defined.

  (* the following two definitions, like "PointedType" rely on
     some funny business about treating universes kind of like
     other normal types.  This is allowed, because of the type-in-type
     unsafe mode that we're working in, but is worth noting *)
  Definition USet := Σ A:UU, isSet A.
  Definition UProp := Σ A:UU, isProp A.
  (* note that because of the above Lemma, we expect the second
     half of these universe restrictions to be mere propositions,
     and hence these are simply sub-universes *)
  (* In UniMath, the above UProp definition is called hProp *)

  (* typed constructors not needed... but maybe nice *)
  Definition to_USet (A : UU) (SA : isSet A) : USet := {A;SA}.
  Definition to_UProp (A : UU) (PA : isProp A) : UProp := {A;PA}.
  (* these projection aliases are critical for below... *)
  Definition USet_to_UU : USet -> UU := @proj1 _ _ .
  Definition UProp_to_UU : UProp -> UU := @proj1 _ _ .
  Definition to_isSet (A : USet) := A.2 .
  Definition to_isProp (A : UProp) := A.2 .

  (* we don't state propositional resizing here because we're
     ignoring the issue of explicit universe management in the way
     in which we're encoding Homotopy Type Theory in Coq. *)
  (* specifically, the type-in-type flag seems to obviate this problem *)
End Subsets_and_Propositional_Resizing.

(* UniMath also cleverly defines a coercion that forgets
   the trailing classifier when needed *)
Coercion USet_to_UU : USet >-> UU.
Coercion UProp_to_UU : UProp >-> UU.

Section The_Logic_of_Mere_Propositions.
  (* example_3_6_1 *)
  Example prod_isProp (A B : UU) (PA : isProp A) (PB : isProp B)
  : isProp (A×B).
  Proof.
    intros x y; destruct x as (a,b); destruct y as (a',b');
      apply paireq; [ apply PA | apply PB ].
  Defined.

  (* example_3_6_2 *)
  Example fun_isProp {A : UU} {B : A -> UU}
          (BP : ∏ x:A, isProp (B x))
    : isProp (section B).
  Proof.
    intros f g; apply funext; intro x; apply (BP x).
  Defined.

  Remark empty_isProp : isProp 𝟘.
  Proof. intros x y; induction x. Defined.
  Corollary not_isProp {A : UU} : isProp (¬A).
  Proof. apply fun_isProp; intro; apply empty_isProp. Defined.

  Remark bool_not_isProp : ¬ isProp 𝟚.
  Proof. intro P2; exact (true_is_not_false (P2 true false)). Defined.
End The_Logic_of_Mere_Propositions.

Section Propositional_Truncation.
  (* truncation encoding is... tricky.
     The following is taken from UniMath.Foundations.Propositions
   *)
  (* the basis for it is to figure out how to encode the type
        "the type A is inhabited."
     which is the basis for one of the exercises. *)
  Definition PropTrunc (A : UU) := ∏ P:UProp, (A -> P) -> P.
  (* if we just wanted to model inhabitedness, couldn't we just say
       "If we have an element a:A, then ..."
     Maybe we could take off some of these needless arrows to P.
     For example, maybe we could say ∏ P:UProp, A -> P, which
     would mean that for any proposition, we can show the proposition
     is inhabited given an element of A.  But note that ∅ is a
     proposition.  So, it would seem that all this would just say
     that A better NOT! be inhabited.
       This suggests that the pattern places P in exactly the
     spot for defining ¬¬A = (A->∅)->∅.  And we know informally
     that ¬¬ should give an embedding of classical logic into
     constructive, dependent type theory.  So, this seems to be
     generalizing the definition of double negation to both ∅ and 𝟙.
   *)
  (* The following Lemma probably uses some funny
     type-in-type business by pushing things up into UU.
     Apparently it relies on propositional resizing, so that's not
     too surprising overall. *)
  Lemma PropTrunc_isProp (A : UU) : isProp (PropTrunc A).
  Proof.
    intros f g. apply funext; intro P; apply funext; intro AP.
    apply P.2.
  Defined.

  Definition UPropTrunc (A : UU) : UProp :=
    to_UProp (PropTrunc A) (PropTrunc_isProp A).
  Opaque UPropTrunc. (* don't go peeking in this! *)
  Notation "∥ A ∥" := (UPropTrunc A) (at level 20) : type_scope.
  (* to input : \|| *)

  Definition elemP {A : UU} : A -> ∥ A ∥
    := λ (a:A) (P:UProp) (f:A->P), f a.
  Opaque elemP.
  (* recall (λ a, λ na, na a) : A -> ¬¬A *)

  (* note that in the text, it says we need two constructors for
     ∥A∥, `elemP` as above, and `∏ x y : ∥A∥, x=y`.  But because
     we've defiend `UPropTrunc` as a UProp, which carries that proof
     along with the underlying type, we can simply get
       ∥A∥.2 : ∏ x y : ∥A∥.1, x=y
   *)

  (* again, we exploit the strange properties of our specific
     truncation encoding to get us this definitional result *)
  Definition trunc_rec {A : UU} {B : UU} (isB : isProp B) (f : A -> B)
    : ∥A∥ -> B
    := λ truncA, truncA {B;isB} f.

  (* show some more support functions for definitions below *)

  (* unfortunately, I don't quite know what the right machinery
     is to remove this cruft yet... *)
  Lemma sig_of_props {P : UU} {Q : P -> UU}
        (isP : isProp P) (isQ : ∏ p:P, isProp (Q p))
    : isProp (total Q).
  Proof.
    intros (xp,xq) (yp,yq).
    apply (spaireq (isP xp yp)).
    apply (isQ yp).
  Defined.
  Lemma eqv_isProp (P Q : UU) (isP : isProp P) (isQ : isProp Q)
    : isProp (P≃Q).
  Proof.
    set (isHP (f g : P->P) (h0 h1 : f ~ g) :=
           funext (λ x:P, props_are_sets isP (f x) (g x) (h0 x) (h1 x) )).
    set (isHQ (f g : Q->Q) (h0 h1 : f ~ g) :=
           funext (λ x:Q, props_are_sets isQ (f x) (g x) (h0 x) (h1 x) )).
    set (isPQ := fun_isProp (λ _:P, isQ) : isProp (P->Q)).
    set (isQP := fun_isProp (λ _:Q, isP) : isProp (Q->P)).
    set (isEqvProp (f:P->Q) :=
           prod_isProp _ _
                       (sig_of_props isQP (λ fR, isHQ (f ∘ fR) idfun))
                       (sig_of_props isQP (λ fL, isHP (fL ∘ f) idfun)) ).
    apply (sig_of_props isPQ isEqvProp).
  Defined.

  Corollary paths_isProp {A B : UU} (isA : isProp A) (isB : isProp B)
    : isProp (A=B).
  Proof.
    (* use a big hammer and switch it out *)
    rewrite (ua Univalence).
    apply eqv_isProp; assumption.
  Defined.

  Definition unit_to_UProp : UProp := {𝟙;unit_isProp}.
  Definition empty_to_UProp : UProp := {∅;empty_isProp}.
  Definition prod_to_UProp (A B : UProp) : UProp
    := { A × B ; prod_isProp A B A.2 B.2 }.
  Definition simple_fun_to_UProp (A : UU) (B : UProp) : UProp
    := { A -> B ; fun_isProp (λ _:A, B.2) }.
  Definition equiv_to_UProp (A B : UProp) : UProp
    := { A.1 = B.1 ; paths_isProp A.2 B.2 }.
  Definition not_to_UProp (A : UU) : UProp
    := { ¬A ; @not_isProp A }.
  Definition coprod_to_UProp (A B : UProp) : UProp
    := ∥ A.1 + B.1 ∥%type.
  Definition pi_to_UProp (A : UU) (B : A -> UProp) : UProp
    := { ∏ a:A, (B a).1 ; fun_isProp (proj2∘B) }.
  Definition sig_to_UProp (A : UU) (B : A -> UProp) : UProp
    := ∥ Σ a:A, (B a).1 ∥ .

End Propositional_Truncation.

Notation "∥ A ∥" := (UPropTrunc A) (at level 20) : type_scope.
(* to input : \|| *)

Notation "A <-> B" := ((A -> B) × (B -> A)) : type_scope.

(* notational conventions for logic... *)
Notation "⊤" := (unit_to_UProp) : logic_scope.
(* input: \top *)
Notation "⊥" := (empty_to_UProp) : logic_scope.
Notation "P /\ Q" := (prod_to_UProp P Q) : logic_scope.
Notation "P => Q" := (simple_fun_to_UProp P Q)
                       (at level 99, Q at level 200, right associativity)
                     : logic_scope.
Notation "P <=> Q" := (equiv_to_UProp P Q)
                        (at level 95) : logic_scope.
(* overloaded in logic_scope *)
Notation "'¬' X" := (not_to_UProp X) (at level 75, right associativity)
                    : logic_scope.
Notation "P \/ Q" := (coprod_to_UProp P Q) : logic_scope.
Notation "'∀' x .. y , P" :=
  (pi_to_UProp _ (fun x => .. (pi_to_UProp _ (fun y => P)) ..))
    (at level 200, x binder, y binder, right associativity) : logic_scope.
Notation "'∃' x .. y , P" :=
  (sig_to_UProp _ (fun x => .. (sig_to_UProp _ (fun y => P)) ..))
    (at level 200, x binder, y binder, right associativity) : logic_scope.

Delimit Scope logic_scope with logic.

Section The_Axiom_of_Choice.
  (* def_3_8_1 *)
  Definition Axiom_of_Choice_statement
    := ∏ (X : UU) (A : X -> UU) (P : ∏ x:X, A x -> UU)
         (isX : isSet X) (isA : ∏ x:X, isSet (A x))
         (isP : ∏ (x:X) (a:A x), isProp (P x a)),
       ( ∏ x:X, ∥ Σ a : A x, P x a ∥ ) ->
       ∥ Σ (g : ∏ x:X, A x), ∏ (x:X), P x (g x) ∥ .

  Remark Axiom_of_Choice_isProp
    : isProp Axiom_of_Choice_statement.
  Proof.
    (* this follows trivially from fun_isProp, but we
       have to crunch through the proof a bit to get that result *)
    unfold Axiom_of_Choice_statement.
    apply fun_isProp; intro X;
      apply fun_isProp; intro A;
        apply fun_isProp; intro P;
          do 4 (apply fun_isProp; intro).
    apply (∥ Σ (g : ∏ x:X, A x), ∏ (x:X), P x (g x) ∥.2).
  Qed.

  Definition Fam_of_Sets_Axiom_statement
    := ∏ (X : UU) (Y : X -> UU)
         (isX : isSet X) (isY : ∏ x:X, isSet (Y x)),
       (∏ x:X, ∥ Y x ∥) -> ∥ ∏ x:X, Y x ∥ .

  Remark Fam_of_Sets_Axiom_isProp
    : isProp Fam_of_Sets_Axiom_statement.
  Proof.
    unfold Fam_of_Sets_Axiom_statement.
    apply fun_isProp; intro X;
      apply fun_isProp; intro Y;
        do 3 (apply fun_isProp; intro).
    apply (∥ ∏ x : X, Y x ∥.2).
  Qed.

  Definition trunc_fun {A B : UU} (f : A -> B) : ∥ A ∥ -> ∥ B ∥
    := trunc_rec (∥B∥).2 (λ a:A, (elemP (f a))).

  (* lem_3_8_2 *)
  Lemma AC_equivalent_to_Fam_of_Sets
    : Axiom_of_Choice_statement ≃ Fam_of_Sets_Axiom_statement.
  Proof.
    apply (prop_eqv Axiom_of_Choice_isProp Fam_of_Sets_Axiom_isProp);
      unfold Axiom_of_Choice_statement, Fam_of_Sets_Axiom_statement.
    - intros AC X Y isX isY Hfam.
      apply (@trunc_fun (Σ _:(∏ x:X, Y x), X->𝟙)).
      (* discharge trunc_fun *) intro g; apply g.1.
      apply (AC X Y (λ _ _, 𝟙) isX isY (λ _ _, unit_isProp)).
      intro x.
      apply (trunc_fun (λ y:Y x, {y;tt}) (Hfam x)).
    - intros FAM X A P isX isA isP Hac.
      apply (trunc_fun univ_sig).
      set (Y x := total (P x)).
      set (isY x := sig_isSet (isA x) (λ a, props_are_sets (isP x a))).
      apply (FAM X Y isX isY Hac).
  Qed.

  (* remark_3_8_4 *)
  (* this is true without any axioms *)
  Remark inv_Fam_of_Sets {X : UU} {Y : X -> UU}
         (isX : isSet X) (isY : ∏ x:X, isSet (Y x))
    : ∥ ∏ x:X, Y x ∥ -> ∏ x:X, ∥ Y x ∥ .
  Proof.
    intros exFam x.
    apply (trunc_fun (λ f, f x) exFam).
  Qed.

  Remark bool_isSet : isSet 𝟚.
  Proof.
    refine (ua bool_is_unit_plus_unit #' _);
    intros x y; destruct x as [()|()];
      [ rewrite (ua (coprod_l_eqvcoding tt y))
      | rewrite (ua (coprod_r_eqvcoding tt y))
      ]; destruct y as [()|()]; simpl;
        [ apply unit_isSet | apply empty_isProp
          | apply empty_isProp | apply unit_isSet ].
  Qed.

  Remark equiv_isSet {A B : UU} (isA : isSet A) (isB : isSet B)
    : isSet (A≃B).
  Proof.
    apply (sig_isSet (fun_isSet (λ a, isB)));
      intro f; apply prod_isSet;
        apply (sig_isSet (fun_isSet (λ b, isA)));
        intro g; apply fun_isSet; intro x; unfold isSet;
          [ apply (sets_are_1types isB)
          | apply (sets_are_1types isA) ].
  Qed.
  Corollary paths_isSet {A B : UU} (isA : isSet A) (isB : isSet B)
    : isSet (A=B).
  Proof. rewrite (ua Univalence); apply equiv_isSet; assumption. Qed.

  (* lem_3_8_5 *)
  (* impossibility of relaxing part of the Axiom of Choice *)
  (* I am misunderstanding some machinery at my disposal...? *)
  Lemma Fam_of_Sets_must_be_set_indexed
    : Σ (X : UU) (Y : X -> UU) (isY : ∏ x:X, isSet (Y x)),
      ¬( (∏ x:X, ∥ Y x ∥) -> ∥ ∏ x:X, Y x ∥ ).
  Proof.
    set (P (A:UU) := ∥ 𝟚 = A ∥.1).
    set (PisProp (A:UU) := ∥ 𝟚 = A ∥.2); simpl in PisProp.
    set (X := Σ A:UU, ∥ 𝟚 = A ∥); exists X.
    set (p2 := elemP (idpath 𝟚)).
    set (x0 := { 𝟚 ; p2 } : X).
    assert (¬(isSet X)) as X_is_not_a_set.
    { (* well, assume X is... *) intro isX.
      set (negb_path :=
             spaireq (P:=P) (ua negb_eqv)
                     (PisProp 𝟚 (ua negb_eqv # p2) p2) : x0 = x0).
      set (badeq := ap (ap proj1) (isX x0 x0 negb_path idpath));
        change (ap proj1 negb_path) with (proj1eq negb_path) in badeq;
        simpl in badeq; unfold negb_path in badeq;
          rewrite sigeq_compute1 in badeq.
      set (badeq2 := happly (ap (transport idfun) badeq) false).
      rewrite ua_compute_transport in badeq2; simpl in badeq2.
      apply (true_is_not_false badeq2).
    }
    assert (is1Type X) as X_is1Type.
    { intros (A0,p0) (A1,p1).
      set (A_isSet (A:UU) (p : ∥ 𝟚 = A ∥) :=
             trunc_rec isSet_isProp (λ eq, eq # bool_isSet) p).
      set (eq_A12 := paths_isSet (A_isSet A0 p0) (A_isSet A1 p1)).

      assert (({A0;p0}={A1;p1} :> X) ≃ (A0=A1)) as exchange.
      {
        exists proj1eq; apply equiv_from_qinv.
        exists (subseteq P PisProp {A0;p0} {A1;p1}).
        unfold funcomp, subseteq; split; intro xeq.
        - apply sigeq_compute1.
        - chain (spaireq (proj1eq xeq) (proj2eq xeq)).
          + apply ap;
            set (A1set := props_are_sets (∥ 𝟚 = A1 ∥).2);
            apply A1set.
          + apply sigeq_uniq.
      }
      rewrite (ua exchange).
      apply eq_A12.
    }

    (* now we define Y finally... *)
    set (Y x := x0 = x).
    set (YisSet x := X_is1Type x0 x : isSet (Y x)).
    exists Y.
    exists YisSet.
    set (all_x_eq_x0 (x:X) :=
           trunc_fun (λ p:𝟚=x.1, subseteq P PisProp x0 x p) x.2).
    intro badHyp.
    refine (trunc_rec empty_isProp _ (badHyp all_x_eq_x0)).
    unfold Y; intro allX0.
    set (XisProp (x y : X) := inv (allX0 x) ∙ allX0 y).
    set (XisSet := props_are_sets XisProp).
    contradiction.
  Qed.
End The_Axiom_of_Choice.

Section The_Principle_of_Unique_Choice.
  (* lem_3_9_1 *)
  Lemma propeqv_trunc {P : UU} (isP : isProp P) : P ≃ ∥P∥.
  Proof.
    apply (prop_eqv isP (∥P∥.2) elemP (trunc_rec isP idfun)).
  Defined.

  (* cor_3_9_2 *)
  Corollary unique_choice {A : UU} {P : A -> UU}
            (isP : ∏ x:A, isProp (P x))
            (inP : ∏ x:A, ∥ P x ∥)
    : ∏ x:A, P x.
  Proof. intro x; apply (propeqv_trunc (isP x)); apply inP. Defined.
End The_Principle_of_Unique_Choice.

Section When_are_Propositions_Truncated.
  (* This section is purely exposition in the book *)
End When_are_Propositions_Truncated.

Section Contractibility.
  (* def_3_11_1 *)
  Definition isContr (A : UU) := Σ (a:A), ∏ (x:A), (a = x).

  (* lem_3_11_3 *)
  Lemma isContr_then_inhabited (A : UU)
    : isContr A -> A.
  Proof. exact (λ c, c.1). Defined.
  Lemma isContr_then_isProp (A : UU)
    : isContr A -> isProp A.
  Proof. exact (λ c, λ x y, inv (c.2 x) ∙ (c.2 y)). Defined.
  Lemma isProp_and_inhabited_then_isContr (A : UU)
    : A -> isProp A -> isContr A.
  Proof. exact (λ a isP, { a ; isP a }). Defined.

  Lemma isProp_and_inhabited_then_eqv_unit (A : UU)
    : A -> isProp A -> A ≃ 𝟙.
  Proof. exact (λ a isP, prop_is_unit isP a). Defined.
  Lemma eqv_unit_then_inhabited (A : UU)
    : A ≃ 𝟙 -> A.
  Proof. exact (λ e, (einv e) tt). Defined.
  Lemma eqv_unit_then_isProp (A : UU)
    : A ≃ 𝟙 -> isProp A.
  Proof. exact (λ e, (ua e) #' unit_isProp). Defined.

  (* lem_3_11_4 *)
  Lemma isContr_isProp (A : UU) : isProp (isContr A).
  Proof.
    intros (a,p) (a',p');
      set (q := p a'); apply (spaireq q);
        set(AisProp := isContr_then_isProp A {a;p}).
    set (paths_props := (fun_isProp (λ x, props_are_sets AisProp a' x)));
      apply paths_props.
  Qed.

  (* cor_3_11_5 *)
  Corollary isContr_isContr {A : UU} : (isContr A) -> isContr (isContr A).
  Proof.
    intros isC;
      apply (isProp_and_inhabited_then_isContr (isContr A)
                                               isC
                                               (isContr_isProp A)).
  Qed.

  (* lem_3_11_6 *)
  Lemma fun_isContr {A : UU} {P : A -> UU}
        (isP : ∏ x:A, isContr (P x))
    : isContr (∏ x:A, P x).
  Proof.
    apply (isProp_and_inhabited_then_isContr (section P)
                                             (λ x, (isP x).1));
      apply fun_isProp; intro x; apply isContr_then_isProp; apply isP.
  Qed.

  Definition isRetract {A B : UU} (r : A->B)
    := Σ (s:B->A), (r ∘ s) ~ idfun .
  Definition Retract (B : UU) (A : UU) := Σ r:A->B, isRetract r.

  (* lem_3_11_7 *)
  Lemma Retract_isContr {A B : UU} (R : Retract B A) (isA : isContr A)
    : isContr B.
  Proof.
    destruct R as (r,(s,ε)); destruct isA as (a,Afam).
    set (b0 := r a); exists b0.
    intros b; apply (ap r (Afam (s b)) ∙ (ε b)).
  Defined.

  (* lem_3_11_8 *)
  Lemma based_paths_isContr (A : UU) (a : A)
    : isContr ( Σ x:A, a=x ).
  Proof.
    set (center := { a ; idpath }); exists center.
    intros (x,p).
    apply (spaireq p).
    apply transport_eq_r.
  Defined.

  (* lem_3_11_9 *)
  Lemma contr_sigfiber {A : UU} {P : A -> UU}
        (isC : ∏ x:A, isContr (P x))
    : (Σ x:A, P x) ≃ A.
  Proof.
    exists proj1; apply equiv_from_qinv;
      exists (λ a:A, { a ; (isC a).1 }).
    unfold funcomp; split; intro x; trivial.
    apply (spaireq idpath); simpl.
    apply (isC x.1).2 .
  Defined.
  (* the following part of the book's Lemma is in the exercises *)
  (*
  Lemma contr_sigbase {A : UU} {P : A -> UU}
        (isC : isContr A)
    : (Σ x:A, P x) ≃ P isC.1 .
   *)

  (* lem_3_11_10 *)
  Lemma prop_paths_isContr {A : UU}
    : (isProp A) ≃ ∏ x y : A, isContr(x=y).
  Proof.
    apply (prop_eqv isProp_isProp
                    (fun_isProp
                       (λ x, fun_isProp
                               (λ y, isContr_isProp (x=y))
          ))); unfold section.
    - intros isA x y; refine { isA x y ; (λ p, _) };
        apply (props_are_sets isA).
    - intros isC x y; exact (isC x y).1.
  Defined.
End Contractibility.


Require Import Lists.List Sorted Bool.

Module Type OrdType.

  Parameter t : Type.
  Parameter le : t -> t -> Prop.
  Parameter lt : t -> t -> Prop.
  Parameter leb : t -> t -> bool.
  Parameter ltb : t -> t -> bool.

  Parameter eq_dec : forall (x y:t), {x = y} + {x <> y}.

  Parameter le_refl : forall x, le x x.
  Parameter le_antisym : forall x y, le x y -> le y x -> x = y.
  Parameter le_trans : forall x y z, le x y -> le y z -> le x z.

  Parameter lt_norefl : forall x, ~ lt x x.
  Parameter lt_antisym : forall x y, lt x y -> lt y x -> False.
  Parameter lt_trans : forall x y z, lt x y -> lt y z -> lt x z.

  Parameter not_le_to_lt : forall x y, ~ le x y -> lt y x.
  Parameter not_lt_to_le : forall x y, ~ lt x y -> le y x.

  Parameter leb_le : forall x y, leb x y = true <-> le x y.
  Parameter le_lteq : forall x y, le x y <-> lt x y \/ x = y.

  Parameter leb_false_not_le : forall x y, leb x y = false <-> ~ le x y.
  (*
  Proof.
    intuition.
    * assert (leb x y = true). apply leb_le. exact H0. rewrite H1 in H. discriminate H.
    * destruct (leb x y) eqn:e; intuition. contradiction H. apply leb_le. exact e.
  Qed.
  *)

  Parameter linearity : forall x y, x = y \/ lt x y \/ lt y x.

End OrdType.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Ch13_1.

Section playfair_midpoints.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma playfair_s_postulate_implies_midpoint_converse_postulate :
  playfair_s_postulate ->
  midpoint_converse_postulate.
Proof.
intros HP A; intros.
destruct (midpoint_existence A C) as [X HAC].
assert (X = Q).
 assert (Par_strict A B X P).
  apply triangle_mid_par with C; assumption.
 assert_diffs.
 assert_cols.
 apply l6_21 with A C P Q.
  intro.
  assert (Col A B C) by ColR.
  contradiction.
  auto.
  Col.
  Col.
  destruct (HP A B Q P X P P) as [HCol1 HCol2]; Col; apply par_strict_par; Par.
  Col.
treat_equalities; assumption.
Qed.

End playfair_midpoints.


(* generated by Ott 0.31, locally-nameless from: stlc.ott *)
Require Import Bool.
Require Import Metalib.Metatheory.
Require Import List.
Require Import Ott.ott_list_core.
(** syntax *)
Definition tvar : Set := var. (*r term variable *)
Definition Tvar : Set := var. (*r type variable *)

Inductive type : Set :=  (*r type *)
 | type_int : type (*r int *)
 | type_top : type (*r top *)
 | type_arrow (A:type) (B:type) (*r function *).

Inductive term : Set :=  (*r term *)
 | term_int : term (*r int *)
 | term_var_b (_:nat) (*r variable *)
 | term_var_f (x:tvar) (*r variable *)
 | term_abs (e:term) (*r abstraction *)
 | term_app (e1:term) (e2:term) (*r application *)
 | term_annotation (e:term) (A:type) (*r type annotation *).

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_term_wrt_term_rec (k:nat) (e_5:term) (e__6:term) {struct e__6}: term :=
  match e__6 with
  | term_int => term_int
  | (term_var_b nat) => if (k === nat) then e_5 else (term_var_b nat)
  | (term_var_f x) => term_var_f x
  | (term_abs e) => term_abs (open_term_wrt_term_rec (S k) e_5 e)
  | (term_app e1 e2) => term_app (open_term_wrt_term_rec k e_5 e1) (open_term_wrt_term_rec k e_5 e2)
  | (term_annotation e A) => term_annotation (open_term_wrt_term_rec k e_5 e) A
end.

Definition open_term_wrt_term e_5 e__6 := open_term_wrt_term_rec 0 e__6 e_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_term *)
Inductive lc_term : term -> Prop :=    (* defn lc_term *)
 | lc_term_int :
     (lc_term term_int)
 | lc_term_var_f : forall (x:tvar),
     (lc_term (term_var_f x))
 | lc_term_abs : forall (L:vars) (e:term),
      ( forall x , x \notin  L  -> lc_term  ( open_term_wrt_term e (term_var_f x) )  )  ->
     (lc_term (term_abs e))
 | lc_term_app : forall (e1 e2:term),
     (lc_term e1) ->
     (lc_term e2) ->
     (lc_term (term_app e1 e2))
 | lc_term_annotation : forall (e:term) (A:type),
     (lc_term e) ->
     (lc_term (term_annotation e A)).
(** free variables *)
(** substitutions *)

(** definitions *)

(* defns subtyping *)
Inductive sub : type -> type -> Prop :=    (* defn sub *)
 | sub_S_Int :
     sub type_int type_int
 | sub_S_Top : forall (A:type),
     sub A type_top
 | sub_S_Arrow : forall (A B C D:type),
     sub C A ->
     sub B D ->
     sub (type_arrow A B) (type_arrow C D).

(** infrastructure *)
Hint Constructors sub lc_term : core.

Theorem sub_transitivity:
  forall t2 t1 t3, sub t1 t2 -> sub t2 t3 -> sub t1 t3.
Proof.
  induction t2; intros.
  - induction t1; eauto.
    inversion H.
    inversion H.
  - induction t1; auto.
    inversion H0.
    constructor.
    induction t3.
    inversion H0.
    constructor.
    inversion H0.
  - generalize dependent t1.
    generalize dependent t3.
    induction t1; intros.
    + inversion H.
    + inversion H.
    + induction t3; subst.
      * inversion H0.
      * constructor.
      * inversion H0; subst.
        inversion H; subst.
        constructor.
        apply IHt2_1 with (t1:=t3_1) (t3:=t1_1) in H4.
        assumption.
        assumption.
        apply IHt2_2 with (t1:=t1_2) (t3:=t3_2) in H8.
        assumption.
        assumption.
Qed.


Require Import init.

Require Export topology_base.
Require Export topology_subspace.
Require Export topology_closure.
Require Export topology_limit.

Definition separation {U} `{Topology U} A B :=
    A ≠ ∅ ∧ B ≠ ∅ ∧ open A ∧ open B ∧ disjoint A B ∧ A ∪ B = all.
Definition sub_separation {U} `{Topology U} X A B :=
    A ≠ ∅ ∧ B ≠ ∅ ∧ disjoint A B ∧ A ∪ B = X ∧
    (∀ x, limit_point A x → ¬B x) ∧ (∀ x, limit_point B x → ¬A x).

Definition connected U `{Topology U} := ∀ A B, ¬separation A B.

(* begin hide *)
Section Connected.

Context {U} `{Topology U}.
(* end hide *)
Theorem separation_comm : ∀ A B, separation A B ↔ separation B A.
Proof.
    intros A B.
    split.
    -   intros [A_empty [B_empty [A_open [B_open [AB_dis AB_all]]]]].
        unfold disjoint in AB_dis.
        rewrite inter_comm in AB_dis.
        rewrite union_comm in AB_all.
        repeat split; assumption.
    -   intros [B_empty [A_empty [B_open [A_open [AB_dis AB_all]]]]].
        unfold disjoint in AB_dis.
        rewrite inter_comm in AB_dis.
        rewrite union_comm in AB_all.
        repeat split; assumption.
Qed.

Theorem connected_clopen : connected U ↔ (∀ S, clopen S → S = all ∨ S = ∅).
Proof.
    split.
    -   intros connect S [S_open S_closed].
        classic_contradiction contr.
        rewrite not_or in contr.
        destruct contr as [S_all S_empty].
        unfold connected in connect.
        apply (connect S (𝐂 S)).
        repeat split.
        +   exact S_empty.
        +   apply empty_neq.
            apply all_neq in S_all.
            exact S_all.
        +   exact S_open.
        +   exact S_closed.
        +   apply empty_eq.
            intros x [Sx nSx].
            contradiction.
        +   apply (antisym (op := subset)).
            *   apply all_sub.
            *   intros x C0; clear C0.
                classic_case (S x) as [Sx|nSx].
                --  left; exact Sx.
                --  right; exact nSx.
    -   intros all_clopen.
        intros A B [A_nempty [B_nempty [A_open [B_open [AB_dis AB_all]]]]].
        assert (A = 𝐂 B) as A_eq.
        {
            apply (antisym (op := subset)).
            -   intros x Ax Bx.
                assert ((A ∩ B) x) as x_in by (split; assumption).
                unfold disjoint in AB_dis.
                rewrite AB_dis in x_in.
                exact x_in.
            -   intros x nBx.
                assert (all x) as x_in by exact true.
                rewrite <- AB_all in x_in.
                destruct x_in as [Ax|Bx].
                +   exact Ax.
                +   contradiction.
        }
        assert (clopen A) as A_clopen.
        {
            split; try exact A_open.
            rewrite A_eq.
            apply open_complement_closed.
            exact B_open.
        }
        assert (clopen B) as B_clopen.
        {
            split; try exact B_open.
            unfold closed.
            rewrite <- A_eq.
            exact A_open.
        }
        pose proof (all_clopen _ A_clopen) as [A_all|A_empty].
        1: pose proof (all_clopen _ B_clopen) as [B_all|B_empty].
        +   subst.
            rewrite compl_all in A_nempty.
            contradiction.
        +   contradiction.
        +   contradiction.
Qed.
Existing Instance subspace_topology.

Theorem sub_connected1 : ∀ (X : U → Prop) (A B : U → Prop),
    sub_separation X A B → separation (to_set_type X A) (to_set_type X B).
Proof.
    -   intros X A B [A_empty [B_empty [AB_dis [AB_X [A_lim B_lim]]]]].
        assert (closure A ∩ B = ∅) as cAB_empty.
        {
            apply empty_eq.
            intros x [Ax Bx].
            rewrite closure_limit_points in Ax.
            destruct Ax as [Ax|lim].
            -   unfold disjoint in AB_dis.
                assert ((A ∩ B) x) as x_in by (split; assumption).
                rewrite AB_dis in x_in.
                exact x_in.
            -   exact (A_lim _ lim Bx).
        }
        assert (A ∩ closure B = ∅) as AcB_empty.
        {
            apply empty_eq.
            intros x [Ax Bx].
            rewrite closure_limit_points in Bx.
            destruct Bx as [Bx|lim].
            -   unfold disjoint in AB_dis.
                assert ((A ∩ B) x) as x_in by (split; assumption).
                rewrite AB_dis in x_in.
                exact x_in.
            -   exact (B_lim _ lim Ax).
        }
        assert (closure A ∩ X = A) as A_eq.
        {
            rewrite <- AB_X.
            rewrite inter_ldist.
            rewrite cAB_empty.
            rewrite union_rid.
            apply rsub_inter_equal.
            apply closure_sub.
        }
        assert (closure B ∩ X = B) as B_eq.
        {
            rewrite <- AB_X.
            rewrite inter_ldist.
            rewrite inter_comm in AcB_empty.
            rewrite AcB_empty.
            rewrite union_lid.
            apply rsub_inter_equal.
            apply closure_sub.
        }
        pose proof (union_lsub A B) as AX.
        pose proof (union_rsub A B) as BX.
        rewrite AB_X in AX, BX.
        assert (closed (to_set_type X A)) as A'_closed.
        {
            rewrite <- A_eq.
            rewrite <- to_set_type_inter.
            rewrite <- (subspace_closure _ _ AX).
            apply closure_closed.
        }
        assert (closed (to_set_type X B)) as B'_closed.
        {
            rewrite <- B_eq.
            rewrite <- to_set_type_inter.
            rewrite <- (subspace_closure _ _ BX).
            apply closure_closed.
        }
        assert (to_set_type X A = 𝐂 (to_set_type X B)) as A'_eq.
        {
            apply (antisym (op := subset)).
            -   intros x Ax Bx.
                unfold disjoint in AB_dis.
                assert ((A ∩ B) [x|]) as x_in by (split; assumption).
                rewrite AB_dis in x_in.
                exact x_in.
            -   intros [x Xx] nBx.
                pose proof Xx as Xx2.
                rewrite <- AB_X in Xx2.
                destruct Xx2 as [Ax|Bx].
                +   exact Ax.
                +   contradiction.
        }
        assert ((to_set_type X B) = 𝐂 (to_set_type X A)) as B'_eq.
        {
            rewrite A'_eq.
            rewrite compl_compl.
            reflexivity.
        }
        repeat split.
        +   apply empty_neq.
            apply empty_neq in A_empty.
            destruct A_empty as [x Ax].
            exists [x|AX x Ax].
            exact Ax.
        +   apply empty_neq.
            apply empty_neq in B_empty.
            destruct B_empty as [x Bx].
            exists [x|BX x Bx].
            exact Bx.
        +   rewrite A'_eq.
            exact B'_closed.
        +   rewrite B'_eq.
            exact A'_closed.
        +   rewrite A'_eq.
            apply empty_eq.
            intros x [nBx Bx]; contradiction.
        +   rewrite B'_eq.
            apply union_compl_all.
Qed.

Theorem sub_connected2 : ∀ (X : U → Prop) (A B : set_type X → Prop),
    separation A B → sub_separation X (from_set_type A) (from_set_type B).
Proof.
    intros X A B [A_empty [B_empty [A_open [B_open [AB_dis AB_all]]]]].
    assert (A = 𝐂 B) as A_eq.
    {
        apply antisym.
        -   intros x Ax Bx.
            unfold disjoint in AB_dis.
            assert ((A ∩ B) x) as x_in by (split; assumption).
            rewrite AB_dis in x_in.
            exact x_in.
        -   intros x nBx.
            assert (all x) as x_in by exact true.
            rewrite <- AB_all in x_in.
            destruct x_in as [Ax|Bx].
            +   exact Ax.
            +   contradiction.
    }
    assert (B = 𝐂 A) as B_eq.
    {
        rewrite A_eq.
        rewrite compl_compl.
        reflexivity.
    }
    assert (closed A) as A_closed.
    {
        unfold closed.
        rewrite <- B_eq.
        exact B_open.
    }
    assert (closed B) as B_closed.
    {
        unfold closed.
        rewrite <- A_eq.
        exact A_open.
    }
    unfold disjoint in AB_dis.
    repeat split.
    -   apply empty_neq.
        apply empty_neq in A_empty.
        destruct A_empty as [x Ax].
        exists [x|].
        split with [|x].
        rewrite set_type_simpl.
        exact Ax.
    -   apply empty_neq.
        apply empty_neq in B_empty.
        destruct B_empty as [x Bx].
        exists [x|].
        split with [|x].
        rewrite set_type_simpl.
        exact Bx.
    -   apply empty_eq.
        intros x [[Xx1 Ax] [Xx2 Bx]].
        rewrite (proof_irrelevance Xx1 Xx2) in Ax.
        assert (∅ [x|Xx2]) as x_in.
        {
            rewrite <- AB_dis.
            split; assumption.
        }
        exact x_in.
    -   rewrite from_set_type_union; trivial.
    -   assert (from_set_type A ⊆ X) as sub.
        {
            intros x [Xx Ax].
            exact Xx.
        }
        pose proof (subspace_closure X (from_set_type A) sub) as eq.
        rewrite to_from_set_type in eq.
        assert (closure A ∩ B = ∅) as AB_eq.
        {
            rewrite <- (closure_eq_if_closed _ A_closed).
            exact AB_dis.
        }
        intros x x_lim [Xx Bx].
        assert ((closure A ∩ B) [x|Xx]) as x_in.
        {
            split; try exact Bx.
            rewrite closure_limit_points.
            right.
            rewrite <- (to_from_set_type X A).
            apply subspace_limit_point.
            -   exact sub.
            -   rewrite set_value_simpl.
                exact x_lim.
        }
        rewrite AB_eq in x_in.
        contradiction x_in.
    -   assert (from_set_type B ⊆ X) as sub.
        {
            intros x [Xx Bx].
            exact Xx.
        }
        pose proof (subspace_closure X (from_set_type B) sub) as eq.
        rewrite to_from_set_type in eq.
        assert (A ∩ closure B = ∅) as AB_eq.
        {
            rewrite <- (closure_eq_if_closed _ B_closed).
            exact AB_dis.
        }
        intros x x_lim [Xx Ax].
        assert ((A ∩ closure B) [x|Xx]) as x_in.
        {
            split; try exact Ax.
            rewrite closure_limit_points.
            right.
            rewrite <- (to_from_set_type X B).
            apply subspace_limit_point.
            -   exact sub.
            -   rewrite set_value_simpl.
                exact x_lim.
        }
        rewrite AB_eq in x_in.
        contradiction x_in.
Qed.

Theorem sub_connected :
    ∀ X, connected (set_type X) ↔ (∀ A B, ¬sub_separation X A B).
Proof.
    intros X.
    split.
    -   intros con A B AB_sep.
        apply sub_connected1 in AB_sep.
        exact (con _ _ AB_sep).
    -   intros con A B AB_sep.
        apply sub_connected2 in AB_sep.
        exact (con _ _ AB_sep).
Qed.

Theorem connected_sub_separation :
    ∀ A B X, separation A B → connected (set_type X) → X ⊆ A ∨ X ⊆ B.
Proof.
    intros A B X [A_empty [B_empty [A_open [B_open [AB_dis AB_all]]]]] X_con.
    specialize (X_con (to_set_type X A) (to_set_type X B)).
    unfold separation in X_con.
    repeat rewrite not_and in X_con.
    do 2 rewrite not_not in X_con.
    destruct X_con
        as [A'_empty|[B'_empty|[A'_open|[B'_open|[AB'_disjoint|AB'_all]]]]].
    -   right.
        intros x Xx.
        assert (all x) as ABx by exact true.
        rewrite <- AB_all in ABx.
        destruct ABx as [Ax|Bx].
        +   assert (to_set_type X A [x|Xx]) as x_in by exact Ax.
            rewrite A'_empty in x_in.
            contradiction x_in.
        +   exact Bx.
    -   left.
        intros x Xx.
        assert (all x) as ABx by exact true.
        rewrite <- AB_all in ABx.
        destruct ABx as [Ax|Bx].
        +   exact Ax.
        +   assert (to_set_type X B [x|Xx]) as x_in by exact Bx.
            rewrite B'_empty in x_in.
            contradiction x_in.
    -   pose proof (subspace_open X A A_open).
        contradiction.
    -   pose proof (subspace_open X B B_open).
        contradiction.
    -   apply empty_neq in AB'_disjoint.
        destruct AB'_disjoint as [[x Xx] [Ax Bx]].
        assert ((A ∩ B) x) as x_in by (split; assumption).
        unfold disjoint in AB_dis.
        rewrite AB_dis in x_in.
        contradiction x_in.
    -   apply all_neq in AB'_all.
        destruct AB'_all as [[x Xx] ABx].
        unfold union in ABx.
        rewrite not_or in ABx.
        destruct ABx as [Ax Bx].
        assert (all x) as x_in by exact true.
        rewrite <- AB_all in x_in.
        destruct x_in; contradiction.
Qed.

Theorem to_set_type_connected : ∀ A B, A ⊆ B →
    connected (set_type A) → connected (set_type (to_set_type B A)).
Proof.
    intros A B sub A_con C D
        [C_empty [D_empty [C_open [D_open [CD_dis CD_all]]]]].
    apply (A_con (to_set_type A (from_set_type (from_set_type C)))
                 (to_set_type A (from_set_type (from_set_type D)))).
    repeat split.
    -   apply empty_neq.
        apply empty_neq in C_empty.
        destruct C_empty as [x Cx].
        destruct x as [x Ax]; cbn in *.
        destruct x as [x Bx]; cbn in *.
        unfold to_set_type in Ax.
        exists [_|Ax].
        split with Bx.
        split with Ax.
        exact Cx.
    -   apply empty_neq.
        apply empty_neq in D_empty.
        destruct D_empty as [x Dx].
        destruct x as [x Ax]; cbn in *.
        destruct x as [x Bx]; cbn in *.
        unfold to_set_type in Ax.
        exists [_|Ax].
        split with Bx.
        split with Ax.
        exact Dx.
    -   destruct C_open as [C' [C'_open C_eq]].
        destruct C'_open as [C'' [C''_open C'_eq]].
        exists C''.
        split; try exact C''_open.
        rewrite C_eq.
        rewrite C'_eq.
        apply antisym.
        +   intros x [Bx [Ax Cx]].
            exact Cx.
        +   intros [x Ax] Cx.
            unfold to_set_type at 1.
            split with (sub _ Ax).
            assert (to_set_type B A [_|sub _ Ax]) as Ax' by exact Ax.
            split with Ax'.
            trivial.
    -   destruct D_open as [D' [D'_open D_eq]].
        destruct D'_open as [D'' [D''_open D'_eq]].
        exists D''.
        split; try exact D''_open.
        rewrite D_eq.
        rewrite D'_eq.
        apply antisym.
        +   intros x [Bx [Ax Dx]].
            exact Dx.
        +   intros [x Ax] Dx.
            unfold to_set_type at 1.
            split with (sub _ Ax).
            assert (to_set_type B A [_|sub _ Ax]) as Ax' by exact Ax.
            split with Ax'.
            trivial.
    -   apply empty_eq.
        intros [x Ax] [Cx Dx].
        unfold disjoint in CD_dis.
        assert (to_set_type B A [x|sub x Ax]) as Ax' by exact Ax.
        assert ((C ∩ D) [_|Ax']) as x_in.
        {
            split.
            -   destruct Cx as [Bx [Ax'' Cx]]; cbn in *.
                rewrite (proof_irrelevance _ Bx).
                rewrite (proof_irrelevance _ Ax'').
                exact Cx.
            -   destruct Dx as [Bx [Ax'' Dx]]; cbn in *.
                rewrite (proof_irrelevance _ Bx).
                rewrite (proof_irrelevance _ Ax'').
                exact Dx.
        }
        rewrite CD_dis in x_in.
        exact x_in.
    -   apply antisym; try apply all_sub.
        intros x C0; clear C0.
        assert (to_set_type B A [_|sub _ [|x]]) as Ax by exact [|x].
        assert (all [_|Ax]) as x_in by exact true.
        rewrite <- CD_all in x_in.
        destruct x_in as [Cx|Dx].
        +   left.
            split with (sub _ [|x]).
            destruct x as [x Ax']; cbn in *.
            split with Ax.
            trivial.
        +   right.
            split with (sub _ [|x]).
            destruct x as [x Ax']; cbn in *.
            split with Ax.
            trivial.
Qed.

(* begin hide *)
End Connected.
Section Connected.

Context {U} `{Topology U}.
Existing Instance subspace_topology.
(* end hide *)
Theorem empty_connected : connected (set_type ∅).
Proof.
    intros A B [A_empty AB].
    apply empty_neq in A_empty.
    destruct A_empty as [[x x_in]].
    exact x_in.
Qed.

Theorem connected_union_connected : ∀ (SS : (U → Prop) → Prop) x,
   (∀ S, SS S → connected (set_type S) ∧ S x) → connected (set_type (⋃ SS)).
Proof.
    intros SS x all_SS.
    classic_case (⋃ SS = ∅) as [SS_empty|SS_nempty].
    {
        rewrite SS_empty.
        exact empty_connected.
    }
    apply empty_neq in SS_nempty.
    destruct SS_nempty as [x' [E [SSE Ex']]].
    pose proof (all_SS E SSE) as [E_con Ex].
    assert ((⋃ SS) x) as x_in.
    {
        exists E.
        split; assumption.
    }
    assert (∀ A B : (set_type (⋃ SS)) → Prop, A [x|x_in] → ¬(separation A B))
        as wlog.
    {
        intros A B Ax AB_sep.
        assert (∀ S, SS S → to_set_type (⋃ SS) S ⊆ A) as sub.
        {
            intros S SS_S a Sa.
            assert (S ⊆ ⋃ SS) as S_sub.
            {
                intros y Sy.
                exists S.
                split; assumption.
            }
            apply all_SS in SS_S as [S_con Sx].
            apply (to_set_type_connected S (⋃ SS) S_sub) in S_con.
            destruct (connected_sub_separation
                    A B (to_set_type (⋃ SS) S) AB_sep S_con) as [sub_A|sub_B].
            -   apply sub_A.
                exact Sa.
            -   assert ((A ∩ B) [x|x_in]) as x_in2.
                {
                    split; try exact Ax.
                    apply sub_B.
                    exact Sx.
                }
                pose proof (land (rand (rand (rand (rand AB_sep)))))
                    as AB_dis.
                unfold disjoint in AB_dis.
                rewrite AB_dis in x_in2.
                contradiction x_in2.
        }
        apply (land (rand AB_sep)).
        apply empty_eq.
        intros a Ba.
        pose proof [|a] as [S [SS_S Sa]].
        specialize (sub _ SS_S _ Sa).
        pose proof (land (rand (rand (rand (rand AB_sep))))) as AB_dis.
        unfold disjoint in AB_dis.
        assert ((A ∩ B) a) as a_in by (split; assumption).
        rewrite AB_dis in a_in.
        exact a_in.
    }
    intros A B [A_empty [B_empty [A_open [B_open [AB_dis AB_all]]]]].
    assert (all [x|x_in]) as x_in2 by exact true.
    rewrite <- AB_all in x_in2.
    destruct x_in2 as [Ax|Bx].
    -   apply (wlog A B Ax).
        repeat split; assumption.
    -   apply (wlog B A Bx).
        unfold separation, disjoint.
        repeat split; try rewrite inter_comm; try rewrite union_comm; assumption.
Qed.

Theorem connected_union_connected2 : ∀ (A B : U → Prop) x,
    A x → B x → connected (set_type A) → connected (set_type B) →
    connected (set_type (A ∪ B)).
Proof.
    intros A B x Ax Bx a_con B_con.
    rewrite <- union_pair.
    apply (connected_union_connected _ x).
    intros S [SA|SB]; subst; split; assumption.
Qed.

Theorem sub_separation_closure_disjoint : ∀ X A B, sub_separation X A B →
    disjoint (closure A) B.
Proof.
    intros X A B [A_empty [B_empty [AB_dis [AB_X [A_lim B_lim]]]]].
    unfold disjoint.
    rewrite closure_limit_points.
    rewrite inter_rdist.
    apply empty_eq.
    intros x [ABx|[Ax Bx]].
    -   unfold disjoint in AB_dis.
        rewrite AB_dis in ABx.
        exact ABx.
    -   exact (A_lim x Ax Bx).
Qed.

Theorem connected_in_closure : ∀ A B, connected (set_type A) →
    A ⊆ B → B ⊆ closure A → connected (set_type B).
Proof.
    intros A B A_con AB BA.
    assert (∀ C D, to_set_type B A ⊆ C → ¬separation C D) as wlog.
    {
        intros C D sub CD_sep.
        pose proof CD_sep as CD_dis.
        apply sub_connected2 in CD_dis.
        apply sub_separation_closure_disjoint in CD_dis.
        apply (to_from_set_type_sub _ _ _ AB) in sub.
        apply closure_sub_closure in sub.
        pose proof (trans BA sub) as leq.
        unfold disjoint in CD_dis.
        pose proof (rand (rand (rand (rand (rand CD_sep))))) as eq.
        apply from_set_type_union in eq.
        rewrite <- eq in leq at 1; clear eq.
        pose proof (land (rand CD_sep)) as D_empty.
        apply empty_neq in D_empty.
        destruct D_empty as [[x Bx] Dx].
        assert (from_set_type D x) as x_in.
        {
            split with Bx.
            trivial.
        }
        assert ((from_set_type C ∪ from_set_type D) x) as x_in2
            by (right; exact x_in).
        apply leq in x_in2.
        assert ((closure (from_set_type C) ∩ from_set_type D) x) as x_in3
            by (split; assumption).
        rewrite CD_dis in x_in3.
        exact x_in3.
    }
    intros C D CD_sep.
    apply (to_set_type_connected A B AB) in A_con.
    pose proof (connected_sub_separation C D (to_set_type B A) CD_sep A_con)
        as [sub|sub].
    -   exact (wlog _ _ sub CD_sep).
    -   apply separation_comm in CD_sep.
        exact (wlog _ _ sub CD_sep).
Qed.
(* begin hide *)
End Connected.
(* end hide *)


From mathcomp Require Import ssreflect ssrnat eqtype ssrbool seq tuple.
Import EqNotations.

Print val.
Print sval.
Lemma sig_bool_eq {A : Type} {P : A -> bool} (x y: {z | P z}): val x = val y -> x = y.
Proof. apply val_inj. Restart.
Proof.
  case: x y => [x Px] [y Py] /= Hxy; destruct Hxy.
  apply eq_exist_uncurried. exists (Logic.eq_refl _).
  apply eq_irrelevance.
Qed.

Require Import ProofIrrelevance.

Section dep_pair.
Context {A : Type} {P : A -> Prop}.
Definition dep_pair := ex_intro P.
Lemma dep_pair_eq (a1 a2 : A) p1 p2: a1 = a2 -> dep_pair a1 p1 = dep_pair a2 p2.
Proof.
  intros ->.
  (* Now f_equal can reduce the equality to a homogeneous one, so it works. *)
  f_equal.
  apply proof_irrelevance.
Qed.
End dep_pair.
(*
Print sig.
Print sigT. *)


Require Import QArith.
Require Import Arith.
Require Import Psatz.
Require Import QArith.Qminmax.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Logic.Classical_Prop.
Require Import Bool Basics OrdersTac.
Require Lra.
Load Hypermap.

Definition prec_CH (m:Hmap) : Prop :=
inv_hmap m /\ linkless m /\ well_emb m /\ noncollinear m.

Definition black_dart (m:Hmap)(d:dart) : Prop :=
~ has_succ m zero d /\ ~ has_succ m one d /\
~ has_pred m zero d /\ ~ has_pred m one d.
Definition blue_dart (m:Hmap)(d:dart) : Prop :=
has_succ m zero d /\ ~ has_succ m one d /\
~ has_pred m zero d /\ has_pred m one d.
Definition red_dart (m:Hmap)(d:dart) : Prop :=
~ has_succ m zero d /\ has_succ m one d /\
has_pred m zero d /\ ~ has_pred m one d.

Definition inv_poly (m:Hmap) : Prop := forall (d:dart),
exd m d -> black_dart m d \/ blue_dart m d \/ red_dart m d.

Lemma black_dart_dec: forall (m:Hmap)(d:dart) , {black_dart m d} + {~black_dart m d}.
Proof.
intros.
unfold black_dart. case (succ_dec m zero d).
-intro. right. intro. tauto.
-intros. case (succ_dec m one d).
  ++intros. right. intro. tauto.
  ++intros. case (pred_dec m zero d).
      -- intros. tauto.
      -- intros. case (pred_dec m one d) .
          +++ tauto.
          +++  intros. tauto.
Qed.

Lemma blue_dart_dec: forall (m:Hmap)(d:dart) , {blue_dart m d} + {~blue_dart m d}.
Proof.
intros.
unfold blue_dart. case (succ_dec m zero d).
-intro. case (succ_dec m one d).
    ++  intros. right. intro. tauto.
    ++  intros. case (pred_dec m zero d).
        -- intros. right.  tauto.
        -- intros. case (pred_dec m one d) .
            +++ intros. left. tauto.
            +++  intros. right. intro. tauto.
-intros. right. intro. tauto.
Qed.

Lemma red_dart_dec: forall (m:Hmap)(d:dart) , {red_dart m d} + {~red_dart m d}.
Proof.
intros.
unfold red_dart. case (succ_dec m zero d).
-intro. right. intro. tauto.
-intros. case (succ_dec m one d).
  ++intros. case (pred_dec m zero d).
      -- intros. case (pred_dec m one d) .
          +++right. intro. tauto.
          +++intros. left. tauto.
      -- intros. tauto.
  ++ intros. right. intro. tauto.
Qed.
 Lemma dart_color_dec: forall (m:Hmap) (d:dart),
well_emb m -> exd m d-> {red_dart m d} + {black_dart m d} + {blue_dart m d}.
Proof.
intros.
unfold well_emb in *. apply H in H0. clear H.
intros. unfold red_dart.

Qed.
Definition convex (m:Hmap) : Prop := forall (x:dart)(y:dart),
exd m x -> exd m y -> blue_dart m x ->
let px := (fpoint m x) in let py := (fpoint m y) in
let x0 := (k_succ m zero x) in let px0 := (fpoint m x0) in
px <> py -> px0 <> py -> ccw px px0 py.

Definition visible (m:Hmap)(d:dart)(p:Point2D) : Prop :=
if (blue_dart_dec m d)
then (ccw (fpoint m d) p (fpoint m (k_succ m zero d)))
else (ccw (fpoint m (k_succ_rev m zero d)) p (fpoint m d)).

Definition invisible (m:Hmap)(d:dart)(p:Point2D) : Prop := ~ visible m d p.

Definition left_dart (m:Hmap)(p:Point2D)(d:dart) : Prop :=
blue_dart m d /\ invisible m (k_succ_rev m one d) p /\ visible m d p.
Definition right_dart (m:Hmap)(p:Point2D)(d:dart) : Prop :=
red_dart m d /\ visible m d p /\ invisible m (k_succ m one d) p.

Lemma visible_dec : forall (m:Hmap)(d:dart)(p:Point2D) ,
 {visible m d p} + {~ visible m d p}.
Proof.
intros.
unfold visible.
case (blue_dart_dec m d).
  -intros. case (ccw_dec (fpoint m d) p (fpoint m (k_succ m zero d))).
    ++ tauto.
    ++ tauto.
  - intros. case (ccw_dec (fpoint m (k_succ_rev m zero d)) p (fpoint m d)).
    ++ tauto.
    ++ tauto.
Qed.
Lemma invisible_dec : forall (m:Hmap)(d:dart)(p:Point2D) ,
 {invisible m d p} + {~ invisible m d p}.
Proof.
intros.
unfold invisible.
case (visible_dec m d p).
  - intros. tauto.
  - intros. tauto.
Qed.
Lemma exist_link: forall(m:Hmap) (d1 d2 d:dart) (k:dim) , exd (L m zero d1 d2) d -> exd m d.
Proof.
intros.
unfold exd in H. fold exd in H. tauto.
Qed.
Lemma exist_insert: forall(m:Hmap)  (d d1:dart) (p:Point2D) , exd m d -> exd (I m d1 p) d.
Proof.
intros.
unfold exd. right. fold exd. tauto.
Qed.
Lemma right_dart_dec : forall (m:Hmap)(p:Point2D)(d:dart) ,
{right_dart m p d} +{~ right_dart m p d}.
Proof.
intros.
unfold right_dart.
case (red_dart_dec m d).
- intros. case (visible_dec m d p).
   ++ intros. case (invisible_dec m (k_succ m one d) p).
      --intros. left. auto.
      --intros. right. tauto.
   ++ intros.  right. tauto.
- intros. right. tauto.
Qed.

Lemma left_dart_dec : forall (m:Hmap)(p:Point2D)(d:dart) ,
 {left_dart m p d} +{~ left_dart m p d}.
Proof.
intros. unfold left_dart.
case (blue_dart_dec m d).
-intros. case (invisible_dec m (k_succ_rev m one d) p).
   ++intros. case (visible_dec m d p).
       --- intros. left. tauto.
       ---intros. right. tauto.
    ++intros. right. tauto.
- intros. right. tauto.
Qed.
Fixpoint submap (m:Hmap)(mr:Hmap): Prop :=
match m with
V => True
| I m0 x p => submap m0 mr /\ exd mr x /\ (fpoint mr x) = p
| L m0 k x y => submap m0 mr /\
(k_succ mr k x) = y /\ (k_succ_rev mr k y) = x
end.

Fixpoint CHID (m:Hmap)(mr:Hmap)(x:dart)(p:Point2D)
 (max:dart) : Hmap :=
 match m with
  V => I V x p
 | I m0 x0 p0 =>
   if(blue_dart_dec mr x0) then
       if(invisible_dec mr x0 p) then
          (I (CHID m0 mr x p max) x0 p0)
       else if(left_dart_dec mr p x0)then
               (L (L (I (I (CHID m0 mr x p max) x0 p0)
               max p) one max x) zero x0 max)
            else(I (CHID m0 mr x p max) x0 p0)
   else if(red_dart_dec mr x0)then
            if(invisible_dec mr x0 p)then
                (I (CHID m0 mr x p max) x0 p0)
            else if(right_dart_dec mr p x0)then
                 (L (I (CHID m0 mr x p max) x0 p0) zero x x0)
                 else(CHID m0 mr x p max)
        else(I (CHID m0 mr x p max) x0 p0)
 | L m0 zero x0 y0 =>
    if(invisible_dec mr x0 p)then
        (L (CHID m0 mr x p max) zero x0 y0)
    else(CHID m0 mr x p max)
 | L m0 one x0 y0 =>
   if(invisible_dec mr x0 p)then
       (L (CHID m0 mr x p max) one x0 y0)
   else if(invisible_dec mr y0 p) then
            (L (CHID m0 mr x p max) one x0 y0)
         else(CHID m0 mr x p max)
 end.

Fixpoint CHI (m1:Hmap)(m2:Hmap)(max:dart) : Hmap :=
match m1 with
V=>m2
| I m0 x p => CHI m0 (CHID m2 m2 x p max) ((max + 1)%nat)
|_=>V
end.

Definition CH2 (x1:dart)(p1:Point2D)
(x2:dart)(p2:Point2D)(max:dart) : Hmap :=
let m0 := (I (I V x1 p1) x2 p2) in
let m1 := L (I m0 (max+1)%nat p1) one (max+1)%nat x1 in
let m2 := L (I m1 (max+2)%nat p2) one (max+2)%nat x2 in
L (L m2 zero x1 (max+2)%nat) zero x2 (max+1)%nat.

Definition CH (m:Hmap) : Hmap :=
match m with
V => V
|I V x p => I V x p
| I (I m0 x1 p1) x2 p2 =>
CHI m0 (CH2 x1 p1 x2 p2 (max_dart m)) (((max_dart m)+3)%nat)
|_=>V
end.

Definition half_blue_succ (m:Hmap)(d:dart) : Prop :=
has_succ m zero d /\ ~ has_succ m one d /\
~ has_pred m zero d /\ ~ has_pred m one d.
Definition half_blue_pred (m:Hmap)(d:dart) : Prop :=
~ has_succ m zero d /\ ~ has_succ m one d /\
~ has_pred m zero d /\ has_pred m one d.

Lemma helper1 : forall (m:Hmap)(d d0: dart)(p :Point2D) ,
exd (I m d0 p) d -> ~ d=d0 -> exd m d.
Proof.
intros.
unfold exd in H. case H.
-intros. symmetry in H1. tauto.
-intro. fold exd in H1. tauto.
Qed.

Lemma helper2 : forall (m:Hmap)(d : dart)(p :Point2D) ,
exd (I m d p) d .
Proof.
intros.
unfold exd. tauto.
Qed.
Lemma helper3 : forall (m mr:Hmap) (x d d1 d2 max:dart) (d0:dim)(p:Point2D) ,
exd (CHID m mr x p max) d -> exd (CHID (L m d0 d1 d2) mr x p max) d.
Proof.
intros.
induction d0.
- unfold CHID. case (invisible_dec mr d1 p).
  +intro. unfold exd. fold exd. fold CHID. auto.
  +intro. auto.
- unfold CHID. case (invisible_dec mr d1 p).
  +intro. unfold exd. fold exd. fold CHID. auto.
  +intro. case (invisible_dec mr d2 p).
    --intro.  unfold exd. fold exd. fold CHID. auto.
    --intro. fold CHID. auto.
Qed.
Lemma submap_insert: forall(m mr:Hmap) (d0:dart) (p:Point2D), submap (I m d0 p) mr -> submap m mr.
Proof.
intros. unfold submap in H.  fold submap in H. tauto.
Qed.
Lemma submap_link: forall(m mr:Hmap) (d1 d2:dart) (d:dim), submap (L m d d1 d2) mr -> submap m mr.
Proof.
intros. unfold submap in H.  fold submap in H. tauto.
Qed.
Lemma submap_insert_rev: forall (m mr:Hmap) (d:dart) (p:Point2D),
~exd m d -> submap m (I mr d p) -> submap m mr.
Proof.
intros. induction m.
- tauto.
- simpl in *. split.
  + apply IHm.
    -- tauto.
    --  tauto.
  + split.
    --apply proj2 in H0. apply proj1 in H0. case H0.
      ++ intro. apply not_or_and in H. rewrite H1 in H.  tauto.
      ++ intro. auto.
    -- apply not_or_and in H. apply proj2 in H0. apply proj2 in H0.
       case (eq_dart_dec d d0) in H0.
      ++ rewrite e in H. tauto.
      ++  auto.
 - simpl in *. split.
   + apply IHm.
     -- auto.
     --  tauto.
   + tauto.
Qed.
Lemma submap_exist_rel: forall (m mr:Hmap) (d:dart),
submap m mr -> exd m d -> exd mr d.
Proof.
intros.
induction m.
-tauto.
- simpl in *. case H0.
  + intro. rewrite H1 in H. tauto.
  + intro. tauto.
- simpl in *. tauto.
Qed.
Fixpoint distinct_members (m:Hmap): Prop :=
match m with
| V => True
| I m0 d _ => ~ exd m0 d /\ distinct_members m0
| L m0 _ _ _ => distinct_members m0
end.
Lemma dis_mem_ins_rev  :
forall (m:Hmap) (d:dart) (p:Point2D) ,
~exd m d /\ distinct_members m -> distinct_members (I m d p).
Proof.
intros.  simpl in *. tauto.
Qed.
(*Lemma submap_inv_hmap: forall(m mr:Hmap) ,
 distinct_members m -> submap m mr -> inv_hmap mr-> inv_hmap m.
Proof.
intros.
induction m.
-  simpl. tauto.
- assert (exd mr d).
  * simpl in H0. tauto.
  * simpl. split.
      + apply IHm.
        -- simpl in H. tauto.
        -- simpl in *. tauto.
      + assert (submap m mr).
        -- simpl in *. tauto.
        -- unfold prec_I. split.
          ++ clear H H0 IHm H3. induction mr.
             --- tauto.
             --- simpl in *. unfold prec_I in H1. case H2.
                 +++ intro. rewrite H in H1. tauto.
                 +++ intro. apply IHmr.
                    ** tauto.
                    **  tauto.
             --- simpl in *. tauto.
          ++ clear H0 H1 IHm H2 H3. induction m.
             --- tauto.
             --- simpl in* . intro . assert(distinct_members (I m d p)).
                  +++ simpl. tauto.
                  +++ tauto.
             --- simpl. apply IHm. simpl. tauto.
- assert(exd mr d0).
  + unfold submap
  +  apply IHm.
    --tauto.
    -- tauto.
  + unfold prec_L. split.
    --

Qed.*)
Lemma blue_dart_CHID_1 :
forall (m mr:Hmap)(x:dart)(px:Point2D)(max:dart)(d:dart),
blue_dart mr d -> exd m d -> exd (CHID m mr x px max) d.
Proof.
intros.
induction m.
- tauto.
- simpl. case (blue_dart_dec mr d0).
  ++intros. case (invisible_dec mr d0 px).
      -- intros. case (eq_dart_dec d d0).
         +++ intro. rewrite e. apply helper2.
         +++ intro. elim H0.
             --- intro. symmetry in H1. tauto.
             --- intro. simpl. right. tauto.
      --intro. case (left_dart_dec mr px d0).
        +++intro. case (eq_dart_dec d d0).
            ---intro. rewrite e. unfold exd. right. auto.
            ---intro. unfold exd. right. right. fold exd.
               apply IHm. apply (helper1 m d d0 p).
               ++++tauto.
               ++++tauto.
        +++ intro. case (eq_dart_dec d d0).
            ---intro. rewrite e. apply helper2.
            ---intro. unfold exd in H0. case H0.
               ++++intro. symmetry in H1. tauto.
               ++++intro. fold exd in H1. clear H0.
                   unfold exd. right. fold exd. apply IHm. tauto.
  ++ intro. case(red_dart_dec mr d0).
      --intro. case (invisible_dec mr d0 px).
        +++intro. case (eq_dart_dec d0 d).
            ---intro. rewrite e. apply helper2.
            ---intro. unfold exd. right. fold exd.
               apply IHm. apply (helper1 m d d0 p).
               ++++ tauto.
               ++++ auto.
        +++intro. case (eq_dart_dec d0 d).
            ---intro. case (right_dart_dec mr px d0).
                ++++ intro. unfold exd.  tauto.
                ++++ intro. apply IHm. rewrite e in n. tauto.
            ---intro. case (right_dart_dec mr px d0).
                ++++ intro. unfold exd. right. fold exd.
                     apply IHm. apply (helper1 m d d0 p).
                     ---- tauto.
                     ---- auto.
                ++++intro. apply IHm. apply (helper1 m d d0 p).
                     ---- tauto.
                     ---- auto.
    --intro. case (eq_dart_dec d d0).
       +++ intro. rewrite e in H. tauto.
       +++ intro. unfold exd. right. fold exd. apply IHm.
           apply (helper1 m d d0 p).
          --- tauto.
          --- tauto.
- unfold exd. fold exd. apply helper3. apply IHm.
  unfold exd in H0. fold exd in H0. auto.
Qed.

Lemma blue_dart_CHID_11 :
forall (m mr:Hmap)(x:dart)(px:Point2D)(max:dart)(d:dart),
submap m mr -> d <> x -> exd m d -> blue_dart mr d ->
visible mr d px -> invisible mr (k_succ_rev mr one d) px ->
k_succ (CHID m mr x px max) zero d = max.
Proof.
intros.
induction m.
- unfold exd in H1. tauto.
- simpl. case (blue_dart_dec mr d0).
  +intro. case (invisible_dec mr d0 px).
    --intro. unfold k_succ. fold k_succ. apply IHm.
      ++ unfold submap in H. simpl. fold submap in H. tauto.
      ++ apply (helper1 m d d0 p).
         --- tauto.
         --- intro. rewrite H5 in H3. unfold invisible in i. auto.
    --intro. case(left_dart_dec mr px d0).
      ++intro. unfold k_succ. fold k_succ. case (eq_dart_dec d0 d).
            +++intro. case (eq_dim_dec zero one).
                ----intro. discriminate.
                ----intro. case(eq_dim_dec zero zero).
                    ++++intro. auto.
                    ++++intro. apply IHm.
                        ** apply (submap_insert m mr d0 px). tauto.
                        ** tauto.
            +++intro. case (eq_dim_dec zero zero).
               ----intro. case (eq_dim_dec zero one).
                   ++++intro. discriminate.
                   ++++intro. apply IHm.
                       **  apply (submap_insert m mr d0 p). tauto.
                       ** apply (helper1 m d d0 p).
                          ***auto.
                          *** auto.
               ----intro. tauto.
      ++intro. apply IHm.
        --- apply (submap_insert m mr d0 p). tauto.
        --- case(eq_dart_dec d d0).
            +++ intro. unfold left_dart in n0. apply not_and_or in n0.
                case n0.
                * intro. tauto.
                * intro. apply not_and_or in H5. case H5.
                  ** intro. rewrite e in H4. tauto.
                  ** intro. tauto.
            +++ intro. apply (helper1 m d d0 p).
               * tauto.
               * tauto.
  +intro. case (red_dart_dec mr d0).
    --intro. case (invisible_dec mr d0 px).
       ++ intro. unfold k_succ. fold k_succ. apply IHm.
           --- apply (submap_insert m mr d0 p). tauto.
           --- case (eq_dart_dec d d0).
               +++ intro. rewrite e in H2. tauto.
               +++ intro. apply (helper1 m d d0 p).
                   * tauto.
                   * tauto.
       ++ intro. case (right_dart_dec mr px d0).
          --- intro. case (eq_dart_dec d d0).
              +++ intro. rewrite e in H2. tauto.
              +++ intro. unfold k_succ. fold k_succ. case (eq_dim_dec zero zero).
                  ----intro. case (eq_dart_dec x d).
                      * intro. symmetry in e0. tauto.
                      * intro. apply IHm.
                        **  apply (submap_insert m mr d0 p). tauto.
                        ** apply (helper1 m d d0 p).
                          *** tauto.
                          *** tauto.
                  ----intro. apply IHm.
                      * apply (submap_insert m mr d0 p). tauto.
                      * apply (helper1 m d d0 p).
                        ** tauto.
                        ** tauto.
          --- intro. apply IHm.
              +++ apply (submap_insert m mr d0 p). tauto.
              +++ apply (helper1 m d d0 p).
                  * tauto.
                  * intro. rewrite H5 in H2. tauto.
   -- intro. apply IHm.
      ++ apply (submap_insert m mr d0 p). tauto.
      ++  apply (helper1 m d d0 p).
          ---tauto.
          --- intro. rewrite H5 in H2. tauto.
- simpl. induction d0.
  + case(invisible_dec mr d1 px).
    -- intro. case(eq_dart_dec d d2).
        ++intro. unfold k_succ. fold k_succ. case (eq_dim_dec zero zero).
             ---intro. case (eq_dart_dec d1 d).
                +++intro. unfold invisible in i. rewrite e1 in i. tauto.
                +++intro. apply IHm.
                    * apply (submap_link m mr d1 d2 zero ). tauto.
                    * apply (exist_link m d1 d2 d zero). tauto.
             ---intro. tauto.
        ++intro. unfold k_succ. fold k_succ.  case (eq_dim_dec zero zero).
            ---intro. case(eq_dart_dec d1 d).
                * intro. rewrite e0 in i. unfold invisible in i. tauto.
                * intro. apply IHm.
                  ** apply (submap_link m mr d1 d2 zero ). tauto.
                  ** apply (exist_link m d1 d2 d zero). tauto.
            ---intro. tauto.
     -- intro. apply IHm.
        ++ apply (submap_link m mr d1 d2 zero ). tauto.
        ++ apply (exist_link m d1 d2 d zero). tauto.
  + case(invisible_dec mr d1 px).
    -- intro. unfold k_succ. fold k_succ. case (eq_dim_dec zero one).
        ++ intro. discriminate.
        ++ intro. apply IHm.
            --- apply (submap_link m mr d1 d2 one ). tauto.
            ---apply (exist_link m d1 d2 d one). tauto.
    -- intro. case (invisible_dec mr d2 px).
        +++ intro. unfold k_succ. fold k_succ. case (eq_dim_dec zero one).
            * intro. discriminate.
            *intro. apply IHm.
               ** apply (submap_link m mr d1 d2 one ). tauto.
               ** apply (exist_link m d1 d2 d one). tauto.
        +++ intro. apply IHm.
            * apply (submap_link m mr d1 d2 one ). tauto.
            * apply (exist_link m d1 d2 d one). tauto.
Qed.
Lemma exd_dec : forall (m:Hmap) (d:dart) ,{exd m d} + {~ exd m d}.
Proof.
intros.
induction m.
- tauto.
- case IHm.
  + intro. left. apply (exist_insert  m d d0 p). auto.
  + intro. case (eq_dart_dec d d0).
    --intro. left. unfold exd. left. auto.
    --intro. right. intro. unfold exd in H. fold exd in H. case H.
       ++ intro. symmetry in H0. auto.
       ++ intro. auto.
- case IHm.
  +intro. auto.
  +intro. auto.
Qed.

Lemma noncolinear_insert: forall (m:Hmap) (x:dart) (p:Point2D),
~ exd m x -> noncollinear (I m x p) -> noncollinear m.
Proof.
intros.
unfold noncollinear. intros. unfold noncollinear in H.
unfold noncollinear in H0. simpl in *.
specialize H0 with d1 d2 d3.
intro.
apply H0.
 - auto.
 - auto.
 - auto.
 - case (eq_dart_dec x d1).
   + intro. rewrite e in H. tauto.
   +  intro. case (eq_dart_dec x d2).
      -- intro. rewrite e in H. tauto.
      -- intro. auto.
 -case (eq_dart_dec x d1).
   + intro. rewrite e in H. tauto.
   +  intro. case (eq_dart_dec x d2).
      -- intro. rewrite e in H. tauto.
      -- intro. case (eq_dart_dec x d3).
         ++ intro. rewrite e in H. tauto.
         ++ intro. tauto.
 -case (eq_dart_dec x d1).
   + intro. rewrite e in H. tauto.
   +  intro. case (eq_dart_dec x d2).
      -- intro. rewrite e in H. tauto.
      -- intro. case (eq_dart_dec x d3).
         ++ intro. rewrite e in H. tauto.
         ++ intro. tauto.
-  case (eq_dart_dec x d1).
   + intro. rewrite e in H. tauto.
   +  intro. case (eq_dart_dec x d2).
      -- intro. rewrite e in H. tauto.
      -- intro. case (eq_dart_dec x d3).
         ++ intro. rewrite e in H. tauto.
         ++ intro. auto.
Qed.
Lemma linkless_inser: forall (m:Hmap) (x:dart) (p:Point2D),
linkless (I m x p) <-> linkless m.
Proof.
intros. split.
-intro. tauto.
- intro. tauto.
Qed.
Lemma linkless_exist_succ: forall (m:Hmap) (x:dart) (d:dim),
linkless m -> ~ has_succ m d x.
Proof.
intros. intro. induction m.
- auto.
- simpl in *. auto.
-  simpl in *. auto.
Qed.
Lemma linkless_exist_pred: forall (m:Hmap) (x:dart) (d:dim),
linkless m -> ~ has_pred m d x.
Proof.
intros. intro. induction m.
- auto.
- simpl in *. auto.
-  simpl in *. auto.
Qed.
Lemma well_emb_insert: forall (m:Hmap) (d:dart)(p:Point2D),
linkless m -> ~ exd m d -> well_emb( I m d p) -> well_emb (m).
Proof.
intros.
unfold well_emb in *. intros. split.
- intro. specialize H1 with x. case H1.
  + apply exist_insert. auto.
  + intros. simpl in *. clear H1. clear H5.
    apply (linkless_exist_succ m x zero) in H. auto.
- split.
  + intro. apply (linkless_exist_succ m x one) in H. tauto.
  + split.
     -- intro.  apply (linkless_exist_pred m x zero) in H. tauto.
     -- split.
        ++  intro.  apply (linkless_exist_pred m x one) in H. tauto.
        ++ intros. specialize H1 with x. apply proj2 in H1.
           apply proj2 in H1. apply proj2 in H1. apply proj2 in H1.
               specialize H1 with y.  assert( exd (I m d p) y).
           --- apply exist_insert. auto.
           --- apply H1 in H6.
             +++ simpl in *. case(eq_dart_dec d x) in H6.
               * rewrite e in H0. auto.
               * intro. case(eq_dart_dec d y) in H6.
                  ** rewrite e in H0. auto.
                  ** auto.
            +++ auto.
            +++ auto.
            +++ auto.
          --- apply exist_insert. auto.
Qed.
Lemma prec_insert: forall (m:Hmap)(d:dart)(p:Point2D),
  prec_CH (I m d p) -> prec_CH m .
Proof.
intros. induction m.
- unfold prec_CH in *. simpl in *. split.
  * auto.
  * split.
    ** auto.
    ** split.
        *** unfold well_emb. tauto.
        *** unfold noncollinear . intros. auto.
- unfold prec_CH. simpl in *. split.
  * unfold prec_CH in *. simpl in *. tauto.
  * unfold prec_CH in *. simpl in *. split.
    ** tauto.
    ** split.
       *** apply (well_emb_insert (I m d0 p0) d p).
           + tauto.
           + unfold prec_I in H. tauto.
           + tauto.
       *** apply (noncolinear_insert (I m d0 p0) d p).
          + unfold prec_I in H. tauto.
          + tauto.
- unfold prec_CH in *. simpl in *. tauto.
Qed.
Lemma inv_hmap_nil: forall(m :Hmap) (d:dart),
 exd m d -> inv_hmap m  -> d<>nil.
Proof.
intros.
induction m.
- tauto.
- simpl in *. elim H.
    +intros. elim H0. intros. unfold prec_I in H3.
      rewrite H1 in H3. tauto.
    +intros. tauto.
- simpl in *. tauto.
Qed.
Lemma CHID_exd_m: forall (m mr :Hmap) (d:dart) (x:dart)(p:Point2D) (max:nat),
~exd m d -> ~x=d -> (max > d)%nat ->~exd (CHID m mr x p max) d.
Proof.
intros.
induction m.
- simpl in*.  tauto.
- simpl in *. case(blue_dart_dec mr d0).
   + intro. case (invisible_dec mr d0 p).
      -- intro. simpl in *. intro. elim H1.
          tauto. intro. tauto.
      -- intro. case(left_dart_dec mr p d0).
         intro. simpl in *. intro. elim H2.
         intro. rewrite H3 in H1. lia.
         intro. tauto.
         intro. simpl in *. intro.
         tauto.
   + intro. case(red_dart_dec mr d0).
      -- intro. case(invisible_dec mr d0 p).
          ++ intro. simpl in *. intro. tauto.
          ++ intros.  case(right_dart_dec mr p d0).
             intro. simpl in *. tauto.
             intro. tauto.
      -- intro. simpl in *. tauto.
- simpl in *.  case d0.
   +case (invisible_dec mr d1 p).
      --intro. simpl in *. tauto.
      -- intro. tauto.
  + case(invisible_dec mr d1 p).
      --intro. simpl in *. tauto.
      --intro. case (invisible_dec mr d2 p).
          ++ intro. simpl in *. tauto.
          ++ intro. tauto.
Qed.
Lemma max_dart_h1: forall(m: Hmap) (d:dart),
exd m d -> (d > max_dart m)%nat -> False.
Proof.
intros. induction m.
- tauto.
- simpl in H. simpl in H0.  case (lt_dec (max_dart m) d0) in H0.
  + elim H.
    -- intro. rewrite H1 in  *. apply (lt_irrefl d) in H0. tauto.
    -- intro. apply IHm.
       ++ tauto.
       ++ lia.
  + elim H.
    -- intro. rewrite H1 in n. lia.
    -- intro. tauto.
- simpl in *. tauto.
Qed.
Lemma CHID_point_exd: forall(m mr :Hmap) (d:dart) (x:dart)(p:Point2D) (max:nat) ,
exd (CHID m mr x p max) x.
Proof.
intros.
induction m.
- simpl in *. tauto.
- simpl in *. case(blue_dart_dec mr d0).
  + case(invisible_dec mr d0 p).
    --intros. simpl in *. right. tauto.
    -- intros.  case(left_dart_dec mr p d0).
        ++ intros. simpl in *.  tauto.
        ++ intros. simpl in *.  tauto.
  + intros. case(red_dart_dec mr d0).
    -- intros. case(invisible_dec mr d0 p).
        ++ intros. simpl in *.  tauto.
        ++ intros. case(right_dart_dec mr p d0).
           intros. simpl in *. tauto. intro. tauto.
    -- intro. simpl in *. tauto.
- simpl in *. case d0.
   + case ( invisible_dec mr d1 p).
      -- intro. simpl in *. tauto.
      -- intro.  tauto.
  +case (invisible_dec mr d1 p).
      -- intro. simpl in *. tauto.
      -- intro. case (invisible_dec mr d2 p).
          intro. tauto.
          intro. tauto.
Qed.
(*Lemma CHID_inv_hmap: forall(m mr:Hmap)  (x max :dart) (p:Point2D),
distinct_members m -> ~x = nil ->  ~exd m x -> (max > (max_dart mr))%nat ->
submap m mr -> inv_hmap mr -> inv_hmap (CHID m mr x p max).
Proof.
intros.
induction m.
- unfold CHID. unfold inv_hmap. unfold prec_I. tauto.
-  simpl. simpl in H.  case (blue_dart_dec mr d).
  + intro. case (invisible_dec mr d p).
    -- intro. simpl. split.
       ++ simpl in H3. simpl in H1. apply IHm. tauto. tauto.
          simpl in H2. tauto.

       ++ simpl in H3. unfold prec_I. split.
          --- apply (inv_hmap_nil mr d). tauto. tauto.
          --- clear IHm. induction m .
              +++ simpl. unfold exd in H1.
                  intro. elim H1. case H5. intro.
                   symmetry in H6. tauto. intro.  auto.
              +++ simpl in H1. assert( ~ exd (I m d0 p1) d ). tauto.
                  simpl in H5.
                  simpl. case (blue_dart_dec mr d0).
                    *  intro. case(invisible_dec mr d0 p).
                        ** intro. simpl.  apply and_not_or. split.
                           *** apply not_or_and in H5. tauto.
                           *** apply IHm.
                                split. tauto. elim H. intros. simpl in H7. tauto.
                                 simpl. intro. elim H6. intro. tauto.
                                intro. tauto. simpl.
                                split. simpl in H3. tauto.
                                split. simpl in H3. tauto.
                                simpl in H3. tauto.
                        ** intros. case (left_dart_dec mr p d0).
                            *** intros. simpl. intro. unfold left_dart in l.
                                unfold invisible in i.
                                 elim H6.
                                intros.  unfold invisible in n.
                                rewrite H7 in H2. apply ( max_dart_h1 mr d). tauto. tauto.
                                intro. elim H7.
                                intro. tauto. intros. apply IHm.
                                split. tauto. simpl in H. tauto.
                                simpl. tauto. simpl. split. simpl in H2. simpl in H3.  tauto.
                                split. apply not_or_and in H1. elim H1. intros.
                                simpl in H2. tauto. simpl in H2. tauto. tauto.
                            *** intros. simpl. intro. apply IHm.
                                split. tauto. simpl in H. tauto.
                                simpl in H. simpl. tauto. simpl in H3. simpl.
                                tauto. elim H6. intro. tauto. intros. tauto.
                    * intros admit.  case(invisible_dec mr d0 p).
                        ** intro. case(red_dart_dec mr d0 ).
                           *** intro. simpl. apply and_not_or. split.
                                tauto. apply IHm. simpl in H1. split.  tauto.
                                simpl in H. tauto. simpl. apply and_not_or .
                                tauto. simpl. simpl in H3. tauto.
                           *** intro. simpl. apply and_not_or. split.
                                intro. apply not_or_and in H5. tauto.
                                apply IHm. simpl in *. tauto.
                                simpl in *. tauto. simpl in *. tauto.
                        ** intros. case(red_dart_dec mr d0 ).
                            ***intros. case (right_dart_dec mr p d0).
                               intros. simpl in *. tauto.
                               intros. simpl in *. tauto.
                            *** intros. simpl in *. tauto.
            +++ simpl in *. case d0.
                * case (invisible_dec mr d1 p).
                   ** intros. simpl in *. tauto.
                   ** intros. tauto.
                * case (invisible_dec mr d1 p).
                   ** intros. simpl in *. tauto.
                   ** intros. case(invisible_dec mr d2 p).
                      *** intros. simpl in *. tauto.
                      *** intros. tauto.
    -- intros. case (left_dart_dec mr p d).
       ++intros. simpl in *. split.
          ---  split.
               +++ split.
                   * split.
                     ** tauto.
                     ** unfold prec_I. split. apply (inv_hmap_nil mr d).
                        tauto. tauto.
                        clear IHm.
                        induction m.
                        *** simpl in *. apply and_not_or.
                            apply not_or_and in H1. split. intro.
                             symmetry in H5. tauto.  tauto.
                        *** simpl in *.  case(blue_dart_dec mr d0).
                            intros. case(invisible_dec mr d0 p).
                            intros. simpl in *. intro. elim H5.
                            intro. apply proj1 in H . apply not_or_and in H. tauto.
                            intro. tauto.
                            intros. case (left_dart_dec mr p d0).
                            simpl in *. intro. intro. elim H5.
                            intro.  apply ( max_dart_h1 mr d).
                             tauto. rewrite H6 in H2. tauto.
                            intro. tauto.
                            intros. simpl in *. intro. tauto.
                            intros. case (red_dart_dec mr d0).
                            intros. case(invisible_dec mr d0 p).
                            intros. simpl in *. tauto.
                            intros. case(right_dart_dec mr p d0).
                            intros. simpl in *. intro. tauto.
                            intros. tauto.
                            intros. simpl. tauto.
                        *** simpl in *. case d0.
                             case( invisible_dec mr d1 p).
                            intros. simpl in *. tauto.
                            intros. tauto.
                            case (invisible_dec mr d1 p).
                            intro. simpl in *. tauto.
                            intro. case (invisible_dec mr d2 p).
                            intro. tauto.
                            intro. tauto.
                * simpl. unfold prec_I. split. admit. simpl. intro.
                   elim H5. intro. rewrite <- H6 in H2.
                   apply ( max_dart_h1 mr d). tauto. tauto.
                   intro. admit.
            +++ unfold prec_L. split. simpl. tauto.
                split. simpl. . admit. split. intro.
                unfold has_succ in H4. simpl in H4. admit.
                split. intro. unfold has_succ in H4. simpl in H4.
                admit. admit.
     --- admit.
   ++ admit.
  + admit.
-admit.

 simpl in H1. assert(submap m mr). tauto.
              apply IHm in H2.
              induction mr.
              +++ simpl.  tauto.
              +++ fold inv_hmap in *. unfold CHID.
Qed.*)
Lemma dart_nil_dec: forall(d:dart) ,
{d=nil} + {(d > nil) %nat}.
Proof.
intro.
induction d.
- apply(zerop nil).
- simpl. case IHd.
  + intro. right. rewrite e. lia.
  + intro. right. assert (S d > d)%nat. lia.
    apply (gt_trans (S d) d nil). tauto. tauto.
Qed.
Lemma succ_pred: forall(m:Hmap) (d:dim)(d1:dart),
inv_hmap m -> has_pred m d d1 -> has_succ m d (k_pred m d d1).
Proof.
intros.
induction m.
-tauto.
- simpl in *. unfold has_succ in *. unfold has_pred in *. tauto.
-unfold has_pred in *. simpl in *. case(eq_dim_dec d d0) in *.
  + case(eq_dart_dec d3 d1) in *.
    -- unfold has_succ. simpl. case (eq_dim_dec d d0).
        ++ intro. case(eq_dart_dec d2 d2). intro.
               unfold prec_L in H. intro. rewrite H1 in H.
              assert(exd m nil). tauto. apply (inv_hmap_nil m nil). tauto.
              tauto. tauto.
           intro. tauto.
        ++ intro. tauto.
    -- unfold has_succ. simpl.  case (eq_dim_dec d d0).
        ++ intro. case (eq_dart_dec d2 (k_pred m d d1)).
           intro.  unfold prec_L in H. intro. rewrite H1 in H.
              assert(exd m nil). tauto. apply (inv_hmap_nil m nil). tauto.
              tauto. tauto.
           intro. tauto.
        ++ intro. tauto.
  + unfold has_succ. simpl. case (eq_dim_dec d d0).
    -- intro. case(eq_dart_dec d2 (k_pred m d d1)).
       ++ intro. tauto.
       ++ intro. tauto.
    -- intro. tauto.
Qed.
Lemma pred_fpoint_eq: forall(m:Hmap) (d: dart),
well_emb m -> exd m d -> blue_dart m d -> fpoint m d = fpoint m (k_pred m one d).
Proof.
intros.
unfold well_emb in *.
specialize H with d. apply H in H0.
unfold blue_dart in *. apply proj2 in H1. apply proj2 in H1. apply proj2 in H1.
apply proj2 in H0. apply proj2 in H0. apply proj2 in H0. apply proj1 in H0.
apply H0 in H1. unfold k_succ_rev in *. tauto.
Qed.
Lemma submap_fpoint: forall (m mr :Hmap) (d:dart),
submap m mr -> exd m d-> fpoint m d = fpoint mr d.
Proof.
intros.
induction m.
- tauto.
- simpl in *.
  case (eq_dart_dec d0 d) in *.
  + rewrite e in *. symmetry. tauto.
  + tauto.
- simpl in *. tauto.
Qed.
Lemma submap_noncollinear: forall (m mr : Hmap),
submap m mr -> noncollinear mr -> noncollinear m.
Proof.
intros.
unfold noncollinear in *.
intros. specialize H0 with d1 d2 d3.
assert (exd mr d1). apply (submap_exist_rel m mr d1 ). tauto. tauto.
assert (exd mr d2). apply (submap_exist_rel m mr d2 ). tauto. tauto.
assert (exd mr d3). apply (submap_exist_rel m mr d3 ). tauto. tauto.
assert (fpoint m d1 = fpoint mr d1).
apply (submap_fpoint m mr d1). tauto. tauto.
assert (fpoint m d2 = fpoint mr d2).
apply (submap_fpoint m mr d2). tauto. tauto.
assert (fpoint m d3 = fpoint mr d3).
apply (submap_fpoint m mr d3). tauto. tauto.

rewrite <- H10 in H0. rewrite <- H11 in H0. rewrite <- H12 in H0.
 tauto.
Qed.
Lemma left_dart_h1: forall(m mr :Hmap) (d1 d2 dnew:dart) ,
inv_hmap m -> well_emb m-> submap m mr-> noncollinear mr -> convex m ->
exd mr dnew -> exd m d1 -> exd m d2 -> left_dart m (fpoint mr dnew) d1 ->
 ccw (fpoint m d1) (fpoint mr dnew) (fpoint m d2).
Proof.
intros.
remember (fpoint mr dnew) as p.
unfold left_dart in *.
elim H7. intro. intro. elim H9. intro. intro.
unfold invisible in *. unfold visible in *. case(blue_dart_dec m (k_succ_rev m one d1)) in *.
- unfold k_succ_rev in *.  unfold blue_dart in *.
     apply proj2 in b. apply proj1 in b. apply proj2 in H8. apply proj2 in H8. apply proj2 in H8.
      assert (False). apply (succ_pred) in H8.
      tauto.  tauto. tauto.
- case(blue_dart_dec m d1) in *.
  + unfold k_succ_rev in *. simpl in *.
    remember (fpoint m d1) as pd1. remember (fpoint m d2) as pd2.
    remember (fpoint m (k_pred m zero (k_pred m one d1))) as pred.
    remember (fpoint m (k_succ m zero d1)) as pnex.

    apply (ccw_dual_trans pred pd1 p pnex pd2).
    -- assert(fpoint m (k_pred m one d1) = pd1).
        ++ unfold blue_dart in b. symmetry. rewrite Heqpd1. apply (pred_fpoint_eq m d1).  (*fpoint d1 and k_pred one d1 are same from blue_dart*)
           tauto. tauto. tauto.
        ++ rewrite  H12 in H7. assert(~ ccw pred p pd1). tauto.
         apply ccw_not_col . tauto.
         unfold noncollinear in *.
        specialize H2 with (k_pred m zero (k_pred m one d1)) dnew d1.

        assert(fpoint m (k_pred m zero (k_pred m one d1)) = fpoint mr (k_pred m zero (k_pred m one d1))).
         apply submap_fpoint. tauto. case (dart_color_dec m (k_pred m one d1)).
        tauto.
          admit.
       rewrite  Heqpred . rewrite Heqpd1 . rewrite Heqp .
         assert(fpoint m d1 = fpoint mr d1).
          apply submap_fpoint. tauto. tauto.
          rewrite H15.          apply H2.
         apply(submap_exist_rel m mr (k_pred m zero (k_pred m one d1))).
           tauto. admit.
           tauto. apply (submap_exist_rel m mr d1). tauto. tauto.
           admit.
            admit. admit.

    -- admit. (* results from convexity and blue_dart d1*)
    -- admit. (* results from blue_dart d1*)
    --tauto.
    -- admit. (* results from blue_dart d1*)
  + tauto.

Lemma left_dart_uniq: forall (mr: Hmap) (d1 d2 :dart) (p:Point2D),
convex mr -> exd mr d1 -> exd mr d2 -> left_dart mr p d1 -> left_dart mr p d2 -> d1 = d2.
Proof.
intros. unfold convex in *. specialize H with d1 d2. unfold blue_dart in *.  simpl in *. tauto.
-  unfold convex in H. specialize H with d1 d2.
   simpl in *. case (eq_dart_dec d d1) in *.
    + case (eq_dart_dec d d2) in *.
       -- rewrite e in e0. tauto.
       -- case(eq_dart_dec d (k_succ mr zero d1)).
          ++ intro. admit. (* self loop on d*)
          ++ intro. case(eq_dart_dec d (k_succ mr zero d1)) in *.
             --- admit. (*self loop on d*)
             --- rewrite e in *. unfold left_dart in H0. admit.
    + case(eq_dart_dec d (k_succ mr zero d1)) in *.
        -- case(eq_dart_dec d d2) in *.
           ++ admit.
           ++ admit.
        -- case(eq_dart_dec d d2) in *.
           ++  admit.
           ++ admit.
- admit.
Qed.
Lemma CHID_blue_left_nexd: forall (m mr:Hmap) (d x:dart)(p:Point2D)(max:dart),
blue_dart mr d -> visible mr d p -> left_dart mr p d -> ~ exd m d
-> submap m mr -> (max > (max_dart mr))%nat /\ (max > x)%nat
-> ~ exd (CHID m mr x p max) max.
Proof.
intros. induction m.
- simpl. intro. case H5. intro. rewrite H6 in H4. lia. tauto.
-  simpl in *. case (blue_dart_dec mr d0).
   + intro. case(invisible_dec mr d0 p  ).
      -- intro. simpl. intro. elim H5. intro.
          rewrite <- H6 in H4. apply (max_dart_h1 mr d0).  tauto.
          tauto.
          intro. tauto.
      -- intro. case (left_dart_dec mr p d0).
          ++ intro. simpl in *. intro. admit.
          ++ intro. simpl. intro. elim H5.  intro.
             rewrite <- H6 in H4. apply (max_dart_h1 mr d0). tauto.
             tauto.
             intro. tauto.
    + intro. case (red_dart_dec mr d0).
       -- intro. case (invisible_dec mr d0 p).
          ++ intro. simpl. intro. elim H5.
             intro. apply (max_dart_h1 mr d0). tauto. rewrite <- H6 in H4. tauto.
             intro. tauto.
          ++ intro. case (right_dart_dec mr p d0).
             intro. simpl. intro.  elim H5. intro. rewrite<- H6 in H4.
             apply (max_dart_h1 mr d0). tauto. tauto.
             intro. tauto.
             intro. tauto.
      -- intro. simpl. intro. elim H5. intro. rewrite <- H6 in H4.
         apply (max_dart_h1 mr d0). tauto. tauto.
         intro. tauto.
- simpl. case d0.
   + case (invisible_dec mr d1 p).
      -- intro. simpl in *.   tauto.
      -- intro. simpl in *. tauto.
   + case (invisible_dec mr d1 p).
      -- intro. simpl in *. tauto.
      -- intro. case (invisible_dec mr d2 p).
          ++ intro. simpl in *. tauto.
          ++  intro. simpl in *. tauto.
Qed.
Lemma CHID_inv_hmap_h1:forall(m mr:Hmap) (x:dart)(p:Point2D)(max:dart) ,
 submap m mr -> inv_hmap mr -> inv_hmap m-> convex mr -> x <> nil -> ~exd mr x
-> (max > x)%nat /\ (max > max_dart mr)%nat
 ->inv_hmap (CHID m mr x p max).
Proof.
intros. induction m.
-simpl. unfold prec_I. tauto.
-simpl. case (blue_dart_dec mr d).
    + intro. case (invisible_dec mr d p).
        -- intro. simpl. split.
            ++ simpl in H. simpl in H1. tauto.
            ++ unfold prec_I. split. simpl in H.
               apply (inv_hmap_nil mr d).
               tauto. tauto.
                simpl in H. simpl in H1. unfold prec_I in *|-.
                assert(inv_hmap (CHID m mr x p max)). tauto.
                induction m.
                --- simpl in *. unfold prec_I in *.
                    elim H. intros. intro. case H9. intros.
                     rewrite <- H10 in H. tauto.  tauto.
                --- simpl in *. case(blue_dart_dec mr d0) in *.
                     +++ intro. case (invisible_dec mr d0 p) in *.
                         * simpl in *. tauto.
                         * simpl in *. case(left_dart_dec mr p d0) in *.
                             simpl in *. elim H7. intro. rewrite H8 in H5.
                             apply proj2 in H5. apply (max_dart_h1 mr d). tauto.
                             tauto. intro.  tauto. simpl in *. tauto.
                     +++ intro. case(red_dart_dec mr d0) in *.
                         * case(invisible_dec mr d0 p) in *.
                            simpl in *. tauto. case(right_dart_dec mr p d0) in *.
                            simpl in *. tauto. tauto.
                         * simpl in *. tauto.
                 --- simpl in *. case d0 in *.
                      +++ case (invisible_dec mr d1 p) in *.
                          * simpl in *. tauto.
                          * tauto.
                      +++ case(invisible_dec mr d1 p) in *.
                          * simpl in *. tauto.
                          * case (invisible_dec mr d2 p) in *.
                                simpl in *. tauto.
                                tauto.
         -- intro. case(left_dart_dec mr p d) in *.
             ++ simpl in *. split. split.  split. split.
                tauto. unfold prec_I. split.  apply (inv_hmap_nil mr d). tauto.
                tauto. apply (CHID_exd_m m mr d x p max ).
                unfold prec_I in *. tauto. intro. rewrite H6 in H4. tauto.
                assert(~ max_dart mr < d)%nat. intro. apply (max_dart_h1 mr d).
                tauto. lia. apply not_lt in H6. lia.
                unfold prec_I. split. intro. rewrite H6 in H5. case(dart_nil_dec  x).
                intro. tauto.  intro. lia.

                simpl in *. intro. elim H6.
                intro. admit.
                intro. unfold prec_I in *. admit.
                unfold prec_L.  simpl in *. split.
                tauto. split. right.  right. apply CHID_point_exd.  tauto.
                split. unfold has_succ. simpl in *. admit.
                split. unfold has_pred. simpl in *. admit.
                admit.
                 unfold prec_L. simpl in *. split.
                tauto. split. right.  right. admit.
                split. unfold has_succ. simpl in *. admit.
                split. unfold has_pred. simpl in *. admit.
                admit.
             ++ simpl in *. split. tauto. unfold prec_I.
                split. admit. admit.
    + intro. case(red_dart_dec mr d).
       -- intro. case(invisible_dec mr d p).
          ++ intro. simpl in *. split. tauto.
             unfold prec_I. split. admit. admit.
          ++ intro. case(right_dart_dec mr p d).
             intro. simpl in *. split. split. tauto.
             unfold prec_I. split. admit.  admit.
             unfold prec_L. split. simpl. admit.
             simpl. split.   admit.
             simpl.  split.  unfold has_succ.
             simpl. admit.
             split. unfold has_succ.  admit.
             admit.
            intro. simpl in *.  tauto.
       -- intro. simpl in *. split. tauto .
          unfold prec_I. split. admit. admit.
- simpl in *. case d.
   + case ( invisible_dec mr d0 p).
      --intro. simpl in *. split. tauto.
        unfold prec_L. split. admit.
        split. admit. split. admit. split. admit. admit.
      -- intro. tauto.
  + case (invisible_dec mr d0 p).
    -- intro. simpl in *. split. tauto.
        admit.
    -- intro. case(invisible_dec mr d1 p).
        ++ intro. simpl in *. split. tauto.
            admit.
        ++ intro. tauto.
Qed.
Lemma CHID_inv_hmap: forall(mr:Hmap) (x:dart)(p:Point2D)(max:dart) ,
convex mr ->x<>nil -> (max > x /\ max > max_dart mr)%nat -> inv_hmap (CHID mr mr x p max).
Proof.
intros.
induction mr.
- simpl. unfold prec_I. tauto.
- simpl. case (blue_dart_dec (I mr d p0) d).
    + intro. case (invisible_dec (I mr d p0) d p).
        -- intro. simpl. split.
           ++ apply CHID_inv_hmap_h1.
Qed.

Lemma CHI_inv_hmap: forall(m mr:Hmap) ,
submap m mr -> inv_hmap mr -> convex mr ->
-> inv_hmap (CHI m mr x p max).
Proof.
intros.
induction m.
- simpl. auto.
- simpl. case (lt_dec (max_dart m) d).
  + intros. induction mr.
    -- simpl. admit.
    -- remember (I mr d0 p0) as t in *. simpl. case (blue_dart_dec (I mr d0 p0) d0).
       ++ intro.  case(invisible_dec (I mr d0 p0) d0 p).
            --- intro. unfold CHID. simpl.
  + unfold CHID.  case (blue_dart_dec (I t d0 p0) d0).
  -- intro. case (invisible_dec (I t d0 p0) d0 p).
     ++ intros. fold CHID. case (invisible_dec (I t d p) d p).
        --- intros. case(invisible_dec (I t d p) d p0).
            +++ intros.
Qed.
Theorem inv_hmap_CH : forall (m:Hmap),
prec_CH m -> inv_hmap (CH m).
Proof.
intros.
induction m.
- unfold CH. unfold prec_CH in H. tauto.
-  unfold CH.
    case m in *.
   + simpl.  unfold prec_CH in H. tauto.
    + simpl. case (lt_dec (if lt_dec (max_dart m) d0 then d0 else max_dart m)).
      -- intro.  case (lt_dec (max_dart m)) in l.
          ++ unfold .  admit.
          ++ admit.
      --  intros. case (if lt_dec (max_dart m) d0 then d0 else max_dart m).
          ++ admit.
          ++ intros. admit.
    + admit.
- simpl. tauto.
Qed.
Theorem exd_CH : forall (m:fmap)(d:dart), prec_CH m ->
exd m d -> exd (CH m) d /\ fpoint m d = fpoint (CH m) d.

Theorem one_left : forall (m:fmap)(p:point)(x:dart)(y:dart),
inv_hmap m -> inv_poly m -> well_emb m ->
inv_noncollinear_points m p -> convex m ->
left_dart m p x -> left_dart m p y -> x = y.

Theorem exd_left_dart_exd_right_dart :
forall (m:fmap)(px:point), inv_hmap m -> inv_poly m ->
(exists da:dart, exd m da /\ left_dart m px da) ->
(exists db:dart, exd m db /\ right_dart m px db).

Lemma blue_dart_not_right_dart_until_i_visible_i :
forall (m:fmap)(d:dart)(p:point)(i:nat), inv_hmap m ->
inv_poly m -> exd m d -> blue_dart m d -> visible m d p ->
let iter0 := (A m zero (Iter (cF m) j d)) in
(forall (j:nat), j <= i -> ~ right_dart m p iter0) ->
visible m (Iter (cF m) i d) p.

Theorem well_emb_CH : forall (m:fmap),
prec_CH (m) -> well_emb (CH m).

Theorem inv_poly_CH : forall (m:Hmap),
prec_CH m -> inv_poly (CH m).

Theorem convex_CH : forall (m:fmap),
prec_CH m -> convex (CH m).