(**  Ordinals of the first and second class,
   After Kurt Schuttes book : Proof theory

 *)

(**   Pierre Casteran, Univ. Bordeaux and  LaBRI *)

From Coq Require Import Relations  Classical   Classical_sets.
From hydras Require Import  Well_Orders Lub Countable.

Import   Compare_dec  Coq.Sets.Image  PartialFun MoreEpsilonIota.

Declare Scope schutte_scope.

Set Implicit Arguments.

#[global] Hint Unfold In : schutte.
Arguments Included [U] _ _.
Arguments countable [U] _.
Arguments Same_set [U] _ _.

Delimit Scope schutte_scope with sch.
Open Scope schutte_scope.

(** *  Definitions *)

(**   The type of countable ordinal numbers  *)

(* begin snippet OrdDecl *)

Parameter Ord : Type.
Parameter lt : relation Ord.
Infix "<" := lt : schutte_scope.

Definition ordinal : Ensemble Ord := Full_set Ord.
Definition big0 alpha : Ensemble Ord := fun beta =>  beta < alpha.

#[global] Hint Unfold ordinal : schutte.

(* end snippet OrdDecl *)

(* begin hide *)
Lemma ordinal_ok : forall a : Ord, ordinal a.
Proof.
  split.
Qed.

(* end hide *)

#[global] Hint Resolve ordinal_ok : schutte.

(** * The three axioms by Schutte *)

(** First Schutte's axiom  : Ord is well-ordered wrt lt *)

(* begin snippet AX1 *)

Axiom AX1 : WO lt.
(* end snippet AX1 *)

#[global] Hint Resolve AX1 : schutte.

#[global] Instance WO_ord : WO  lt := AX1.

(** Stuff for using Coq.Logic.Epsilon *)
(* begin snippet inhOrd *)

Axiom inh_Ord : inhabited Ord.

#[ global ] Instance InH_Ord : InH Ord. (* .no-out *)
Proof. (* .no-out *)
  exact inh_Ord. (* .no-out *)
Qed. (* .no-out *)
(* end snippet inhOrd *)

#[ global ] Instance Inh_OSets : InH (Ensemble Ord).
Proof.
  split; apply Empty_set.
Qed.

#[ global ] Instance Inh_Ord_Ord : InH (Ord -> Ord).
Proof.
  split;  exact (fun (alpha:Ord) => alpha).
Qed.

#[global] Hint Resolve  AX1 Inh_Ord_Ord Inh_OSets inh_Ord : schutte.

Definition le := Le lt.

Infix "<=" := le : schutte_scope.

(** Second and third axioms from Schutte

A subset X of Ord is bounded iff X is countable *)

(* begin snippet AX23 *)

Axiom AX2 :
  forall X: Ensemble Ord,
    (exists a,  (forall y, In X y -> y < a)) ->
    countable X.

Axiom AX3 :
  forall X : Ensemble Ord,
    countable X ->
    exists a,  forall y, In X y -> y < a.

(* end snippet AX23 *)

(** * First definitions
*)

Definition ge alpha : Ensemble Ord := fun beta => alpha <= beta.

Definition Unbounded (X : Ensemble Ord) :=
  forall x: Ord,  exists y, In X y /\ x < y.

(* begin snippet zeroDef *)

Definition zero := the_least ordinal.
(* end snippet zeroDef *)

(* begin snippet succDef *)

Definition succ (alpha : Ord)
  := the_least (fun beta => alpha < beta).

(* end snippet succDef *)

(** Finite ordinals *)

(* begin snippet finiteDef *)

Fixpoint finite (i:nat) : Ord :=
  match i with 0 => zero
            | S i => succ (finite i)
  end.

Notation F i := (finite i).

Coercion finite : nat >-> Ord.

(* end snippet finiteDef *)

Definition is_finite  := seq_range finite.

(** ** Limits *)

(* begin snippet supDef *)

Definition sup_spec X lambda := is_lub ordinal lt X lambda.

Definition sup (X: Ensemble Ord) : Ord := the (sup_spec X).

Notation "'|_|' X" := (sup X) (at level 29) : schutte_scope.

(* end snippet supDef *)

(**  Limit of omega-sequences *)

(* begin snippet omegaDef *)

Definition omega_limit (s:nat->Ord) : Ord
  := |_| (seq_range s).

Definition _omega := omega_limit finite.

Notation omega := (_omega).

(* end snippet omegaDef *)

(** Successor and limit ordinals *)
(* begin snippet isSuccIsLimit *)

Definition is_succ (alpha:Ord)
  := exists beta, alpha = succ beta.

Definition is_limit (alpha:Ord)
  := alpha <> zero /\ ~ is_succ alpha.
(* end snippet isSuccIsLimit *)

(** Ordinals considered as sets *)

Definition members (a:Ord) := (fun b => b < a).

Definition set_eq (X Y: Ord -> Prop) := forall a,  (X a <-> Y a).

(** Induction (after Schutte) *)

Definition progressive (P : Ord -> Prop) : Prop :=
  forall a, (forall b,  b < a -> P b) -> P a.

(* begin snippet ClosedDef *)

Definition Closed (B : Ensemble Ord) : Prop :=
  forall M, Included M B -> Inhabited _ M -> countable M ->
                            In B (|_| M).

(* end snippet ClosedDef *)

Definition  continuous (f:Ord->Ord)(A B : Ensemble Ord) : Prop :=
  fun_codomain A B f /\
  Closed A /\
  (forall U, Included U A -> Inhabited _ U ->
             countable U -> |_| (image U f) = f (|_| U)).

(** *  Basic properties

*)

Lemma Unbounded_not_countable (X: Ensemble Ord) :
    Unbounded X -> not (countable X).
Proof.
  intros  H  H1; case (AX3 H1); intros x Hx.
  destruct (H x) as [x0 [H0 H2]].
  case (Lt_irreflexive (a:=x));  eapply (Lt_trans (WO:=AX1)); eauto.
Qed.

Lemma countable_not_Unbounded : forall X,
    countable  X -> not (Unbounded X).
Proof.
  red;intros; apply Unbounded_not_countable with X;auto.
Qed.

Lemma Progressive_Acc: progressive (Acc lt).
Proof.
  split; auto.
Qed.

Theorem transfinite_induction (P: Ord->Prop) : progressive P ->
                                 forall a,  P a.
Proof.
  intros Hp; case (classic  (forall a : Ord,  P a));
  [trivial|idtac].
  intro H; case (not_all_ex_not _ (fun a =>  P a) H).
  intros x Hx.
  assert False.
  {  case (well_order  (fun z => ~ P z) _ Hx (WO := AX1)).
     intros x0 H0; assert (forall b,  b < x0 -> P b).
     {  intros.
        case H0; intros H3 H5; apply NNPP.
        intro H6.  case (H5 _ H6).
        intro;subst x0.
        case (Lt_irreflexive  (a:=b));auto.
        intro; case (Lt_irreflexive   (a:=b)).
        eapply Lt_trans; eauto.
        exact AX1.
      }
     assert (~ (P x0)) by (case H0; unfold In; tauto).
     apply H2; apply Hp;auto.
  }
  contradiction.
Qed.

(** ** Properties of [le] and [lt] *)

Lemma le_refl : forall alpha,  alpha <= alpha.
Proof.
  left;auto.
Qed.

#[global] Hint Resolve le_refl : schutte.

Lemma eq_le : forall a b : Ord,  a = b -> a <= b.
Proof.
  left;auto.
Qed.

Lemma lt_le : forall a b: Ord, a < b -> a <= b.
Proof.
  right;auto.
Qed.

Lemma lt_trans : forall a b c : Ord, a < b ->  b < c -> a < c.
Proof.
  intros; eapply Lt_trans; eauto with schutte.
Qed.

Lemma le_lt_trans : forall a b c, a <= b -> b < c -> a < c.
Proof.
  apply Le_Lt_trans; eauto with schutte.
Qed.

Lemma lt_le_trans : forall a b c, a < b -> b <= c -> a < c.
Proof (Lt_Le_trans AX1).

Lemma le_trans : forall a b c, a <= b -> b <= c -> a <= c.
Proof (Le_trans AX1).

Lemma lt_irrefl : forall a, ~ (a < a).
Proof.
  intros a Ha; now apply ( @Lt_irreflexive  Ord  lt AX1 a).
Qed.

Lemma le_antisym : forall a b, a <= b -> b <= a -> a = b.
Proof (Le_antisym AX1).

Lemma le_eq_or_lt : forall a b, a <= b -> a = b \/ a < b.
Proof.
  intros a b [H |H];auto.
Qed.

Lemma le_not_gt : forall a b, a <= b -> ~ b < a.
Proof.
  intros a b H; case (le_eq_or_lt H).
  -  intro;subst b;apply lt_irrefl.
  -  intros H0 H1;case (@lt_irrefl a);eapply lt_trans;eauto.
Qed.

#[global] Hint Resolve eq_le lt_le lt_trans le_trans le_lt_trans
     lt_le_trans lt_irrefl le_not_gt:
  schutte.

Lemma le_disj : forall alpha beta, alpha <= beta ->
                                   alpha = beta \/ alpha < beta.
Proof.
  intros alpha beta H; destruct H; tauto.
Qed.

Lemma all_ord_acc : forall alpha : Ord,  Acc lt alpha.
Proof.
  intros alpha ;  pattern alpha;  apply transfinite_induction; auto.
  apply Progressive_Acc; auto.
Qed.

Lemma trichotomy : forall a b : Ord ,
                               a < b \/ a = b \/ b < a.
Proof (Lt_connect AX1).

(* begin hide *)

Ltac tricho t u Hname :=
                         case (@trichotomy t u);
                     [
                       intro Hname |
                       intros [Hname|Hname]].

(* end hide *)

Lemma lt_or_ge : forall a b: Ord, a < b \/ b <= a.
Proof.
  intros a b ; tricho a b H;auto with schutte.
Qed.

Lemma not_gt_le : forall a b,  ~ b < a  -> a <= b.
Proof.
  intros a b  H1; tricho a b H2; auto with schutte;  contradiction.
Qed.

#[global] Hint Unfold Included : schutte.

(** ** Global properties *)

Theorem Non_denum : ~ countable (Full_set Ord).
Proof.
  red; intro H; case (AX3  H); auto.
  intros x H0; case (@lt_irrefl x);apply H0; split.
Qed.

Lemma Inh_ord : Inhabited _ ordinal.
Proof.
  destruct inh_Ord as [x];  exists x; split.
Qed.

Theorem unbounded : forall alpha,  exists beta,  alpha < beta.
Proof.
  intros alpha ; pose (X0 := fun z =>  z < alpha).
  assert (countable X0).
  { apply AX2.
    unfold X0, Included, In; intuition.
    now exists alpha.
  }
  pose (X:= Add  _ X0 alpha).
  assert (countable X).
  {  unfold X; unfold Add; apply countable_union.
     auto.
     apply countable_singleton.
  }
  case (AX3  H0);  intros x Hx.
  assert (H1: X alpha).
  {
     unfold X; right; split.
   }
  specialize (Hx alpha H1);  exists x;auto.
Qed.

Lemma the_least_ok : forall X, Inhabited Ord X ->
                               forall a, In X a -> the_least X <= a.
Proof.
  intros X H a H0;   pattern X, (the_least X).
  unfold the_least, the;apply iota_ind.
  -  apply the_least_unicity.
    now exists a.
  - intros a0 H2;  destruct H2;  now apply H1.
Qed.

(** ** About zero *)

(* begin snippet zeroLe *)

Lemma zero_le (alpha : Ord) : zero <= alpha. (* .no-out *)
Proof. (* .no-out *)
  unfold zero, the_least, the; apply iota_ind.
  -  (* .no-out *) apply the_least_unicity, Inh_ord.
  -  (* .no-out *) destruct 1 as [[_ H1] _]; apply H1; split.
Qed.

(* end snippet zeroLe *)

Lemma not_lt_zero : forall alpha,  ~ alpha < zero.
Proof.
  intros;apply le_not_gt; apply zero_le;auto.
Qed.

Lemma zero_or_greater : forall alpha : Ord,
    alpha = zero \/ exists beta, beta < alpha.
Proof.
  intros a; tricho zero a t;auto with schutte.
  -  right;exists zero;auto with schutte.
  -  case (not_lt_zero t).
Qed.

Lemma zero_or_positive : forall alpha,  alpha = zero \/ zero < alpha.
Proof.
  intros a ; tricho zero a t;auto with schutte;  case (not_lt_zero   t).
Qed.

(** **  Properties of successor *)

(* begin snippet succSpec *)

Definition succ_spec (alpha:Ord) :=
  least_member lt (fun z => alpha < z).
(* end snippet succSpec *)

(* begin snippet succOka *)

Lemma succ_ok :
  forall alpha,  succ_spec alpha  (succ alpha). (* .no-out *)
Proof. (* .no-out *)
  intro alpha; unfold succ, the_least, the; apply iota_spec.
  (* end snippet succOka *)

  (* begin snippet succOkb *)

  (*| .. coq:: no-out |*)
  destruct (@AX3 (Singleton _ alpha)).
  - apply countable_singleton.
  - unfold succ_spec; apply the_least_unicity; exists x; intuition.
Qed.
(*||*)
(* end snippet succOkb *)

(* begin snippet succProps *)

(*| .. coq:: no-out |*)

Lemma lt_succ (alpha : Ord): alpha < succ alpha.
Proof.
  destruct  (succ_ok  alpha); tauto.
Qed.

#[global] Hint Resolve lt_succ : schutte. (* .none *)

Lemma lt_succ_le (alpha beta : Ord):
  alpha < beta -> succ alpha <= beta.
Proof with eauto with schutte.
  intros  H;  pattern (succ alpha); apply the_least_ok ...
  exists (succ alpha); red;apply lt_succ ...
Qed.
(*||*)

Lemma lt_succ_le_2 (alpha beta : Ord):
  alpha < succ beta -> alpha <= beta. (* .no-out *)
 (*| .. coq:: none |*)
Proof.
  intro H;  tricho alpha beta t;eauto with schutte.
  case (@lt_irrefl alpha);  apply lt_le_trans with (succ beta).
  - assumption.
  - apply lt_succ_le;eauto with schutte.
Qed.
(*||*)

Lemma succ_mono (alpha beta : Ord):
  alpha < beta -> succ alpha < succ beta. (* .no-out *)
 (*| .. coq:: none |*)
Proof with eauto with schutte.
  intros; eapply le_lt_trans with beta  ...
  - eapply lt_succ_le ...
Qed.

Arguments succ_mono [ alpha beta].
(*||*)

Lemma succ_monoR (alpha beta : Ord) :
 succ alpha < succ beta -> alpha < beta. (* .no-out *)
 (*| .. coq:: none |*)
Proof.
  intro H;  tricho alpha beta t; auto with schutte.
  -  subst beta; case (@lt_irrefl (succ alpha)); eauto with schutte.
  - case (@lt_irrefl  (succ alpha)); eapply lt_trans;eauto.
    apply succ_mono;auto.
Qed.
(*||*)

Lemma succ_injection (alpha beta : Ord) :
  succ alpha = succ beta -> alpha = beta. (* .no-out *)
 (*| .. coq:: none |*)
Proof.
  intros  H; tricho alpha beta t;auto.
  - generalize (succ_mono t).
    rewrite H; intro; case (@lt_irrefl (succ beta));auto.
  - generalize (succ_mono  t).
   rewrite H; intro; case (@lt_irrefl (succ beta));auto.
Qed.
(*||*)

Lemma succ_zero_diff (alpha : Ord): succ alpha <> zero. (* .no-out *)
 (*| .. coq:: none |*)
Proof.
  intros  H; destruct (@not_lt_zero alpha).
  rewrite <- H; auto with schutte.
Qed.
(*||*)

Lemma zero_lt_succ : forall alpha,  zero < succ alpha. (* .no-out *)
 (*| .. coq:: none |*)
Proof.
  intros a;  apply le_lt_trans with a;eauto with schutte;
    apply zero_le;auto.
Qed.
(*||*)

Lemma lt_succ_lt (alpha beta : Ord) :
  is_limit beta ->  alpha < beta -> succ alpha < beta. (* .no-out *)
 (*| .. coq:: none |*)
Proof.
  intros (Hbeta, Hbeta') H;  case (lt_succ_le  H); [|auto].
  - intros H' ; subst ;  case Hbeta'.
    exists alpha;split; eauto with schutte.
Qed.
(*||*)

(* end snippet succProps *)

#[global] Hint Resolve zero_lt_succ zero_le : schutte.

(** Less than finite is finite ... *)

Lemma finite_lt_inv : forall i o,
    o < F i ->
    exists j:nat , (j<i)%nat /\ o = F j.
Proof.
  induction i.
  - simpl (F 0); intros ; destruct (not_lt_zero  H ).
  - simpl (F (S i));intros o H; destruct (@lt_succ_le_2 o (F i));
      auto with schutte.
    +  exists i; split; auto.
    + destruct (IHi o  H0) as [x [H1 H2]].
      exists x; case H1;auto with arith.
Qed.

Lemma finite_mono : forall i j, (i<j)%nat -> F i < F j.
Proof.
  induction 1.
  -  simpl (finite (S i)); auto with schutte.
  -  apply lt_trans  with (finite m);auto.
     simpl (finite (S m)); apply lt_succ; auto with schutte.
Qed.

#[global] Hint Resolve finite_mono : schutte.

Lemma finite_inj : forall i j, F i = F j -> i = j.
Proof.
  intros i j H; case (lt_eq_lt_dec i j).
  -  destruct 1.
     +  case (@lt_irrefl (F i)).
        *  pattern (F i) at 2 ; rewrite H.
           apply finite_mono;auto.
     + auto.
  -  intro;  case (@lt_irrefl (F i)).
     pattern (F i) at 1 ; rewrite H; apply finite_mono;auto.
Qed.

(**  ** Building limits *)

Lemma sup_exists : forall X, countable  X ->
                             ex (sup_spec  X).
Proof.
  intros X H; case (AX3 H); auto.
  intros x H'x;
  assert (H''x : forall y : Ord, X y -> y=x \/ lt y x) by  intuition.
  generalize  (@well_order   Ord lt  AX1
                             (fun z =>
                                (forall y,   X y -> y = z \/ y < z))
                             x ).
  intros H1; destruct H1 as [  x0 H0].
  {   red;  auto.  }
  exists x0; unfold least_member in H0; repeat split.
  -   case H0; intros; intuition.
        red in H1;   red;  intros; auto.
    -  intros y H1 H2;  decompose [and] H0.
       red in H2;  destruct (H4 y); auto.
       intros y0 H5;  specialize (H2 y0);  apply H2; auto with schutte.
Qed.

Lemma sup_unicity : forall X l l',
                      (countable  X /\ forall x, X x -> ordinal x) ->
                      sup_spec X l -> sup_spec X l' -> l = l'.
Proof.
  intros X l l' _ H H0; apply le_antisym.
  destruct H, H0; intuition.
  case (H4 l' H0);auto with schutte.
  destruct H, H0; intuition.
  case (H5 l H);auto with schutte.
Qed.

Lemma sup_spec_unicity (X:Ensemble Ord) (HX : countable X) :
  exists! u, sup_spec X u.
Proof.
  destruct (sup_exists  HX).
  exists x;split;auto.
  intros;  apply sup_unicity with   X;split;auto.
  1, 2, 4 : split.
  -  destruct H; tauto.
  - destruct H0; tauto.
Qed.

Lemma sup_ok1 (X: Ensemble Ord)(HX : countable X) :
  sup_spec X (sup X).
Proof.
  unfold sup, the;  apply iota_spec;  now apply sup_spec_unicity.
Qed.

Lemma sup_upper_bound (X : Ensemble Ord) (alpha : Ord):
  countable X ->  In X alpha -> alpha <= |_|  X.
Proof.
  intros  H  H1;  generalize (sup_ok1   H).
  intro H2;  destruct H2 as [H2 [H3 H4]].
  destruct (H3 alpha); auto with schutte.
Qed.

Lemma sup_least_upper_bound (X : Ensemble Ord) (alpha : Ord) :
  countable X -> (forall y, In X y -> y <= alpha) -> sup  X <= alpha.
Proof.
   intros  H H0;  specialize (sup_ok1   H) as H1.
    destruct H1 as [H1 [H2 H3]].
    destruct  (H3 alpha); auto with schutte.
    red;  intros;  apply H0; auto.
Qed.

Lemma sup_of_leq (alpha : Ord) :
    alpha = |_| (fun x : Ord =>  x <= alpha).
Proof.
 assert (DD :countable (fun x : Ord =>  x <= alpha)).
  {
    apply AX2.
    -   exists (succ alpha);
       destruct 1; apply le_lt_trans with alpha;auto with schutte.
  }
  apply le_antisym.
  - apply sup_upper_bound; auto with schutte.
  - apply sup_least_upper_bound;auto.
Qed.

Lemma sup_mono (X Y : Ensemble Ord) :
    countable X ->
    countable Y ->
    (forall x, In X x -> exists y, In Y y /\ x <= y) ->
|_| X <= |_| Y.
Proof.
  intros H H0 H1;
  apply sup_least_upper_bound; auto with schutte.
  intros x Hx; case (H1 x Hx); intros y (Hy,Hy').
  apply le_trans  with y;auto with schutte.
  apply sup_upper_bound;auto with schutte.
Qed.

Lemma sup_eq_intro (X Y : Ensemble Ord):
  countable X -> countable Y ->
  Included X Y -> Included Y X ->
|_| X = |_| Y.
Proof.
  unfold Included, In; intros; apply le_antisym;
    apply sup_mono;auto with schutte;
  intro x;exists x; unfold In;auto with schutte.
Qed.

Lemma lt_sup_exists_leq (X: Ensemble Ord) :
  countable X ->
  forall y, y < sup X ->
            exists x, In X x /\ y <= x.
Proof.
  intros;  case (not_all_not_ex _ (fun x =>  X x /\ y <= x)).
  -   intro H3;  unfold Included,In in H0.
      assert (forall n, X n -> n < y).
      { intros n H4;  apply NNPP; intro H5.
         assert (y < n).
        { case (@trichotomy n y); auto.
           - intro; case H5;auto.
           - destruct 1.
             +  subst n ; case (H3 y).
                auto with schutte.
             + auto.
         }
        case (H3 n).
        split;auto with schutte.
      }
      case ( @lt_irrefl y).
      eapply lt_le_trans with (|_|X);eauto.
      apply sup_least_upper_bound;auto with schutte.
  -  intros x Hx; exists x;auto.
Qed.

Lemma lt_sup_exists_lt (X : Ensemble Ord) :
  countable X ->
  forall y,  y < sup X -> exists x, In X x /\ y < x.
Proof.
  intros  H y H0;
  case (not_all_not_ex _ (fun x =>  X x /\ y < x)).
 -  red;intro H1;
      assert (forall n, X n -> n <= y).
    {  intros n H4; apply NNPP.
       intro H5.
       assert (y < n).
       { case (@trichotomy n y).
         -   intro H6;   case H5;auto with schutte.
         -  destruct 1.
            +   case H5;auto with schutte.
            +   auto.
       }
       case (H1 n); split;auto with schutte.
    }
    assert (sup X <= y).
    {  apply sup_least_upper_bound; auto. }
    case (@Lt_irreflexive Ord  lt AX1  y).
    eapply Lt_Le_trans;eauto with schutte.
 - intros x Hx; exists x;auto.
  Qed.

Lemma members_eq (alpha beta : Ord) :
  members alpha = members beta -> alpha = beta.
Proof.
  intros  H; tricho alpha beta H2; auto with schutte.
  -   assert (H0: members beta alpha) by auto.
      rewrite <- H in H0;  destruct (lt_irrefl H0);auto.
  - assert (H0: members alpha beta) by auto.
    rewrite  H in H0;  destruct (lt_irrefl H0);auto.
Qed.

Lemma sup_members_succ (alpha : Ord) :
  sup (members alpha) < alpha -> alpha = succ (|_| (members alpha)).
Proof.
  intros  H;pose (A := sup (members alpha)).
  fold A;  generalize (@lt_succ_le  A alpha).
  intros H0.
  case (le_eq_or_lt  (H0  H)).
  -   symmetry;auto.
  -  intro H3;   assert (succ A <= A).
     {
       unfold A;apply sup_upper_bound.
       - apply AX2; exists alpha;unfold members; auto.
       - assumption.
     }
     destruct (@lt_irrefl A); apply lt_le_trans with (succ A); auto.
    +     eapply lt_succ;auto.
Qed.

Lemma sup_members_not_succ (alpha beta : Ord) :
  alpha = sup (members alpha) ->  alpha <> succ beta.
Proof.
  intros   e e1;  generalize (sup_of_leq  beta).
  intro H; assert (sup (members alpha) = beta).
  {
    unfold members;rewrite H;
      apply sup_eq_intro.
    - apply AX2; exists alpha; auto.
    - apply AX2;  exists (succ beta);  intros y Hy;
       eauto with schutte.
    - red;   intros;  red; red in H0; rewrite e1 in H0.
      apply lt_succ_le_2;auto.
    -  unfold Included, In; intros x H1;  rewrite e1.
       eapply le_lt_trans;eauto with schutte.
  }
  case (@lt_irrefl alpha); pattern alpha at 2;rewrite e1, e, H0;
    auto with schutte.
Qed.

(** ** Sequences of ordinals *)

Definition seq_mono (s:nat -> Ord) :=
  forall i j, (i < j)%nat -> s i < s j.

Lemma seq_mono_intro (s: nat -> Ord) :
  (forall i, s i <  s (S i)) -> seq_mono s.
Proof.
  intros  H; unfold seq_mono; induction 1;  auto.
  apply (@Lt_trans Ord  lt AX1)  with (s m);auto.
Qed.

Lemma seq_mono_inj (s : nat -> Ord) :
  seq_mono s -> injective _ _ s.
Proof.
  unfold injective;intros  H i j H0.
  case (lt_eq_lt_dec i j).
  -   destruct 1; auto.
   + generalize (H _ _ l); auto.
     rewrite H0;intro;case (@Lt_irreflexive Ord  lt AX1  (s j));auto.
  - intro l;generalize (H _ _ l).
    rewrite H0;intro;case (@Lt_irreflexive  Ord lt AX1 (s j));auto.
Qed.

#[global] Hint Resolve Countable.seq_range_countable seq_mono_intro : schutte.

Lemma In_full {A:Type} (a:A) : In (Full_set A ) a.
Proof. split. Qed.

#[global] Hint Resolve In_full: core.

Lemma lt_omega_limit (s : nat -> Ord) :
  seq_mono s -> forall i, s i <  omega_limit s.
Proof.
  unfold omega_limit;intros.
  apply lt_le_trans with (s (S i)).
  -  eapply H;  auto.
  -  apply sup_upper_bound;auto with schutte.
     exists (S i);split;auto.
Qed.

Lemma omega_limit_least (s : nat -> Ord) :
    seq_mono s ->
    forall y : Ord,
      (forall i, s i < y) ->
      omega_limit s <=  y.
Proof.
  intros  H y  H1.
  unfold omega_limit;apply sup_least_upper_bound;auto with schutte.
  intro y0; destruct 1 as [x [_ e]]; subst y0;auto.
  right; auto.
Qed.

Lemma lt_omega_limit_lt_exists_lt (alpha : Ord) (s : nat -> Ord) :
  (forall i, s i < s (S i)) ->
  alpha < omega_limit s ->
  exists j, alpha < s j.
Proof.
  intros H H0;  unfold omega_limit in H0.
  assert (exists y, In (seq_range s) y /\ alpha <  y).
  apply lt_sup_exists_lt; auto with schutte.
  destruct H1 as [y [[j [_ Hj]] H'y]]; subst y; now exists j.
Qed.

Lemma omega_limit_least_gt (alpha : Ord) (s : nat -> Ord)
      (Hmono : forall i, s i < s (S i))
      (H : alpha < omega_limit s) :
  exists i, least_member Peano.lt (fun j =>  alpha <  s j) i.

Proof.
  destruct (lt_omega_limit_lt_exists_lt s Hmono H ) as [i Hi].
  destruct (well_order (fun i =>  alpha < s i) i) as [x Hx]; trivial.
  now  exists x.
Qed.

(** ** Properties of omega *)

(* begin snippet omegaPropsa:: no-out *)
Lemma finite_lt_omega (i : nat) : i < omega.
(* end snippet omegaPropsa *)
Proof.
   intros; apply lt_omega_limit; auto with schutte.
Qed.

(* begin snippet omegaPropsb:: no-out *)
Lemma zero_lt_omega : zero < omega.
Proof.
  change zero with (F 0); apply finite_lt_omega.
Qed.
(* end snippet omegaPropsb *)

(* begin snippet omegaPropsc:: no-out *)
Lemma lt_omega_finite (alpha : Ord) :
  alpha < omega ->  exists i:nat, alpha = i.
(* end snippet omegaPropsc *)
Proof.
  intro H0; unfold omega_limit in H0.
  generalize (lt_sup_exists_leq (X:=(seq_range finite))  ).
  intros;  assert (countable (seq_range finite)) by
    apply seq_range_countable.
  generalize (H H1);clear H;intros.
  generalize (H _ H0);clear H;intros.
  destruct H as [x [H2 H3]].
  destruct H2 as [x0 [_ e]].  subst x.
  destruct (le_disj H3).
  -  exists x0; auto.
  - destruct  (finite_lt_inv x0 H);auto.
    exists x; tauto.
Qed.

(* begin snippet omegaPropsd:: no-out *)
Lemma is_limit_omega : is_limit omega.
(* end snippet omegaPropsd *)
Proof.
  repeat split; auto with schutte.
  - intro H;  absurd (F 1 < zero).
    +   apply not_lt_zero;auto with schutte.
    +   rewrite <- H;   apply finite_lt_omega.
  - destruct 1 as [x Hx].
  assert (x < omega).
  {  rewrite Hx;auto with schutte. }
  destruct (lt_omega_finite  H); subst x.
  assert (omega = F (S x0)) by (simpl; trivial).
  case ( @lt_irrefl omega);auto with schutte.
  pattern omega at 1;rewrite H0;auto with schutte.
  apply finite_lt_omega;auto with schutte.
Qed.

(** ** About zero, is_succ and is_limit *)

Lemma not_is_succ_zero : ~ is_succ zero.
Proof.
   intros (b, Hb);  apply (succ_zero_diff  b); now symmetry.
Qed.

Lemma not_is_limit_zero : ~ is_limit zero.
Proof.
  unfold is_limit;   tauto.
Qed.

Lemma not_is_limit_succ (alpha : Ord) :  is_succ alpha -> ~ is_limit alpha.
Proof.
  unfold is_limit;tauto.
Qed.

Lemma not_is_succ_limit (alpha : Ord) : is_limit alpha -> ~ is_succ alpha.
Proof.
  unfold is_limit;tauto.
Qed.

(** ** About members *)

Lemma countable_members (alpha : Ord): countable (members alpha).
Proof.
 apply AX2;   now exists alpha.
Qed.

#[global] Hint Resolve countable_members : schutte.

Lemma le_sup_members (alpha : Ord) :  |_| (members alpha) <= alpha.
Proof.
  intros; apply sup_least_upper_bound; auto with schutte.
Qed.

Lemma is_limit_sup_members (alpha : Ord) :
  is_limit alpha -> alpha = |_| (members alpha).
Proof.
  intros;  case (@le_sup_members alpha);auto with schutte.
  intro H0;  generalize (@sup_members_succ alpha).
  intros H1 ;  destruct  (not_is_limit_succ (alpha:=alpha));auto with schutte.
  exists (|_|members alpha); auto.
Qed.

Lemma sup_members_disj (alpha : Ord) :
  alpha = sup (members alpha) ->
  alpha = zero \/ is_limit alpha.
Proof.
  intro H;  unfold is_limit.
  case (classic (alpha=zero)).
  -   auto.
  -  right;repeat split;auto.
      red; destruct 1 as [x Hx].
      case (sup_members_not_succ  x H Hx).
Qed.

Theorem classification (alpha : Ord) :
  alpha = zero \/ is_succ alpha \/  is_limit alpha.
Proof.
 case (le_sup_members  alpha).
  - intro H;  symmetry in H; case (sup_members_disj  H);auto with schutte.
  -  right; left; exists (sup (members alpha));
       apply sup_members_succ;auto.
Qed.

(**   ** Extensional equalities on sets of ordinals *)

Lemma members_omega :  Same_set (members omega) is_finite.
Proof.
  unfold Same_set;split;
      red; unfold members, In.
  - intros x Hx; case (lt_omega_finite  Hx); intros x0; exists x0; auto.
  -   destruct 1 as [n [_ Hn]];   subst ;auto with schutte.
      apply finite_lt_omega.
Qed.

Lemma Not_Unbounded_bounded (X: Ensemble Ord):
   ~ Unbounded X ->
   exists beta : Ord, forall x, In X x -> x < beta.
Proof.
  intros  H; apply NNPP; intro H0.
  assert (forall beta,  exists x, In X x /\ beta <= x).
  { intros beta;  change (exists x:Ord, (fun y => In X y /\ beta <= y) x).
  apply not_all_not_ex.
  intro H1;  case H0;  exists beta; auto.
  - intros x H2;  tricho x beta H5;auto with schutte.
   +  case (H1 x).
      split;auto with schutte.
   +  case (H1 x);split;auto with schutte.
  }
  clear H0;  case H; intro x.
  destruct (H1 (succ x)) as [y [H2 H3]].
  exists y;split;auto with schutte.
  apply lt_le_trans with (succ x); auto with schutte.
Qed.

Lemma Not_Unbounded_countable (X : Ensemble Ord) :
  ~ Unbounded X ->   countable X.
Proof.
  intros;eapply AX2;eauto.
  case (Not_Unbounded_bounded H);auto.
  intros x H0; exists x;auto.
Qed.

Lemma not_countable_unbounded (X : Ensemble Ord):
    ~ countable X -> Unbounded X.
Proof.
  intros H;  apply NNPP; intro H0.
  apply H,  Not_Unbounded_countable;auto.
Qed.

Lemma le_alpha_zero (alpha : Ord) :
  alpha <= zero -> alpha = zero.
Proof.
  intros H;  apply le_antisym;auto.
  apply zero_le.
Qed.

Lemma finite_not_limit (i: nat): ~ is_limit i.
Proof.
 destruct i.
 -  simpl; apply not_is_limit_zero.
 -  simpl. intros [_ H0]; apply H0;   now exists (F i).
Qed.

(* begin hide *)

Module iota_demo.

  (* begin snippet iotaDemoa:: no-out  *)
  Remark R : exists! z : Ord, least_member lt  ordinal z.
  Proof.
    destruct inh_Ord as [a ];
      apply least_member_ex_unique with a.
    - apply AX1.
    - split.
  Qed.
  (* end snippet iotaDemoa *)

 (* begin snippet iotaDemob *)
  Definition zero : Ord. (* .no-out *)
  Proof. (* .no-out *)
    Fail destruct R.
  Abort.

  (* end snippet iotaDemob *)

(* end hide *)

Definition zero: Ord := iota inh_Ord (least_member lt ordinal).

Lemma zero_le (alpha : Ord) :  zero <= alpha.
Proof.
  generalize (iota_spec inh_Ord _ R).
  destruct 1 as [_ H]; apply H; split.
Qed.

(* begin snippet BadBottoma:: no-out *)
Module Bad.

  Definition bottom := the_least (Empty_set Ord).
(* end snippet BadBottoma *)

  (* begin snippet trivialProps:: no-out *)
  Lemma le_zero_bottom : zero <= bottom.
  Proof. apply zero_le. Qed.

  Lemma bottom_eq : bottom = bottom.
  Proof. trivial. Qed.
  (* end snippet trivialProps *)

  (* begin snippet Failure *)
  Lemma le_bottom_zero : bottom <= zero. (* .no-out *)
  Proof. (* .no-out *)
    unfold bottom, the_least, the; apply iota_ind.
  Abort.

End Bad.
(* end snippet Failure *)

End iota_demo.


Require Import HoTT.
Require Import FunextAxiom.

From GCTT Require Import conn_ptype.

(* Making an induction principle for pointed connected 1-types, based on notes by Thierry Coquand *)

Section deloop_induction.
  Context (X : Conn_pType) .
  (* Context (X : Type) (x0 : X) (* (istrunc_X : IsTrunc 1 X) *) *)
  (*         `{isconn_X : forall (x : X), merely (x0 = x)}. *)

  Context (Y : X -> Type)
          `{istrunc_Y : forall x : X, IsTrunc 1 (Y x)}
          (y0 : Y (point X))
          (f : forall (ω : point X = point X), transport Y ω y0 = y0)
          (ishom_f : forall (α ω : point X = point X),
              f (α @ ω) =
              transport_pp Y  α ω y0 @ ap (transport Y ω) (f α) @ (f ω)).
  Lemma ishom_f_1 :
    f idpath = idpath.
  Proof.
    apply (equiv_inj (concat (f idpath))).
    refine (_ @ (concat_p1 _)^).
    apply inverse.
    refine (ishom_f idpath idpath @ _).
    apply whiskerR. simpl.
    refine (concat_1p _ @ _).
    apply ap_idmap.
  Qed.

  Definition C (x : X) (y : Y x) :=
    {p : forall (ω : point X = x),
        transport Y ω y0 = y &
        forall (α : point X = point X) (ω : point X = x),
          p (α @ ω) =
          transport_pp Y α ω _ @ ap (transport Y ω) (f α) @ p (ω)}.

  Lemma p_is_f (y : Y (point X)) (p : C (point X) y) (α : (point X) = (point X)) :
    p.1 α = f α @ (p.1 idpath).
  Proof.
    destruct p as [p H]. simpl.
    refine ((apD p (concat_p1 α))^ @ _).
    refine (transport_paths_Fl (concat_p1 α) (p (α @ 1)) @ _).
    apply moveR_Vp.
    refine (H α idpath @ _).
    refine (_ @ concat_pp_p _ _ _ ). apply whiskerR.
    apply concat2.
    + destruct α. reflexivity.
    + destruct (f α). reflexivity.
  Qed.

  Definition C_base : forall y : Y (point X), (C (point X) y) <~> y0 = y.
  Proof.
    intro y.
    srapply @equiv_adjointify.
    - intros [p H].
      exact (p idpath).
    - intro p0.
      exists (fun ω => f ω @ p0).
      intros.
      refine (_ @ concat_pp_p _ _ _). apply whiskerR.
      apply ishom_f.
    - intro p0.
      refine (_ @ concat_1p _). apply whiskerR.
      apply ishom_f_1.
    - intros [p H].
      apply path_sigma_hprop. simpl.
      apply path_forall. intro α.
      apply inverse.
      apply (p_is_f y (p; H)).
  Defined.

  Instance contr_C :
    forall (x : X), Contr {y : Y x & C x y}.
  Proof.
    intro x.
    generalize (isconn_conn_ptype X x).
    (* Being contractible is a proposition, so we can assume that X is a single point *)
    apply Trunc_rec. intros [].
    apply (contr_equiv' {y : Y (point X) & y0 = y}).
    { apply equiv_functor_sigma_id. intro y.
      apply equiv_inverse.
      apply C_base. }
    apply contr_basedpaths.
  Defined.

  Definition deloop_ind : forall (x : X), Y x
    := fun x => pr1 (center _ (contr_C x)).

  Definition deloop_ind_p (x : X) : forall ω : (point X) = x, transport Y ω y0 = deloop_ind x
    := pr1 (pr2 (center {y : Y x & C x y} )).

  Lemma p_is_apD_ind :
    forall (x x': X) (α : (point X) = x) (β : x = x'),
      deloop_ind_p x' (α @ β) =
      transport_pp Y α β _ @ ap (transport Y β) (deloop_ind_p x α) @ apD deloop_ind β.
  Proof.
    intros. destruct β. destruct α. simpl.
    destruct (deloop_ind_p (point X) idpath). reflexivity.
  Qed.

  Definition deloop_ind_beta_pt : deloop_ind (point X) = y0 :=
    (deloop_ind_p (point X) idpath)^.

  Definition deloop_ind_beta_loop : forall (ω : (point X) = (point X)),
      (ap (transport Y ω) deloop_ind_beta_pt)^ @ apD deloop_ind ω @ deloop_ind_beta_pt = f ω.
  Proof.
    intro. apply moveR_pM. unfold deloop_ind_beta_pt.
    rewrite ap_V. rewrite inv_V. rewrite inv_V.
    refine (_ @ p_is_f _ _ ω).
    change ((center {y : Y (point X) & C (point X) y}).2).1 with (deloop_ind_p (point X)).
    apply inverse.
    rewrite <- (concat_1p ω).
    refine ((p_is_apD_ind (point X) (point X) idpath ω) @ _).
    simpl. revert ω.
    cut (forall (x : X) (ω : point X = x),
            (transport_pp Y 1 ω y0 @ ap (transport Y ω) (deloop_ind_p (point X) 1)) @ apD deloop_ind ω =
            ap (transport Y (1 @ ω)) (deloop_ind_p (point X) 1) @ apD deloop_ind (1 @ ω)).
    { intro H. apply H. }
    intros x [].
    simpl. destruct (deloop_ind_p (point X) idpath).
    reflexivity.
  Qed.
End deloop_induction.

Section deloop_ind_prop.
  Context (X : Conn_pType).
  Context (Y : X -> hProp)
          (y0 : Y ((point X))).

  Definition deloop_ind_prop : forall x : X, Y x.
  Proof.
    intro x.
    generalize (isconn_conn_ptype X x).
    apply Trunc_ind.
    { exact _. }
    intros []. exact y0.
  Defined.
End deloop_ind_prop.

Section deloop_ind_set.
  Context (X : Conn_pType).

  Context (Y : X -> Type)
          `{isset_y : forall x : X, IsHSet (Y x)}
          (y0 : Y ((point X)))
          (f : forall (ω : (point X) = (point X)), transport Y ω y0 = y0).

  Definition deloop_ind_set : forall x : X, Y x.
  Proof.
    apply (deloop_ind X Y y0 f).
    intros.
    apply isset_y.
  Defined.
End deloop_ind_set.

Section deloop_rec.
  Context (X : Conn_pType).

  Context (Y : Type)
          `{istrunc_y : IsTrunc 1 Y}
          (y0 : Y)
          (f : ((point X) = (point X)) -> (y0 = y0))
          (ishom_f : forall (α ω : (point X) = (point X)),
              f (α @ ω) = f α @ f ω).

  Lemma rec_help (α ω : (point X) = (point X)) :
    transport_const (α @ ω) y0 @ f (α @ ω) =
    (transport_pp (fun _ : X => Y) α ω y0
                  @ ap (transport (fun _ : X => Y) ω) (transport_const α y0 @ f α))
      @ (transport_const ω y0 @ f ω).
  Proof.
    rewrite ishom_f.
    destruct (f ω). destruct (f α).
    destruct ω. destruct α. reflexivity.
  Qed.

  Definition deloop_rec : X -> Y :=
    deloop_ind X (fun _ => Y) y0 (fun ω => transport_const ω y0 @ f ω) rec_help.

  Definition deloop_rec_beta_pt : deloop_rec (point X) = y0 :=
    deloop_ind_beta_pt X _ _ _ _ .

  Definition deloop_rec_beta_loop (ω : (point X) = (point X)) :
    deloop_rec_beta_pt^ @ ap deloop_rec ω @ deloop_rec_beta_pt = f ω.
  Proof.
    apply (cancelL (transport_const ω y0)).
    refine (_ @ deloop_ind_beta_loop X (fun _ => Y) y0
              (fun ω => transport_const _ _ @ f ω) rec_help ω).
    change (deloop_ind X (fun _ => Y) y0 (fun ω => transport_const ω y0 @ f ω) rec_help)
    with deloop_rec.
    change (deloop_ind_beta_pt X
                               (fun _ : X => Y) y0
                               (fun ω0 : (point X) = (point X) => transport_const ω0 y0 @ f ω0) rec_help)
    with deloop_rec_beta_pt.
    generalize (deloop_rec_beta_pt). intros []. simpl.
    revert ω.
    cut (forall (x : X) (ω : point X = x),
            transport_const ω (deloop_rec (point X)) @ ((1 @ ap deloop_rec ω) @ 1) =
            (1 @ apD deloop_rec ω) @ 1).
    { intro H. apply H. }
    intros x []. reflexivity.
  Qed.

  Definition deloop_rec_beta_loop' (ω : (point X) = (point X)) :
    ap deloop_rec ω = deloop_rec_beta_pt @ f ω @ deloop_rec_beta_pt^.
  Proof.
    apply moveL_pV. apply moveL_Mp.
    refine (concat_p_pp _ _ _ @ _).
    apply deloop_rec_beta_loop.
  Qed.

End deloop_rec.

Section universal.
  (** Showing a universal principle for connected pointed types. *)
  Context (X : Conn_pType).
  Context (Y : Type) `{istrunc_y : IsTrunc 1 Y}.

  Definition rec_of (g : X -> Y) : X -> Y.
  Proof.
    apply (deloop_rec X Y (g (point X)) (fun ω => ap g ω)).
    intros. apply ap_pp.
  Defined.

  Definition is_rec (g : X -> Y) :
    rec_of g == g.
  Proof.
    intro x. revert x.
    srapply (deloop_ind_set X); simpl.
    - simpl. apply deloop_rec_beta_pt.
    - simpl. intros.
      refine (transport_paths_FlFr ω _ @ _).
      refine (concat_pp_p _ _ _ @ _).
      apply moveR_Vp.
      apply moveR_Mp. apply inverse.
      refine (concat_p_pp _ _ _ @ _).
      refine (deloop_rec_beta_loop X Y (g (point X))
                                   (fun ω0 : (point X) = (point X) => ap g ω0)
                                   (fun α ω0 : (point X) = (point X) => ap_pp g α ω0) ω).
  Defined.

  Definition deloop_rec_uncurried :
    {y0 : Y &
          {f : ((point X) = (point X)) -> (y0 = y0) &
                forall (α ω : (point X) = (point X)), f (α @ ω) = f α @ f ω}} -> X -> Y.
  Proof.
    intros [y0 [f ishom_f]]. exact (deloop_rec X Y y0 f ishom_f).
  Defined.

  Definition isequiv_deloop_rec_uncurried : IsEquiv deloop_rec_uncurried.
  Proof.
    srapply @isequiv_adjointify.
    - intro g.
      exists (g (point X)). exists (fun ω => ap g ω). intros. apply ap_pp.
    - intro g. apply path_arrow.
      apply (is_rec g).
    - intros [y0 [f ishom_f]].
      srapply @path_sigma.
      + simpl. apply deloop_rec_beta_pt.
      + simpl. srapply @path_sigma_hprop. simpl.
        apply path_forall. intro ω.
        refine (_ @ deloop_rec_beta_loop X Y y0 f ishom_f ω).
        generalize (deloop_rec_beta_pt X Y y0 f ishom_f). intros [].
        simpl.
        rewrite concat_1p. rewrite concat_p1. reflexivity.
  Defined.

  Definition path_deloop
             (f g : X -> Y)
             (p : f (point X) = g (point X))
             (eq_ap : forall w : (point X) = (point X), ap f w = p @ ap g w @ p^)
    : f == g.
  Proof.
    intro x. revert x.
    srapply (deloop_ind_set X).
    - simpl. exact p.
    - intro. simpl.
      refine (transport_paths_FlFr _ p @ _).
      rewrite eq_ap.
      rewrite inv_pp. rewrite inv_V.
      rewrite inv_pp. rewrite concat_p_pp.
      rewrite concat_pV_p. rewrite concat_pV_p. reflexivity.
  Defined.

  Definition path_deloop_id (f : X -> Y) (x : X) :
    path_deloop f f idpath (fun w => inverse (concat_p1 _ @ concat_1p (ap f w))) x = idpath.
  Proof.
    revert x.
    apply (deloop_ind_prop X). simpl.
    refine (deloop_ind_beta_pt X _ _ _ _ ).
  Qed.

End universal.

Section pointed_rec.
  (** Reformulate for pointed maps.  *)
  Context (X : Conn_pType).
  Context (Y : pType) {istrunc_y : IsTrunc 1 Y}.

  Definition equiv_deloop_prec :
    {f : loops X -> loops Y & forall α ω : loops X, f (α @ ω) = f α @ f ω} <~> pMap X Y.
  Proof.
    refine (issig_pmap X Y oE _).
    transitivity
      {a : {y : Y & {f : loops X -> y = y &
                                    forall α ω : loops X, f (α @ ω) = f α @ f ω}} & point Y = pr1 a}.
    - srapply @equiv_adjointify.
      + intros [f ishom_f].
        srapply @exist.
        *  exists (point Y).
           exists f. exact ishom_f.
        * reflexivity.
      + intros [[y [f ishom]] p].
        simpl in p.  destruct p.
        exact (f; ishom).
      + intros [[y [f ishom]] p]. simpl in p. destruct p.
        reflexivity.
      + intros [f ishom_f]. reflexivity.
    - srapply @equiv_functor_sigma'.
      + exact (BuildEquiv _ _ (deloop_rec_uncurried X  Y)
                          (isequiv_deloop_rec_uncurried X Y)).
      + simpl.
        intros [y [f ishom]].
        refine (equiv_path_inverse _ _ oE _).
        apply equiv_concat_r.
        simpl. apply inverse. unfold deloop_rec_uncurried.
        apply deloop_rec_beta_pt.
  Defined.

  Definition deloop_prec (f : loops X -> loops Y)
             (ishom_f : forall α ω : loops X, f (α @ ω) = f α @ f ω) :
    pMap X Y.
  Proof.
    apply (Build_pMap X Y (deloop_rec X Y (point Y) f ishom_f)).
    apply deloop_rec_beta_pt.
  Defined.

  Lemma deloop_prec_eq_equiv_dloop_prec (f : loops X -> loops Y)
             (ishom_f : forall α ω : loops X, f (α @ ω) = f α @ f ω) :
    deloop_prec f ishom_f = equiv_deloop_prec (f; ishom_f).
  Proof.
    simpl. rewrite concat_1p. rewrite inv_V.
    reflexivity.
  Qed.

End pointed_rec.

Require Import monoids_and_groups.
Section functor_deloop.
  Context (X : Conn_pType) `{istrunc_X : IsTrunc 1 X}.
  Context (Y : pType) `{istrunc_Y : IsTrunc 1 Y}.

  Definition equiv_functor_deloop'
    : Homomorphism (loopGroup X (point X)) (loopGroup Y (point Y)) <~> pMap X Y.
  Proof.
    refine (equiv_deloop_prec X Y oE _).
    srapply @equiv_adjointify.
    - intros [f f_id f_mult]. exact (f; f_mult).
    - intros [f f_mult].
      apply (@Build_GrpHom (loopGroup X _) (loopGroup Y _) f f_mult).
    - intro f.
      apply path_sigma_hprop. reflexivity.
    - intro f. apply path_hom. reflexivity.
  Defined.

  Definition functor_deloop : Homomorphism (loopGroup X (point X)) (loopGroup Y (point Y)) -> pMap X Y.
  Proof.
    intros [f f_1 f_mult]. simpl in f_mult.
    srapply @Build_pMap.
    - apply (deloop_rec X Y (point Y) f f_mult).
    - apply deloop_rec_beta_pt.
  Defined.

  Definition functor_loop : pMap X Y -> Homomorphism (loopGroup X (point X)) (loopGroup Y (point Y)).
  Proof.
    intro f.
    srapply @Build_GrpHom.
    - apply (loops_functor f).
    - simpl. destruct (point_eq f).
      intros. destruct g2. destruct g1. reflexivity.
  Defined.

  Global Instance isequiv_functor_loop : IsEquiv functor_loop.
  Proof.
    apply (isequiv_adjointify functor_loop functor_deloop).
    - intro f. apply path_hom. apply path_arrow.
      intro w. simpl in w. destruct f as [f f_1 f_mult]. simpl.
      rewrite deloop_rec_beta_loop'. hott_simpl.
    - intro f. apply path_pmap.
      srapply @Build_pHomotopy.
      + srapply (path_deloop X ).
        { refine (deloop_rec_beta_pt X _ _ _ _@ (point_eq f)^). }
        intro w.
        refine (deloop_rec_beta_loop' X Y (point Y) _ _ w @ _).
        pointed_reduce.
        reflexivity.
      + apply moveR_pM.
        refine (deloop_ind_beta_pt X  _ _ _ _ ).
  Defined.

  Definition equiv_functor_loop
    : pMap X Y <~> Homomorphism (loopGroup X (point X)) (loopGroup Y (point Y))
    := BuildEquiv _ _ functor_loop _.

  Definition functor_deloop_loop
             (f : Homomorphism (loopGroup X (point X)) (loopGroup Y (point Y)))
    : loops_functor (functor_deloop f) == f.
  Proof.
    intro ω. unfold loops_functor. simpl.
    refine (concat_p_pp _ _ _ @ _). apply deloop_rec_beta_loop.
  Defined.

End functor_deloop.

  Lemma functor_loop_id (X : Conn_pType)
        `{istrunc_X : IsTrunc 1 X} :
    functor_loop X X (@pmap_idmap X) == idhom.
  Proof.
    unfold functor_loop. simpl. intros []. reflexivity.
  Defined.

  Lemma functor_loop_compose
        (X : Conn_pType)  `{istrunc_X : IsTrunc 1 X}
        (Y : Conn_pType) `{istrunc_Y : IsTrunc 1 Y}
        (Z : pType) `{istrunc_Z : IsTrunc 1 Z}
        (f : pMap X Y) (g : pMap Y Z)
    : functor_loop Y Z g oH functor_loop X Y f ==
      functor_loop X Z (pmap_compose g f).
  Proof.
    unfold functor_loop. simpl. intro p.
    pointed_reduce.
    apply inverse. apply ap_compose.
  Qed.

Section functor_deloop_id.
  Context (X : Conn_pType)  `{istrunc_X : IsTrunc 1 X}.
  Definition functor_deloop_id :
    (functor_deloop X X idhom) = @pmap_idmap X.
  Proof.
    apply (equiv_inj (functor_loop X X)).
    refine (eisretr (functor_loop X X) idhom @ _).
    apply inverse.
    apply path_hom. apply path_arrow.
    apply functor_loop_id.
  Defined.
End functor_deloop_id.

Section functor_deloop_compose.
  Context (X : Conn_pType) `{istrunc_X : IsTrunc 1 X}.
  Context (Y : Conn_pType) `{istrunc_Y : IsTrunc 1 Y}.
  Context (Z : pType) `{istrunc_Z : IsTrunc 1 Z}.

  Open Scope monoid_scope.
  Definition functor_deloop_compose
             (f : Homomorphism (loopGroup X (point X)) (loopGroup Y (point Y)))
             (g : Homomorphism (loopGroup Y (point Y)) (loopGroup Z (point Z))) :
    (functor_deloop X Z (g oH f)) =
    (pmap_compose (functor_deloop Y Z g)
                  (functor_deloop X Y f)).
  Proof.
    apply (equiv_inj (functor_loop X Z)).
    refine (eisretr (functor_loop X Z) (g oH f) @ _).
    apply path_hom. apply path_arrow. intro x.
    refine (_ @ functor_loop_compose _ _ _ _ _ _).
    apply inverse.
    apply (ap011 (fun a b => (a oH b) x)).
    - refine (eisretr (functor_loop Y Z) g).
    - refine (eisretr (functor_loop X Y) f).
  Qed.
End functor_deloop_compose.

(* Section deloop_double_rec. *)
(*     Context (X1 : Type) (a : X1)  *)
(*           (isconn_X1 : forall (x : X1), merely (a = x)). *)
(*     Context (X2 : Type) (b : X2)  *)
(*             (isconn_X2 : forall (x : X2), merely (b = x)). *)
(*     Context (Y : 1-Type) *)
(*             (y0 : Y) *)
(*             (fl : a = a -> y0 = y0) *)
(*             (ishom_fl : forall (α ω : a = a), *)
(*                 fl (α @ ω) = fl α @ fl ω) *)
(*             (fr : b = b -> y0 = y0) *)
(*             (ishom_fr : forall (α ω : b = b), *)
(*                 fr (α @ ω) = fr α @ fr ω) *)
(*             (natl_flr : forall (α : a = a) (ω : b = b), *)
(*                 fl α @ fr ω = fr ω @ fl α). *)

(*     Definition deloop_double_rec : X1 -> X2 -> Y. *)
(*     Proof. *)
(*       srefine (deloop_rec X1 a isconn_X1 _ _ _ _). *)
(*       - simpl. *)
(*         exact (deloop_rec X2 b isconn_X2 Y y0 fr ishom_fr). *)
(*       - intro α. apply path_arrow. intro x2. revert x2. *)
(*         srefine (deloop_ind_set X2 b isconn_X2 _ _ _ ). *)
(*         + simpl. *)
(*           refine *)
(*             (deloop_rec_beta_x0 X2 b isconn_X2 Y y0 fr ishom_fr @ _ @ *)
(*                                 (deloop_rec_beta_x0 _ _ _ _ _ _ _ )^). *)
(*           exact (fl α). *)
(*         + intro. simpl.  *)
(*           refine (transport_paths_FlFr  _ _ @ _). *)
(*           rewrite *)
(*             (moveL_Mp _ _ _ (moveL_pV _ _ _ (deloop_rec_beta_loop X2 b isconn_X2 Y y0 fr ishom_fr ω))). *)
(*           generalize ((deloop_rec_beta_x0 X2 b isconn_X2 Y y0 fr ishom_fr)). *)
(*           intro p. *)
(*           rewrite inv_pp. rewrite inv_pp. rewrite inv_V. *)
(*           repeat rewrite concat_p_pp. *)
(*           apply whiskerR. apply moveR_pM. *)
(*           repeat rewrite concat_pp_p. apply whiskerL. *)
(*           apply moveR_Vp. *)
(*           rewrite concat_Vp. rewrite concat_p1. *)
(*           rewrite concat_V_pp. *)
(*           rewrite concat_p_pp. apply moveL_pV. apply natl_flr. *)
(*       - simpl. intros. *)
(*         apply (ap (path_arrow (deloop_rec X2 b isconn_X2 Y y0 fr ishom_fr) (deloop_rec X2 b isconn_X2 Y y0 fr ishom_fr))). *)
(*         apply (istrunc_trunctype_type Y). *)

(*           generalize *)
(*             ((deloop_rec_beta_x0 X2 b isconn_X2 Y y0 fr ishom_fr @ fl α) *)
(*                @ (deloop_rec_beta_x0 X2 b isconn_X2 Y y0 fr ishom_fr)^). *)
(*           generalize (ap (deloop_rec X2 b isconn_X2 Y y0 fr ishom_fr) ω ). *)
(*           repeat rewrite concat_p_pp. *)
(*           destruct ((ap (deloop_rec X2 b isconn_X2 Y y0 fr ishom_fr) ω)). *)

(*       intros x1. *)

(*           (y0 : Y) *)
(*           (f : (x0 = x0) -> (y0 = y0)) *)
(*           (ishom_f : forall (α ω : x0 = x0), *)
(*               f (α @ ω) = f α @ f ω). *)

(* End deloop_double_rec. *)

Section deloop_double_ind_set.
  Context (X1 : Conn_pType).
  Context (X2 : Conn_pType).

  Context (Y : X1 -> X2 -> 0-Type)
          (y0 : Y (point X1) (point X2))
          (fr : forall (ω : (point X2) = (point X2)), transport (Y (point X1)) ω y0 = y0)
          (fl : forall (ω : (point X1) = (point X1)), transport (fun x1 => Y x1 (point X2)) ω y0 = y0).

  Definition deloop_double_ind_set : forall (x1 : X1) (x2 : X2), Y x1 x2.
  Proof.
    intros x1.
    simple refine (deloop_ind_set X2 (fun x2 => Y x1 x2) _ _).
    - exact (deloop_ind_set X1 (fun x1 => Y x1 (point X2)) y0 fl x1).
    - simpl. intro.
      revert x1.
      apply (deloop_ind_prop X1). simpl.
      refine (_ @ fr ω @ _).
      + apply (ap (transport (fun x : X2 => Y (point X1) x) ω)).
        unfold deloop_ind_set.
        exact (deloop_ind_beta_pt X1
                   (fun x : X1 => Y x (point X2)) y0 _ _ ) .
      + apply inverse.
        unfold deloop_ind_set.
        exact (deloop_ind_beta_pt X1
                   (fun x : X1 => Y x (point X2)) y0 _ _).
  Defined.

  Definition deloop_double_ind_set_beta_pt :
    deloop_double_ind_set (point X1) (point X2) = y0.
  Proof.
    unfold deloop_double_ind_set. unfold deloop_ind_set.
    refine (deloop_ind_beta_pt X2 _ _ _ _ @ _).
    apply (deloop_ind_beta_pt X1 (fun x : X1 => Y x (point X2))).
  Defined.

End deloop_double_ind_set.

Section deloop_double_ind_set'.
  Context (X1 : Conn_pType).
  Context (X2 : Conn_pType).

  Context (Y : X1 -> X2 -> 0-Type)
          (y0 : Y (point X1) (point X2))
          (fl_fr : forall (ω1 : (point X1) = (point X1)) (ω2 : (point X2) = (point X2)),
              transport (uncurry Y) (path_prod (_,_) (_,_) ω1 ω2) y0 = y0).

  Definition deloop_double_ind_set' : forall (x1 : X1) (x2 : X2), Y x1 x2.
  Proof.
    intros x1 x2.
    simple refine (deloop_ind_set (conn_ptype_prod X1 X2) (uncurry Y) y0 _ (x1, x2)).
    unfold point. simpl.
    apply (equiv_functor_forall_pb (equiv_path_prod (point X1, point X2) (point X1, point X2))).
    intros [ω1 ω2]. simpl in ω1, ω2.
    apply fl_fr.
  Defined.

  Definition deloop_double_ind_set_beta_pt' :
    deloop_double_ind_set' (point X1) (point X2) = y0.
  Proof.
    unfold deloop_double_ind_set'. unfold deloop_ind_set. simpl.
    change (point X1, point X2) with (point (conn_ptype_prod X1 X2)).
    apply (deloop_ind_beta_pt (conn_ptype_prod X1 X2) (uncurry Y) y0).
  Defined.

End deloop_double_ind_set'.

(* todo: replace transport with pathover above, and write out deloop_double_ind *)
(* this should replace the two above *)
(* Section deloop_double_ind. *)


Module foo.

Require Import option_monad.

Inductive list (a : Type) : Type :=
  | nil : list a
  | cons : a -> list a -> list a.

Infix "::" := cons (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Set Implicit Arguments.

Definition head {a : Type} (default : a) (l : list a) : a :=
  match l with
    | nil => default
    | cons h t => h
  end.

Definition tail {a : Type} (default : list a) (l : list a) : list a :=
  match l with
    | nil => default
    | cons h t => t
  end.

Fixpoint append {a : Type} (l1 l2 : list a) : list a :=
  match l1 with
    | nil => l2
    | cons h t => cons a h (append t l2)
  end.

Notation "xs ++ ys" := (append xs ys) (at level 60, right associativity).

Theorem app_is_assoc : forall (a : Type)
                              (xs ys zs : list a),
                         (xs ++ ys) ++ zs = xs ++ (ys ++ zs).
Proof.
  intros.
  induction xs.
  simpl.
  reflexivity.
  simpl.
  rewrite IHxs.
  reflexivity.
Qed.

Fixpoint length {a : Type} (l : list a) : nat :=
  match l with
    | nil => 0
    | cons h t => 1 + length t
  end.

Theorem app_length : forall (a : Type)
                            (xs ys : list a),
                       length xs + length ys = length (xs ++ ys).
Proof.
  intros.
  induction xs.
  simpl.
  reflexivity.
  simpl.
  rewrite IHxs.
  reflexivity.
Qed.

Fixpoint map {a b : Type} (f : a -> b) (l : list a) : list b :=
  match l with
    | nil => nil b
    | cons h t => cons b (f h) (map f t)
  end.

Definition id' {a} x : a := x.

Theorem map_id_id_map : forall (a : Type)
                               (xs : list a),
                          map id' xs = xs.
Proof.
  intros.
  induction xs.
  simpl.
  reflexivity.
  simpl.
  rewrite IHxs.
  unfold id'.
  reflexivity.
Qed.

Definition compose {a b c} (f : a -> b) (g : b -> c) : a -> c :=
  fun x => g (f x).

Theorem map_f_g_compose : forall (a b c : Type)
                                 (f : a -> b)
                                 (g : b -> c)
                                 (xs : list a),
                            map (compose f g) xs = compose (map f) (map g) xs.
Proof.
  intros.
  induction xs.
  simpl.
  reflexivity.
  simpl.
  rewrite IHxs.
  reflexivity.
Qed.

Fixpoint fold_right {a b : Type} (f : a -> b -> b) (b' : b) (la : list a) : b:=
  match la with
    | nil => b'
    | cons h t => fold_right f (f h b') t
  end.

Definition flatten {a : Type} (xs : list (list a)) : list a :=
  fold_right append (nil a) xs.

Definition flat_map {a b : Type} (l : list a) (f : a -> list b) : list b :=
  flatten (map f l).

Definition singleton {a : Type} (x : a) := cons a x (nil a).


(*|
########################
Induction over relations
########################

:Link: https://stackoverflow.com/q/44024840
|*)

(*|
Question
********

I'm trying to prove the following toy theorem about the ordering of
the naturals:
|*)

Inductive Le : nat -> nat -> Prop :=
| le_n : forall n, Le n n
| le_S : forall n m, Le n m -> Le n (S m).

Theorem le_Sn_m : forall n m, Le (S n) m -> Le n m.

(*|
On paper, this is a simple induction on ``Le (S n) m``. In particular,
the base case of ``le_n`` is trivial.

In Coq though, beginning my proof with induction gives me the
following:
|*)

Proof.
  intros n m H. induction H. Show. (* .unfold .messages *)
Abort. (* .none *)

(*| How should I proceed instead? |*)

(*|
Answer (Vinz)
*************

This is due to a limitation of Coq, when using ``induction`` on term
that are not made only of variables. By doing your induction, Coq
forgets about the fact that the first argument was a ``S`` of some
``n``.

You can do the following instead:
|*)

Theorem le_Sn_m_ : forall X m, Le X m -> forall n, X = S n -> Le n m.
Abort. (* .none *)

(*|
I think there is a ``dependent induction`` somewhere that could save
you this intermediate lemma but I can't recall where.
|*)

(*|
Answer (Zimm i48)
*****************

Similar to @Vinz suggestion, but without changing the statement you
are proving:
|*)

Theorem le_Sn_m : forall n m, Le (S n) m -> Le n m.
Proof.
  intros n m H. remember (S n) as p. induction H; subst n0.
  - do 2 constructor.
  - constructor. now apply IHLe.
Qed.

(*|
Using the `remember
<https://coq.inria.fr/refman/proof-engine/tactics.html#coq:tacv.remember>`__
tactic will introduce an equality in your context which will avoid
losing this critical information.
|*)

(*|
Answer (Anton Trunov)
*********************

This is happening because Coq treats differently *indices* and
*parameters* (see the accepted answer to `this question
<https://stackoverflow.com/q/24600256/2747511>`__ for a very nice
explanation). Your ``Le`` relation uses indices only, whereas the
standard definition makes the first argument a parameter:
|*)

Print le. (* .unfold .messages *)

(*|
I can recommend reading `this blog post
<https://homes.cs.washington.edu/~jrw12/dep-destruct.html>`__ by James
Wilcox. Here is a relevant excerpt:

    When Coq performs a case analysis, it first abstracts over all
    indices. You may have seen this manifest as a loss of information
    when using destruct on predicates

So you can either (1) change your ``Le`` relation so it would use a
parameter, or (2) use the ``remember`` tactic as was suggested by
@Zimm i48, or (3) use the ``dependent induction`` tactic mentioned by
@Vinz:
|*)

Reset Initial. (* .none *)
Require Import Coq.Program.Equality. (* for `dependent induction` *)

Inductive Le : nat -> nat -> Prop :=
| le_n : forall n, Le n n
| le_S : forall n m, Le n m -> Le n (S m).
Hint Constructors Le. (* so `auto` will work *)

Theorem le_Sn_m : forall n m, Le (S n) m -> Le n m.
Proof.
  intros n m H. dependent induction H; auto.
Qed.


Require Export SFSstate.

Set Implicit Arguments.
Unset Strict Implicit.

(*********************************************************************)
(*                Preconditions for DAC and MAC                      *)
(*********************************************************************)

Section Preconditions.

Variable s : SFSstate.

(*This predicate asserts that for a entity to read an entity, the   *)
(*former must belong to the set of readers of the last. Also, this   *)
(*condition holds if the entity belongs to a group wich in turn     *)
(*belongs to the entity's readers.                                   *)

Definition PreDACRead (eSub : ENTITY) (eObj : ENTITY) : Prop :=
  match fcap (cap s) eSub with
  | Some x => set_In eObj (CanReadEntities x)
  | None => False
  end.

(*This predicate asserts that for a entity to write to an entity,   *)
(*the former must belong to the set of writers of the last. Also,    *)
(*this condition holds if the entity belongs to a group wich in turn*)
(*belongs to the entity's writers.                                   *)

Definition PreDACWrite (eSub : ENTITY) (eObj : ENTITY) : Prop :=
  match fcap (cap s) eSub with
  | Some x => set_In eObj (CanWriteEntities x)
  | None => False
  end.

(*This predicate asserts that for a entity to read or write an      *)
(*entity, the entity's security class must be dominated by the       *)
(*entity's security class.                                          *)

Definition PreMAC (eSub : ENTITY) (eObj : ENTITY) : Prop :=
  match fESC (entitySC s) eObj, fESC (entitySC s) eSub with
  | None, _ => False
  | _, None => False
  | Some a, Some b => le_sc a b
  end.

(*This predicate asserts that if a user is an active writer of any   *)
(*entity b, then the security class of b must dominates the security *)
(*class of o. This predicate is used to preserve the *-property*)

Definition PreStarPropRead (eSub : ENTITY) (eObj : ENTITY) : Prop :=
  forall b : ENTITY,
  match fsecmat (secmat s) eSub, fESC (entitySC s) eObj, fESC (entitySC s) b with
  | None, _, _ => False
  | _, None, _ => False
  | _, _, None => False
  | Some x, Some y, Some z => (set_In eObj (EntReadingList x) /\ set_In b (EntWritingList x)) -> le_sc y z
  end.

(*This predicate asserts that if a user is an active reader of any   *)
(*entity b, then the security class of b must be dominated by the    *)
(*security class of o. This predicate is used to preserve the        *)
(**-property.                                                        *)

Definition PreStarPropWrite (eSub : ENTITY) (eObj : ENTITY) : Prop :=
  forall b : ENTITY,
  match fsecmat (secmat s) eSub, fESC (entitySC s) eObj, fESC (entitySC s) b with
  | None, _, _ => False
  | _, None, _ => False
  | _, _, None => False
  | Some x, Some y, Some z => (set_In eObj (EntWritingList x) /\ set_In b (EntReadingList x)) -> le_sc z y
  end.

Definition InSystem (e : ENTITY) : Prop :=
  set_In e (DOM ENTeq_dec (entitycontent s)).

End Preconditions.

Hint Unfold PreDACRead PreDACWrite PreMAC PreStarPropRead PreStarPropWrite InSystem.


Require Import HoTT.
Require Import HitTactics.
Require Import definition.
Require Import operations.
Require Import properties.

Ltac destruct_match := repeat
  match goal with
  | [|- match ?X with | _ => _ end ] => destruct X
 	end.

Ltac destruct_match_1 :=
	repeat match goal with
    | [|- match ?X with | _ => _ end ] => destruct X
    | [|- ?X = ?Y ] => apply path_ishprop
    | [ H: ?x <> E  |- Empty ] => destruct H
    | [  H1: ?x = E, H2: ?y = E, H3: ?w ∪ ?q  = E |- ?r = E]
    			=> rewrite H1, H2 in H3; rewrite nl in H3;  rewrite nl in H3
  end.

Ltac eq_neq_tac :=
match goal  with
    |  [ H: ?x <> E, H': ?x = E |- _ ] => destruct H; assumption
end.

Section EmptySetProperties.

Context {A : Type}.
Context {A_deceq : DecidablePaths A}.

(*Should go to properties *)
Lemma union_subset `{Funext} :
	forall x y z: FSet A, x ∪ y ⊆ z = true -> x ⊆ z = true /\ y ⊆ z = true.
intros x y z Hu.
split.
- eapply subset_isIn. intros a Ha.
  eapply subset_isIn in Hu.
  + instantiate (1 := a) in Hu.
  assumption.
  + transitivity (a ∈ x || a ∈ y)%Bool .
  apply union_isIn.
  rewrite Ha. cbn; reflexivity.
- eapply subset_isIn. intros a Ha.
  eapply subset_isIn in Hu.
  + instantiate (1 := a) in Hu.
  assumption.
  + rewrite comm. transitivity (a ∈ y || a ∈ x)%Bool .
  apply union_isIn.
  rewrite Ha. cbn. reflexivity.
Defined.

Lemma eset_subset_l `{Funext} : forall x: FSet A, x ⊆ ∅ = true -> x = ∅.
intros x He.
apply eq_subset.
split.
- cbn; reflexivity.
- assumption.
Defined.

Lemma eset_subset_r `{Funext} : forall x: FSet A,  x = ∅ -> x ⊆ ∅ = true.
intros x He.
apply eq_subset. apply symmetry. assumption.
Defined.

Lemma subset_transitive `{Funext}:
	forall x y z, x ⊆ y = true -> y ⊆ z = true -> x ⊆ z = true.
intros.
Admitted.

Lemma eset_union_l `{Funext}  : forall x y: FSet A, x ∪ y = ∅ -> x = ∅ .
Proof.
intros.
assert (x ⊆ (x  ∪ y) = true).
apply subset_union_equiv. rewrite assoc. rewrite (union_idem x). reflexivity.
apply eset_subset_r in X.
assert (x ⊆ ∅ = true).
apply (subset_transitive x (U x y)); assumption.
apply eset_subset_l.
assumption.
Defined.

Lemma eset_union_lr `{Funext}  :
forall x y: FSet A, x ∪ y = ∅ -> ((x = ∅)  /\ (y = ∅)).
Proof.
intros.
split.
apply eset_union_l in X; assumption.
rewrite comm in X.
apply eset_union_l in X. assumption.
Defined.

Lemma non_empty_union_l `{Funext} :
	forall x y: FSet A,   x <> E -> x ∪ y <> E.
intros x y He.
intro Hu.
apply He.
apply eq_subset in Hu.
destruct Hu as [_ H1].
apply union_subset in H1.
apply eset_subset_l.
destruct H1.
assumption.
Defined.

Lemma non_empty_union_r `{Funext} :
	forall x y: FSet A,   y <> E -> x ∪ y <> E.
intros x y He.
intro Hu.
apply He.
apply eq_subset in Hu.
destruct Hu as [_ H1].
apply union_subset in H1.
apply eset_subset_l.
destruct H1.
assumption.
Defined.

Theorem contrapositive : forall P Q : Type,
   (P -> Q) -> (not Q -> not P) .
Proof.
intros p q H1 H2.
unfold "~".
intro H3.
apply H1 in H3. apply H2 in H3. assumption.
Defined.

Lemma non_empty_singleton : forall a: A, L a <> E.
intros a H.
enough (false = true).
 contradiction (false_ne_true X).
transitivity (isIn a E).
cbn. reflexivity.
transitivity (a ∈ (L a)).
apply (ap (fun x => a ∈ x) H^) .
cbn. destruct (dec (a = a)).
reflexivity.
destruct n.
reflexivity.
Defined.

(* Lemma aux `{Funext}: forall x: FSet A, forall p q: x = ∅  -> False,  p = q.
intros. apply path_forall. intro.
apply path_ishprop.
Defined.*)

Lemma fset_eset_dec `{Funext}: forall x: FSet A, x = ∅ \/ x <> ∅.
hinduction.
- left; reflexivity.
- right. apply non_empty_singleton.
- intros x y [G1 | G2] [G3 | G4].
	+ left. rewrite G1, G3. apply nl.
	+ right. apply non_empty_union_r; assumption.
	+ right. apply non_empty_union_l; assumption.
	+ right. apply non_empty_union_l; assumption.
- intros. destruct px, py, pz; apply path_sum; destruct_match_1.
	+   rewrite p, p0, p1.  rewrite nl. rewrite nl. reflexivity.
	+ assumption.
	+ rewrite p, p0 in p1. rewrite nl in p1. rewrite comm in p1. rewrite nl in p1.
		assumption.
	+ rewrite p in p0. rewrite nl in p0.
	  apply (non_empty_union_l y z) in n.  eq_neq_tac.
	+ rewrite p, p0 in p1. rewrite nr in p1. rewrite nr in p1. assumption.
	+ rewrite p in p0. rewrite nr in p0.
		apply (non_empty_union_l x z) in n.  eq_neq_tac.
	+ rewrite p in p0. rewrite nr in p0.
	 	apply (non_empty_union_l x y) in n.  eq_neq_tac.
	+ apply (non_empty_union_l x y) in n.
	  apply (non_empty_union_l (x ∪ y) z) in n. eq_neq_tac.
- intros. destruct px, py; apply path_sum; destruct_match_1.
	+ rewrite p, p0; apply union_idem.
	+ rewrite p in p0. rewrite nr in p0. assumption.
	+ rewrite p in p0. rewrite nl in p0. assumption.
	+ apply (non_empty_union_r y x) in n. eq_neq_tac.
- intros x px.
	destruct px. apply path_sum; destruct_match_1.
	+ assumption.
	+ apply path_sum; destruct_match_1. assumption.
- intros x px.
	destruct px. apply path_sum; destruct_match_1.
	+ assumption.
	+ apply path_sum; destruct_match_1. assumption.
- intros. cbn. apply path_sum. destruct_match_1.
  + apply (non_empty_singleton x). apply p.
Defined.

Lemma union_non_empty `{Funext}:
  forall X1 X2: FSet A, U X1 X2 <> ∅ -> X1 <> ∅ \/ X2 <> ∅.
intros X1 X2 G.
specialize (fset_eset_dec X1).
intro. destruct X. rewrite p in G. rewrite nl in G.
right. assumption. left. apply n.
Defined.

Lemma union_non_empty' `{Funext}:
  forall X1 X2: FSet A, U X1 X2 <> ∅ ->
  	(X1 <> ∅ /\ X2 = ∅) \/
  	(X1 = ∅ /\ X2 <> ∅) \/
  	(X1 <> ∅ /\ X2 <> ∅ ).
intros X1 X2 G.
specialize (fset_eset_dec X1).
specialize (fset_eset_dec X2).
intros H1 H2.
destruct H1, H2.
- rewrite p, p0 in G. destruct G. apply union_idem.
- left; split; assumption.
- right. left.  split; assumption.
- right. right. split; assumption.
Defined.

End  EmptySetProperties.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__betweennotequal.
Require Export lemma__layoffunique.
Require Export lemma__ray4.
Require Export lemma__ray5.
Require Export logic.
Definition lemma__lessthanbetween : forall A B C, (euclidean__defs.Lt A B A C) -> ((euclidean__defs.Out A B C) -> (euclidean__axioms.BetS A B C)).
Proof.
intro A.
intro B.
intro C.
intro H.
intro H0.
assert (exists M, (euclidean__axioms.BetS A M C) /\ (euclidean__axioms.Cong A M A B)) as H1 by exact H.
destruct H1 as [M H2].
destruct H2 as [H3 H4].
assert (* Cut *) (euclidean__axioms.neq A M) as H5.
- assert (* Cut *) ((euclidean__axioms.neq M C) /\ ((euclidean__axioms.neq A M) /\ (euclidean__axioms.neq A C))) as H5.
-- apply (@lemma__betweennotequal.lemma__betweennotequal A M C H3).
-- destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
exact H8.
- assert (* Cut *) (euclidean__defs.Out A M C) as H6.
-- apply (@lemma__ray4.lemma__ray4 A M C).
---right.
right.
exact H3.

--- exact H5.
-- assert (* Cut *) (euclidean__defs.Out A C M) as H7.
--- apply (@lemma__ray5.lemma__ray5 A M C H6).
--- assert (* Cut *) (euclidean__defs.Out A C B) as H8.
---- apply (@lemma__ray5.lemma__ray5 A B C H0).
---- assert (* Cut *) (M = B) as H9.
----- apply (@lemma__layoffunique.lemma__layoffunique A C M B H7 H8 H4).
----- assert (* Cut *) (euclidean__axioms.BetS A B C) as H10.
------ apply (@eq__ind__r euclidean__axioms.Point B (fun M0 => (euclidean__axioms.BetS A M0 C) -> ((euclidean__axioms.Cong A M0 A B) -> ((euclidean__axioms.neq A M0) -> ((euclidean__defs.Out A M0 C) -> ((euclidean__defs.Out A C M0) -> (euclidean__axioms.BetS A B C))))))) with (x := M).
-------intro H10.
intro H11.
intro H12.
intro H13.
intro H14.
exact H10.

------- exact H9.
------- exact H3.
------- exact H4.
------- exact H5.
------- exact H6.
------- exact H7.
------ exact H10.
Qed.