From vcfloat Require Import RAux.
From Flocq Require Import Binary Bits Core Zaux.
From vcfloat Require Import IEEE754_extra.
Require vcfloat.Fprop_absolute.
Set Bullet Behavior "Strict Subproofs".
Global Unset Asymmetric Patterns.

Import Bool.

Require Import vcfloat.FPCore.
Global Existing Instance fprec_gt_0. (* to override the Opaque one in Interval package *)

Local Open Scope R_scope.

Lemma binary_float_eqb_eq_rect_r:
 forall ty1 ty2 (a b: binary_float (fprec ty1) (femax ty1))
  (H: ty2=ty1),
@binary_float_eqb (fprec ty1) (femax ty1) (fprec ty2) (femax ty2)
  a (@eq_rect_r type ty1 ftype b ty2 H) =
  binary_float_eqb a b.
Proof.
intros. subst ty2.
reflexivity.
Qed.

Lemma center_R_correct a b x:
 0 <= b - a - Rabs (2 * x - (a + b)) ->
 a <= x <= b.
Proof.
  intros.
  assert (Rabs (2 * x - (a + b)) <= (b - a) )%R by lra.
  apply Raux.Rabs_le_inv in H0.
  lra.
Qed.

Lemma center_R_complete a b x:
 a <= x <= b ->
 0 <= b - a - Rabs (2 * x - (a + b)).
Proof.
  intros.
  cut (Rabs (2 * x - (a + b)) <= (b - a)); [ lra | ].
  apply Rabs_le.
  lra.
Qed.

Definition center_Z a x b :=
  (b - a - Z.abs (2 * x - (a + b)))%Z
.

Lemma center_Z_correct a b x:
  (0 <= center_Z a x b)%Z ->
  (a <= x <= b)%Z.
Proof.
  unfold center_Z.
  intros.
  apply IZR_le in H.
  replace (IZR 0) with 0 in H by reflexivity.
  repeat rewrite minus_IZR in H.
  rewrite abs_IZR in H.
  rewrite minus_IZR in H.
  rewrite mult_IZR in H.
  rewrite plus_IZR in H.
  replace (IZR 2) with 2 in H by reflexivity.
  apply center_R_correct in H.
  intuition eauto using le_IZR.
Qed.

Lemma center_Z_complete a b x:
  (a <= x <= b)%Z ->
  (0 <= center_Z a x b)%Z.
Proof.
  unfold center_Z.
  intros.
  apply le_IZR.
  replace (IZR 0) with 0 by reflexivity.
  repeat rewrite minus_IZR.
  rewrite abs_IZR.
  rewrite minus_IZR.
  rewrite mult_IZR.
  rewrite plus_IZR.
  replace (IZR 2) with 2 by reflexivity.
  apply center_R_complete.
  intuition eauto using IZR_le.
Qed.

Section WITHNANS.

Context {NANS: Nans}.

Definition Bsqrt ty := Bsqrt _ _ (fprec_gt_0 ty) (fprec_lt_femax ty) (sqrt_nan ty) BinarySingleNaN.mode_NE.

Inductive FF2B_gen_spec (prec emax: Z) (x: full_float): binary_float prec emax -> Prop :=
  | FF2B_gen_spec_invalid (Hx: valid_binary prec emax x = false):
      FF2B_gen_spec prec emax x (B754_infinity _ _ (sign_FF x))
  | FF2B_gen_spec_valid (Hx: valid_binary prec emax x = true)
                        y (Hy: y = FF2B _ _ _ Hx):
      FF2B_gen_spec _ _ x y
.

Lemma FF2B_gen_spec_unique prec emax x y1:
  FF2B_gen_spec prec emax x y1 ->
  forall y2,
    FF2B_gen_spec prec emax x y2 ->
    y1 = y2.
Proof.
  inversion 1; subst;
  inversion 1; subst; try congruence.
  f_equal.
  apply Eqdep_dec.eq_proofs_unicity.
  generalize bool_dec. clear. firstorder.
Qed.

Definition FF2B_gen prec emax x :=
  match valid_binary prec emax x as y return valid_binary prec emax x = y -> _ with
    | true => fun Hx => FF2B _ _ _ Hx
    | false => fun _ => B754_infinity _ _ (sign_FF x)
  end eq_refl.

Lemma bool_true_elim {T} a  (f: _ -> T) g H:
  match a as a' return a = a' -> _ with
    | true => f
    | false => g
  end eq_refl = f H.
Proof.
  destruct a; try congruence.
  f_equal.
  apply Eqdep_dec.eq_proofs_unicity.
  decide equality.
Qed.

Lemma FF2B_gen_correct prec emax x (Hx: valid_binary prec emax x = true):
  FF2B_gen _ _ x = FF2B _ _ _ Hx.
Proof.
  apply bool_true_elim.
Qed.

Definition F2 prec emax e  :=
if Z_lt_le_dec (e+1) (3 - emax)
 then F754_zero false
 else let p := Pos.pred prec in
  F754_finite false (2 ^ p) (e - Z.pos p).

Lemma F2R_F2 prec emax e:
   (3 - emax <= e + 1)%Z ->
  FF2R Zaux.radix2 (F2 prec emax e) = Raux.bpow Zaux.radix2 e.
Proof.
  unfold F2.
 destruct (Z_lt_le_dec _ _); [lia | ].
 intros _.
  simpl.
  unfold Defs.F2R.
  simpl Defs.Fnum.
  simpl Defs.Fexp.
  generalize (Pos.pred prec).
  intros.
  rewrite Pos2Z.inj_pow.
  replace 2%Z with (Zaux.radix_val Zaux.radix2) by reflexivity.
  rewrite Raux.IZR_Zpower by (vm_compute; congruence).
  rewrite <- Raux.bpow_plus.
  f_equal.
  ring.
Qed.

Lemma F2_valid_binary_gen prec emax e:
  (Z.pos prec < emax)%Z ->
  (e + 1 <= emax)%Z ->
  prec <> 1%positive ->
  valid_binary (Z.pos prec) emax (F2 prec emax e) = true.
Proof.
  intros.
  unfold valid_binary.
  unfold F2.
  destruct (Z_lt_le_dec _ _); auto.
  rename H0 into H0'.
  assert (H0 := conj l H0'). clear l H0'.
  apply bounded_canonical_lt_emax.
  { constructor. }
  { assumption.  }
  {
   red.
   rewrite cexp_fexp with (ex := (e + 1)%Z).
    {
      simpl Defs.Fexp.
      unfold FLT_exp.
      symmetry. unfold SpecFloat.fexp.
      rewrite  Z.max_l.
      {
        rewrite Pos2Z.inj_pred by assumption.
        lia.
      }
      unfold SpecFloat.emin; lia.
    }
    unfold Defs.F2R. simpl Defs.Fnum. simpl Defs.Fexp.
    rewrite Pos2Z.inj_pow.
    replace 2%Z with (Zaux.radix_val Zaux.radix2) by reflexivity.
    rewrite Raux.IZR_Zpower by (vm_compute; congruence).
    rewrite <- Raux.bpow_plus.
    rewrite Rabs_right.
    {
      split.
      {
        apply Raux.bpow_le.
        lia.
      }
      apply Raux.bpow_lt.
      lia.
    }
    apply Rle_ge.
    apply Raux.bpow_ge_0.
  }
  unfold Defs.F2R. simpl Defs.Fnum. simpl Defs.Fexp.
  rewrite Pos2Z.inj_pow.
  replace 2%Z with (Zaux.radix_val Zaux.radix2) by reflexivity.
  rewrite Raux.IZR_Zpower by (vm_compute; congruence).
  rewrite <- Raux.bpow_plus.
  apply Raux.bpow_lt.
  lia.
Qed.

Lemma F2_valid_binary ty e:
  (e + 1 <= femax ty)%Z ->
  valid_binary (fprec ty) (femax ty) (F2 (fprecp ty) (femax ty) e) = true.
Proof.
  intros.
  destruct (Z_lt_le_dec (e+1) (3 - (femax ty))).
-
  unfold F2.
  destruct (Z_lt_le_dec (e+1) (3 - (femax ty))); try lia.
  reflexivity.
-
  apply F2_valid_binary_gen.
  { apply fprec_lt_femax. }
  { assumption. }
  apply fprecp_not_one.
Qed.

Definition B2 ty e := FF2B_gen (fprec ty) (femax ty) (F2 (fprecp ty) (femax ty) e).
Definition B2_opp ty e := BOPP (B2 ty e).

Lemma B2_finite ty e:
  (e + 1 <= femax ty)%Z ->
  is_finite _ _ (B2 ty e) = true.
Proof.
  unfold B2.
  intros.
  rewrite (FF2B_gen_correct _ _ _ (F2_valid_binary _ _ H)).
  set (j := F2_valid_binary _ _ _). clearbody j. revert j.
  destruct (F2 _ _ _) eqn:?H; intros; auto;
  elimtype False; clear - H0; unfold F2 in H0;
  destruct (Z_lt_le_dec _ _) in H0; inversion H0.
Qed.

Lemma B2_correct ty e:
  (3 - femax ty <= e + 1 <= femax ty)%Z ->
  B2R _ _ (B2 ty e) = Raux.bpow Zaux.radix2 e.
Proof.
  intros.
  unfold B2.
  rewrite (FF2B_gen_correct _ _ _ (F2_valid_binary _ _ (proj2 H))).
  rewrite B2R_FF2B.
  apply F2R_F2.
  destruct H; auto.
Qed.

Definition fone: Defs.float Zaux.radix2 :=
  {|
    Defs.Fnum := 1;
    Defs.Fexp := 0
  |}.

Lemma F2R_fone: F2R _ fone = 1.
Proof.
  simpl. ring.
Qed.

Definition ftwo: Defs.float Zaux.radix2 :=
  {|
    Defs.Fnum := 1;
    Defs.Fexp := 1
  |}.

Lemma F2R_ftwo: F2R _ ftwo = 2.
Proof.
 unfold F2R, ftwo. ring_simplify. reflexivity.
Qed.

Lemma Rabs_lt_pos: forall x : R, 0 < Rabs x -> x <> 0.
Proof.
  intros.
  unfold Rabs in H.
  destruct (Rcase_abs x); lra.
Qed.

Lemma FLT_format_mult_beta_n_aux beta emin prec n
      x:
  FLX.Prec_gt_0 prec ->
  (Generic_fmt.generic_format
     beta (FLT.FLT_exp emin prec) x) ->
  Generic_fmt.generic_format
    beta
    (FLT.FLT_exp emin prec)
    (x * Raux.bpow beta (Z.of_N n)).
Proof.
  intros.
  revert x H0.
  rewrite <- N_nat_Z.
  induction (N.to_nat n).
  {
    simpl.
    intros.
    rewrite Rmult_1_r.
    auto.
  }
  intros.
  rewrite Nat2Z.inj_succ.
  unfold Z.succ.
  rewrite bpow_plus_1.
  rewrite (Rmult_comm (IZR _)).
  rewrite <- Rmult_assoc.
  apply FLT.generic_format_FLT.
  rewrite <- (Rmult_comm (IZR _)).
  apply Fprop_absolute.FLT_format_mult_beta.
  apply FLT.FLT_format_generic; auto.
Qed.

Lemma FLT_format_mult_beta_n ty (x: ftype ty) n rnd
      {H: Generic_fmt.Valid_rnd rnd}:
  Generic_fmt.round
      Zaux.radix2
      (FLT.FLT_exp (3 - femax ty - fprec ty) (fprec ty))
      rnd (B2R _ _ x * Raux.bpow Zaux.radix2 (Z.of_N n)) = B2R _ _ x * Raux.bpow Zaux.radix2 (Z.of_N n).
Proof.
  intros.
  apply Generic_fmt.round_generic; auto.
  apply FLT_format_mult_beta_n_aux; try typeclasses eauto.
  apply generic_format_B2R.
Qed.

Lemma bpow_minus1
     : forall (r : Zaux.radix) (e : Z),
       Raux.bpow r (e - 1) =
       Raux.bpow r e / IZR (Zaux.radix_val r)
.
Proof.
  intros.
  replace (e - 1)%Z with (e + - (1))%Z by ring.
  rewrite Raux.bpow_plus.
  rewrite Raux.bpow_opp.
  unfold Rdiv.
  f_equal.
  f_equal.
  simpl.
  f_equal.
  apply Zpow_facts.Zpower_pos_1_r.
Qed.

Lemma FLT_format_div_beta_1_aux beta emin prec n
      x:
  FLX.Prec_gt_0 prec ->
  (Generic_fmt.generic_format
     beta (FLT.FLT_exp emin prec) x) ->
  Raux.bpow beta (emin + prec + Z.pos n - 1) <= Rabs x ->
  Generic_fmt.generic_format
    beta
    (FLT.FLT_exp emin prec)
    (x / Raux.bpow beta (Z.pos n)).
Proof.
  intros until 1.
  unfold Rdiv.
  rewrite <- Raux.bpow_opp.
  rewrite <- positive_nat_Z.
  revert x.
  induction (Pos.to_nat n).
  {
    simpl.
    intros.
    rewrite Rmult_1_r.
    auto.
  }
  intro.
  rewrite Nat2Z.inj_succ.
  unfold Z.succ.
  intros.
  replace (- (Z.of_nat n0 + 1))%Z with (- Z.of_nat n0 - 1)%Z by ring.
  rewrite bpow_minus1.
  unfold Rdiv.
  rewrite <- Rmult_assoc.
  apply FLT.generic_format_FLT.
  apply Fprop_absolute.FLT_format_div_beta.
  {
    unfold FLX.Prec_gt_0 in H. lia.
  }
  {
    apply FLT.FLT_format_generic; auto.
    apply IHn0; auto.
    eapply Rle_trans; [ | eassumption ].
    apply Raux.bpow_le.
    lia.
  }
  rewrite Rabs_mult.
  rewrite (Rabs_right (Raux.bpow _ _)) by (apply Rle_ge; apply Raux.bpow_ge_0).
  eapply Rle_trans; [ | apply Rmult_le_compat_r ; try eassumption ].
  {
    rewrite <- Raux.bpow_plus.
    apply Raux.bpow_le.
    lia.
  }
  apply Raux.bpow_ge_0.
Qed.

Lemma FLT_format_div_beta_1 ty (x: ftype ty) n rnd
      {H: Generic_fmt.Valid_rnd rnd}:
  Raux.bpow Zaux.radix2 (3 - femax ty + Z.pos n - 1) <= Rabs (B2R _ _ x) ->
  Generic_fmt.round
      Zaux.radix2
      (FLT.FLT_exp (3 - femax ty - fprec ty) (fprec ty))
      rnd (B2R _ _ x * / Raux.bpow Zaux.radix2 (Z.pos n)) = B2R _ _ x / Raux.bpow Zaux.radix2 (Z.pos n).
Proof.
  intros.
  apply Generic_fmt.round_generic; auto.
  apply FLT_format_div_beta_1_aux; try typeclasses eauto.
  {
    apply generic_format_B2R.
  }
  eapply Rle_trans; [ | eassumption ].
  apply Raux.bpow_le.
  lia.
Qed.

Lemma Bdiv_beta_no_overflow' ty (x: ftype ty) n:
  is_finite _ _ x = true ->
  (n >= 0)%Z ->
  Rabs (B2R _ _ x / Raux.bpow Zaux.radix2 n) < Raux.bpow Zaux.radix2 (femax ty).
Proof.
  intros.
  unfold Rdiv.
  rewrite Rabs_mult.
  rewrite <- Raux.bpow_opp.
  rewrite (Rabs_right (Raux.bpow _ _)) by (apply Rle_ge; apply Raux.bpow_ge_0).
  eapply Rlt_le_trans.
  {
    apply Rmult_lt_compat_r.
    {
      apply Raux.bpow_gt_0.
    }
    apply abs_B2R_lt_emax.
  }
  rewrite <- Raux.bpow_plus.
  apply Raux.bpow_le.
  lia.
Qed.

Lemma Bdiv_beta_no_overflow ty (x: ftype ty) n:
  is_finite _ _ x = true ->
  Rabs (B2R _ _ x / Raux.bpow Zaux.radix2 (Z.pos n)) < Raux.bpow Zaux.radix2 (femax ty).
Proof.
  intros.
  apply Bdiv_beta_no_overflow'; auto.
 lia.
Qed.

Theorem Bdiv_mult_inverse_finite ty:
  forall x y z: (Binary.binary_float (fprec ty) (femax ty)),
  is_finite _ _ x = true ->
  is_finite _ _ y = true ->
  is_finite _ _ z = true ->
  Bexact_inverse (fprec ty) (femax ty) (fprec_gt_0 ty) (fprec_lt_femax ty) y = Some z ->
  Bdiv _ _ _ (fprec_lt_femax ty) (div_nan ty) BinarySingleNaN.mode_NE x y =
  Bmult _ _ _ (fprec_lt_femax ty) (mult_nan ty) BinarySingleNaN.mode_NE x z .
Proof.
  intros.
  destruct (Bexact_inverse_correct _ _ _ _ _ _ H2) as (A & B & C & D & E).
  assert (HMUL :=Binary.Bmult_correct (fprec ty)  (femax ty)
                     (fprec_gt_0 ty) (fprec_lt_femax ty) (mult_nan ty) BinarySingleNaN.mode_NE x z).
  assert (HDIV := Binary.Bdiv_correct  (fprec ty)  (femax ty)
                    (fprec_gt_0 ty) (fprec_lt_femax ty) (div_nan ty) BinarySingleNaN.mode_NE x y D).
 unfold Rdiv in HDIV.
 rewrite <- C in HDIV.
 destruct Rlt_bool.
 -
  destruct HMUL as (P & Q & R).
  destruct HDIV as (S & T & U).
  assert (Binary.is_finite  (fprec ty) (femax ty)
               (Binary.Bmult (fprec ty) (femax ty)  (fprec_gt_0 ty) (fprec_lt_femax ty)
                   (mult_nan ty) BinarySingleNaN.mode_NE x z) = true)
   by  (rewrite Q; auto;  rewrite ?andb_true_iff; auto).
  assert (Binary.is_finite (fprec ty) (femax ty)
              (Binary.Bdiv (fprec ty) (femax ty)  (fprec_gt_0 ty) (fprec_lt_femax ty)
                   (div_nan ty) BinarySingleNaN.mode_NE x y) = true)
    by (rewrite T; auto).
  apply Binary.B2R_Bsign_inj; auto;
  rewrite ?S, ?R, ?U, ?E; auto; apply is_finite_not_is_nan; auto.
-
  pose proof Binary.B2FF_inj _ _
       (Binary.Bdiv (fprec ty) (femax ty) (fprec_gt_0 ty)
            (fprec_lt_femax ty) (div_nan ty) BinarySingleNaN.mode_NE x y)
      (Binary.Bmult (fprec ty) (femax ty) (fprec_gt_0 ty)
            (fprec_lt_femax ty) (mult_nan ty) BinarySingleNaN.mode_NE x z).
  rewrite E in HMUL.
  rewrite HMUL, HDIV in *; auto.
Qed.

Theorem Bdiv_mult_inverse_nan ty:
  forall x y z: (Binary.binary_float (fprec ty) (femax ty)),
  is_nan _ _ x = false ->
  is_finite _ _ y = true ->
  is_finite _ _ z = true ->
  Bexact_inverse (fprec ty) (femax ty) (fprec_gt_0 ty) (fprec_lt_femax ty) y = Some z ->
  Bdiv _ _ _ (fprec_lt_femax ty) (div_nan ty) BinarySingleNaN.mode_NE x y =
  Bmult _ _ _ (fprec_lt_femax ty) (mult_nan ty) BinarySingleNaN.mode_NE x z .
Proof.
  intros.
  destruct (Bexact_inverse_correct _ _ _ _ _ _ H2) as (A & B & C & D & E).
  assert (HMUL :=Binary.Bmult_correct (fprec ty)  (femax ty)
                     (fprec_gt_0 ty) (fprec_lt_femax ty) (mult_nan ty) BinarySingleNaN.mode_NE x z).
  assert (HDIV := Binary.Bdiv_correct  (fprec ty)  (femax ty)
                    (fprec_gt_0 ty) (fprec_lt_femax ty) (div_nan ty) BinarySingleNaN.mode_NE x y D).
 unfold Rdiv in HDIV.
 rewrite <- C in HDIV.
 destruct Rlt_bool.
 -
  destruct HMUL as (P & Q & R).
  destruct HDIV as (S & T & U).
  destruct x; simpl in H; try discriminate.
 +
 set (x:= (B754_zero (fprec ty) (femax ty) s)) in *.
 assert (Binary.is_finite  (fprec ty) (femax ty)
               (Binary.Bmult (fprec ty) (femax ty)  (fprec_gt_0 ty) (fprec_lt_femax ty)
                   (mult_nan ty) BinarySingleNaN.mode_NE x z) = true)
   by  (rewrite Q; auto;  rewrite ?andb_true_iff; auto).
  assert (Binary.is_finite (fprec ty) (femax ty)
              (Binary.Bdiv (fprec ty) (femax ty)  (fprec_gt_0 ty) (fprec_lt_femax ty)
                   (div_nan ty) BinarySingleNaN.mode_NE x y) = true)
    by (rewrite T; auto).
  apply Binary.B2R_Bsign_inj; auto;
  rewrite ?S, ?R, ?U, ?E; auto; apply is_finite_not_is_nan; auto.
 +
   destruct y; simpl in A; try discriminate.
   destruct z; simpl in B; try discriminate.
   cbv [Bdiv]; simpl; simpl in E; subst; auto.
 + apply Bdiv_mult_inverse_finite; auto.
-
  pose proof Binary.B2FF_inj _ _
       (Binary.Bdiv (fprec ty) (femax ty) (fprec_gt_0 ty)
            (fprec_lt_femax ty) (div_nan ty) BinarySingleNaN.mode_NE x y)
      (Binary.Bmult (fprec ty) (femax ty) (fprec_gt_0 ty)
            (fprec_lt_femax ty) (mult_nan ty) BinarySingleNaN.mode_NE x z).
  rewrite E in HMUL.
  rewrite HMUL, HDIV in *; auto.
Qed.

Theorem Bdiv_mult_inverse_equiv ty:
  forall x y z: (Binary.binary_float (fprec ty) (femax ty)),
  is_finite _ _ y = true ->
  is_finite _ _ z = true ->
  Bexact_inverse (fprec ty) (femax ty) (fprec_gt_0 ty) (fprec_lt_femax ty) y = Some z ->
  binary_float_equiv
  (Bdiv _ _ _ (fprec_lt_femax ty) (div_nan ty) BinarySingleNaN.mode_NE x y)
  (Bmult _ _ _ (fprec_lt_femax ty) (mult_nan ty) BinarySingleNaN.mode_NE x z) .
Proof.
intros.
destruct x.
- apply binary_float_eq_equiv.
   apply Bdiv_mult_inverse_finite; auto.
- apply binary_float_eq_equiv.
   apply Bdiv_mult_inverse_nan; auto.
- destruct y; try simpl in H; try discriminate.
   destruct z; try simpl in H0; try discriminate.
 + cbv [Bdiv Bmult Binary.build_nan binary_float_equiv]. reflexivity.
 + cbv [Bdiv Bmult Binary.build_nan binary_float_equiv]. reflexivity.
- apply binary_float_eq_equiv.
   apply Bdiv_mult_inverse_finite; auto.
Qed.

Theorem Bdiv_mult_inverse_equiv2 ty:
  forall x1 x2 y z: (Binary.binary_float (fprec ty) (femax ty)),
  binary_float_equiv x1 x2 ->
  is_finite _ _ y = true ->
  is_finite _ _ z = true ->
  Bexact_inverse (fprec ty) (femax ty) (fprec_gt_0 ty) (fprec_lt_femax ty) y = Some z ->
  binary_float_equiv
  (Bdiv _ _ _ (fprec_lt_femax ty) (div_nan ty) BinarySingleNaN.mode_NE x1 y)
  (Bmult _ _ _ (fprec_lt_femax ty) (mult_nan ty) BinarySingleNaN.mode_NE x2 z) .
Proof.
intros.
assert (binary_float_equiv x1 x2) by apply H.
destruct x1; destruct x2; simpl in H; try contradiction.
-  subst; apply Bdiv_mult_inverse_equiv; auto.
-  subst; apply Bdiv_mult_inverse_equiv; auto.
-  destruct y; simpl in H0; try discriminate.
    destruct z; simpl in H1; try discriminate;
    cbv [Bdiv Bmult build_nan binary_float_equiv]; reflexivity.
- apply binary_float_finite_equiv_eqb in H3; auto.
   apply binary_float_eqb_eq in H3.
   rewrite H3.
   apply Bdiv_mult_inverse_equiv; auto.
Qed.

Lemma is_nan_normalize:
  forall prec emax (H0: FLX.Prec_gt_0 prec) (H1 : (prec < emax)%Z)
                   mode m e s,
  is_nan _ _ (binary_normalize prec emax H0 H1 mode m e s) = false.
Proof.
intros.
apply is_nan_BSN2B'.
Qed.

Lemma Bmult_correct_comm:
forall (prec emax : Z) (prec_gt_0_ : FLX.Prec_gt_0 prec)
         (Hmax : (prec < emax)%Z)
         (mult_nan : binary_float prec emax ->
                     binary_float prec emax -> nan_payload prec emax)
         (m : BinarySingleNaN.mode) (x y : binary_float prec emax),
       if
        Raux.Rlt_bool
          (Rabs
             (Generic_fmt.round Zaux.radix2
                (FLT.FLT_exp (3 - emax - prec) prec)
                (BinarySingleNaN.round_mode m)
                (B2R prec emax x * B2R prec emax y)))
          (Raux.bpow Zaux.radix2 emax)
       then
        B2R prec emax
          (Bmult prec emax prec_gt_0_ Hmax mult_nan m y x) =
        Generic_fmt.round Zaux.radix2
          (FLT.FLT_exp (3 - emax - prec) prec)
          (BinarySingleNaN.round_mode m)
          (B2R prec emax x * B2R prec emax y) /\
        is_finite prec emax (Bmult prec emax prec_gt_0_ Hmax mult_nan m y x) =
        is_finite prec emax x && is_finite prec emax y /\
        (is_nan prec emax (Bmult prec emax prec_gt_0_ Hmax mult_nan m y x) =
         false ->
         Bsign prec emax (Bmult prec emax prec_gt_0_ Hmax mult_nan m y x) =
         xorb (Bsign prec emax x) (Bsign prec emax y))
       else
        B2FF prec emax (Bmult prec emax prec_gt_0_ Hmax mult_nan m y x) =
        binary_overflow prec emax m
          (xorb (Bsign prec emax x) (Bsign prec emax y))
.
Proof.
  intros.
  rewrite Rmult_comm.
  rewrite andb_comm.
  rewrite xorb_comm.
  apply Bmult_correct.
Qed.

Lemma Rabs_zero_iff x:
  Rabs x = 0 <-> x = 0.
Proof.
  split; intros; subst; auto using Rabs_R0.
  destruct (Req_dec x 0); auto.
  apply Rabs_no_R0 in H0.
  contradiction.
Qed.

Lemma B2_zero:
  forall (ty : type) (e : Z),
  (e+1 < 3 - (femax ty))%Z -> (B2 ty e) = B754_zero (fprec ty) (femax ty) false.
Proof.
intros.
destruct (B2 ty e) eqn:?H; auto.
unfold B2, F2 in H0;
destruct (Z_lt_le_dec (e + 1) (3 - femax ty)); [ | lia];
inversion H0; auto.
all:
elimtype False;
unfold B2, F2 in H0;
destruct (Z_lt_le_dec (e + 1) (3 - femax ty)); [ | lia];
inversion H0.
Qed.

Lemma F2R_B2F:
 forall ty x,
    is_finite (fprec ty) (femax ty) x = true ->
    F2R radix2 (B2F x) = B2R (fprec ty) (femax ty) x.
Proof.
intros.
unfold F2R, B2R.
unfold B2F.
destruct x; auto; lra.
Qed.

Lemma InvShift_finite_aux:
 forall (pow : positive) (ty : type) (x : ftype ty),
   is_finite (fprec ty) (femax ty) x = true ->
  Rabs (round radix2 (FLT_exp (3 - femax ty - fprec ty) (fprec ty)) (BinarySingleNaN.round_mode BinarySingleNaN.mode_NE)
     (B2R (fprec ty) (femax ty) x * / bpow radix2 (Z.pos pow))) < bpow radix2 (femax ty).
Proof.
intros.
unfold BinarySingleNaN.round_mode.
pose proof (bpow_gt_0 radix2 (Z.pos pow)).
rewrite <- round_NE_abs by (apply FLT_exp_valid; apply fprec_gt_0).
rewrite Rabs_mult, Rabs_inv by lra.
rewrite (Rabs_right (bpow _ _)) by lra.
assert (bpow radix2 (femax ty - 1) < bpow radix2 (femax ty - 1 + 1)).
rewrite bpow_plus.
simpl bpow.
pose proof (bpow_gt_0 radix2 (femax ty - 1)).
lra.
replace (femax ty - 1 + 1)%Z with (femax ty) in H1 by lia.
match goal with |- ?A < _ => assert (A <= bpow radix2 (femax ty - 1)) end;
 [ | lra].
clear H1.
apply round_le_generic.
apply FLT_exp_valid; apply fprec_gt_0.
apply valid_rnd_N.
apply generic_format_FLT_bpow.
apply fprec_gt_0.
  pose proof (fprec_lt_femax ty).
  pose proof (fprec_gt_0 ty).
  red in H2.
  lia.
assert (Rabs (B2R (fprec ty) (femax ty) x) <= bpow radix2 (femax ty)). {
  pose proof (abs_B2R_lt_emax _ _ x). lra.
}
replace (Z.pos pow) with (1 + (Z.pos pow - 1))%Z by lia.
rewrite bpow_plus.
assert (bpow radix2 0 <= bpow radix2 (Z.pos pow - 1)).
apply bpow_le. lia.
unfold bpow at 1 in H2.
change (bpow radix2 1) with 2.
set (j := bpow radix2 (Z.pos pow - 1)) in *. clearbody j.
rewrite Rinv_mult by lra.
replace (femax ty - 1)%Z with (femax ty + -(1))%Z by lia.
rewrite bpow_plus, bpow_opp.
rewrite bpow_1.
change (IZR radix2) with 2.
rewrite (Rmult_comm _ (/ j)).
rewrite <- Rmult_assoc.
set (y := Rabs _) in *.
assert (0 <= y) by apply Rabs_pos.
apply Rmult_le_compat_r.
lra.
assert (y * /j <= y * 1); [ | lra].
apply Rmult_le_compat_l; try lra.
apply Rle_Rinv in H2; lra.
Qed.

Lemma InvShift_accuracy_aux:
  forall ty x pow,
    is_finite (fprec ty) (femax ty) x = true ->
  Rabs (round radix2 (FLT_exp (3 - femax ty - fprec ty) (fprec ty)) (BinarySingleNaN.round_mode BinarySingleNaN.mode_NE)
        (B2R (fprec ty) (femax ty) x * bpow radix2 (- Z.pos pow)) -
            bpow radix2 (- Z.pos pow) * B2R (fprec ty) (femax ty) x) <=
           /2 * bpow radix2 (3 - femax ty - fprec ty).
Proof.
intros.
 destruct (Rle_lt_dec
    (bpow radix2 (3 - femax ty + Z.pos pow))
    (Rabs (B2R (fprec ty) (femax ty) x))).
-
rewrite bpow_opp.
rewrite FLT_format_div_beta_1; auto.
2: apply valid_rnd_N.
rewrite Rmult_comm.
unfold Rdiv.
rewrite Rminus_eq_0, Rabs_R0.
pose proof (bpow_gt_0 radix2 (3 - femax ty - fprec ty)). lra.
eapply Rle_trans. 2: apply r. apply bpow_le. lia.
-
unfold BinarySingleNaN.round_mode.
rewrite (Rmult_comm (bpow _ _)).
eapply Rle_trans.
apply (error_le_half_ulp radix2
  (FLT_exp (3 - femax ty - fprec ty) (fprec ty)) (fun x => negb (Z.even x))
  (B2R (fprec ty) (femax ty) x * bpow radix2 (- Z.pos pow))).
unfold ulp.
set (emin := (3 - _ - _)%Z).
match goal with |- context  [Req_bool ?A ?B] =>
  set (a := A)
end.
pose proof (Req_bool_spec a 0).
destruct H0.
+
subst a.
destruct (negligible_exp_FLT emin (fprec ty)) as [z [? ?]].
rewrite H1.
unfold FLT_exp.
pose proof (fprec_gt_0 ty). red in H3.
rewrite Z.max_r by lia.
lra.
+
rewrite <- ulp_neq_0 by auto.
rewrite ulp_FLT_small.
lra.
apply fprec_gt_0.
subst a.
unfold emin.
rewrite bpow_opp.
replace (bpow radix2 (3 - femax ty + Z.pos pow)) with
(bpow radix2 (3 - femax ty - fprec ty + fprec ty) * bpow radix2 (Z.pos pow) ) in r.

assert (HltA: Rlt (IZR Z0) (bpow radix2 (Zpos pow))).
{pose proof bpow_gt_0 radix2  (( Zpos pow)); auto.
}
assert (HnotA: not (@eq R (bpow radix2 (Zpos pow)) (IZR Z0))).
{
apply Rabs_lt_pos; auto.
repeat rewrite Rabs_pos_eq; try apply bpow_ge_0; try nra.
}
match goal with |- context [Rabs ?A ] =>
field_simplify A; try nra
end.
apply Rdiv_lt_left in r; try nra.
rewrite <- Rabs_div_eq in r; try nra.
rewrite <- bpow_plus.
match goal with |-context [ bpow _ ?b = bpow _ ?a] =>
ring_simplify a; ring_simplify b; nra
end; symmetry;
match goal with |-context [_ = bpow _ ?a] =>
ring_simplify a
end.
Qed.

End WITHNANS.


Require Import Ornamental.Ornaments.

Set DEVOID search prove equivalence. (* <-- Correctness proofs for search *)
Set DEVOID lift type. (* <-- Prettier types than the ones Coq infers *)
Set Nonrecursive Elimination Schemes. (* <--- Preprocess needs induction principles for records *)

(*
 * This is an example for lifting between nested tuples and records.
 *)

(*
 * In this example, we have some generated code that uses nested tuples:
 *)
Module Generated.

Definition input := (prod bool (prod nat bool)).

Definition output := (prod nat bool).

Definition firstBool (r : (prod bool (prod nat bool))) : bool :=
  (fst r).

Definition numberI (r : (prod bool (prod nat bool))) : nat :=
  (fst (snd r)).

Definition secondBool (r : (prod bool (prod nat bool))) : bool :=
  (snd (snd r)).

Definition numberO (r : (prod nat bool)) : nat :=
  (fst r).

Definition andBools (r : (prod nat bool)) : bool :=
  (snd r).

Definition op (r : (prod bool (prod nat bool))) : (prod nat bool) :=
  (pair
    (numberI r)
    (andb
      (firstBool  r)
      (secondBool r)
    )
  ).

End Generated.

(*
 * We want to write proofs over the record versions of these, which
 * are easier to read about. We start by defining the record versions
 * of input and output ourselves:
 *)
Module Handwritten.

Record input := MkInput
{
  firstBool  : bool;
  numberI    : nat;
  secondBool : bool;
}.

Record output := MkOutput
{
  numberO  : nat;
  andBools : bool;
}.

End Handwritten.

(*
 * Now we Preprocess in both directions, since we'll lift in
 * both directions.
 *)
Preprocess Module Generated as Generated'.
Preprocess Module Handwritten as Handwritten'.

(*
 * The easiest way to lift these is to just lift the module twice, first for
 * input (bigger type) then for output (smaller type):
 *)
Lift Module Generated'.input Handwritten'.input in Generated' as Temp1.
Lift Module Generated'.output Handwritten'.output in Temp1 as Handwritten''.

(*
 * If you lift in the opposite order, for op, you get something well-typed but with
 * a type you don't even want. So for now when one type definition you lift along
 * is a subterm of another type definition you lift along, you will need to start
 * with the bigger one and then tell DEVOID to treat the lifted projections as opaque.
 * Really interesting WIP on handling this better without so much work for the user.
 *
 * See: https://taliasplse.wordpress.com/2020/02/02/automating-transport-with-univalent-e-graphs/
 *)

(*
 * OK, now that we're in the handwritten world, we can write our proofs over
 * these nicer types:
 *)
Module HandwrittenProofs.

Theorem and_spec_true_true
  (r : Handwritten'.input)
  (F : Handwritten''.firstBool  r = true)
  (S : Handwritten''.secondBool r = true)
  : Handwritten''.andBools (Handwritten''.op r) = true.
Proof.
  destruct r as [f n s].
  unfold Handwritten''.op.
  simpl in *.
  apply andb_true_intro.
  intuition.
Qed.

End HandwrittenProofs.

(*
 * Let's Preprocess this proof for lifting:
 *)
Preprocess Module HandwrittenProofs as HandwrittenProofs'.

(*
 * Then lift it back to our nested pair types.
 * I think this is order sensitive if we want something that looks nice, since we
 * lifted op in one order so we only have nice cached intermediate constants if we go
 * in the opposite order. But it will work regardless of which direction you do.
 *)
Lift Handwritten'.output Generated'.output in HandwrittenProofs'.and_spec_true_true as and_spec_true_true_1.
Repair Handwritten'.input Generated'.input in and_spec_true_true_1 as and_spec_true_true'.

(*
 * Tweaking those tactics, we can get back the original proof even forgetting about
 * Preprocessing.
 *)
Theorem and_spec_true_true
  (r : Generated.input)
  (F : Generated.firstBool  r = true)
  (S : Generated.secondBool r = true)
  : Generated.andBools (Generated.op r) = true.
Proof.
  induction r.
  apply (andb_true_intro (conj F S)).
Qed.

(* We are done! *)

(*
 * This is fully automatic, save for tweaking the tactics.
 * What do we get if we try to do this manually?
 * Let's start with the old proof.
 * The time is 10:29, end time is 10:31. So comparable effort,
 * since we need to tweak the tactics a bit, and the proof is really easy,
 * but that's just for the proof---we'd also need to port all of the functions,
 * like we did above. That took some time, but here we got it for free.
 * So we get a slight savings in development time overall.
 *)
Theorem and_spec_true_true_manual
  (r : Generated.input)
  (F : Generated.firstBool  r = true)
  (S : Generated.secondBool r = true)
  : Generated.andBools (Generated.op r) = true.
Proof.
  destruct r as [n b].
  unfold Generated.op.
  simpl in *.
  apply andb_true_intro.
  intuition.
Qed.
(*
 * All we change is the first line to get rid of the warning.
 *)


Require Setoid.

Parameter Provable : Prop -> Prop.
Axiom Pmodus : forall {a b:Prop}, Provable (a -> b) -> Provable a -> Provable b.
Axiom loeb : forall {a:Prop}, Provable (Provable a -> a) -> Provable a.
Axiom unsafeNecessitation: forall {a:Prop}, a -> Provable a. (* WRONG *)
Ltac prove := repeat match goal with
  | [ H : Provable _ |- _ ] => refine (Pmodus _ H); clear H
end; clear; apply unsafeNecessitation; intuition. (* sometimes doesnt clear *)
Ltac loebprove := apply loeb; prove.

Parameter Fixedpoint2 : (Prop -> Prop -> Prop) -> (Prop -> Prop -> Prop) -> Prop. (* SHOULD BE REDUNDANT *)
Notation "A <3 B" := (Fixedpoint2 A B) (at level 70).
Axiom fixedpoint2 : forall {a b}, a <3 b = a (a <3 b) (b <3 a).
Ltac unfix := rewrite fixedpoint2.

Definition Prudent (self other:Prop) := Provable (self <-> other).
Definition Fair    (self other:Prop) := Provable other.
Definition Coop    (self other:Prop) := True.
Definition Defect  (self other:Prop) := False.

Theorem prudentbotcoops : Prudent <3 Prudent. unfix. prove. Qed.

Theorem fairbotcoops : Fair <3 Fair. unfix. loebprove. unfix. prove. Qed.

Theorem p2pp : forall {a : Prop}, Provable a -> Provable (Provable a).
Proof.
  intros a pa.
  refine (Pmodus _ (_: Provable (a /\ Provable a))). prove.
  loebprove. intuition prove.
Qed.

Theorem prudentfaircoops : Prudent <3 Fair.
Proof.
  unfix.
  loebprove.
  unfix. apply p2pp in H. prove. unfix. assumption.
  unfix. exact H.
Qed.

Theorem fairfaircoops : Fair <3 Fair.


Require Import BasicMachineTypes.
Require Import Setoid.
Require List.

(* Definition for expressing resources in annotations. An RA will
   have a function to convert this to a resource, a logic will have
   a function to convert this to a formula. *)
Definition res_expr (R:Set) : Set := List.list (bool * R).

Module Type RESOURCE_ALGEBRA
  (RA_B : BASICS).

Parameter res : Type.

Parameter eq : res -> res -> Prop.
Notation "e1 [=] e2" := (eq e1 e2) (at level 70, no associativity).

Axiom eq_refl : forall r, r [=] r.
Axiom eq_symm : forall r1 r2, r1 [=] r2 -> r2 [=] r1.
Axiom eq_trans : forall r1 r2 r3, r1 [=] r2 -> r2 [=] r3 -> r1 [=] r3.

Add Relation res eq
 reflexivity proved by eq_refl
 symmetry proved by eq_symm
 transitivity proved by eq_trans as ra_eq_rel.

Parameter leq : res -> res -> Prop.
Notation "e1 <: e2" := (leq e1 e2) (at level 75, no associativity).

Axiom leq_refl     : forall r1 r2, r1 [=] r2 -> r1 <: r2.
Axiom leq_antisymm : forall r1 r2, r1 <: r2 -> r2 <: r1 -> r1 [=] r2.
Axiom leq_trans    : forall r1 r2 r3, r1 <: r2 -> r2 <: r3 -> r1 <: r3.

Declare Instance ra_leq_rel : PreOrder leq.
Declare Instance leq_morphism : Morphisms.Proper (eq ==> eq ==> iff) leq.

Parameter combine : res -> res -> res.
Notation "e1 :*: e2" := (combine e1 e2) (at level 40, left associativity).

Parameter e : res.

Axiom e_bottom : forall r, e <: r.
Axiom e_combine_r : forall r, e :*: r [=] r.
Axiom r_combine_e : forall r, r :*: e [=] r.
Axiom combine_assoc : forall r1 r2 r3, r1 :*: (r2 :*: r3) [=] (r1 :*: r2) :*: r3.
Axiom combine_symm  : forall r1 r2, r1 :*: r2 [=] r2 :*: r1.

Declare Instance combine_morphism_Proper : Morphisms.Proper (eq ==> eq ==> eq) combine.
Declare Instance combine_order_Proper : Morphisms.Proper (leq ++> leq ++> leq) combine.
Axiom combine_order : forall x y, x <: y -> forall x0 y0, x0 <: y0 -> x :*: x0 <: y :*: y0.

Parameter bang : res -> res.
Notation "! e" := (bang e) (at level 35, right associativity).

Axiom bang_unit : forall r, r <: !r.
Axiom bang_mult : forall r, !!r <: !r.
Axiom bang_codup : forall r, !r :*: !r <: !r.
Axiom bang_e : !e [=] e.
Axiom bang_combine : forall r1 r2, !(r1 :*: r2) [=] !r1 :*: !r2.

Parameter r_new : RA_B.Classname.t -> option res.

Declare Instance bang_morphism_Proper : Morphisms.Proper (eq ==> eq) bang.
Declare Instance bang_order_Proper : Morphisms.Proper (leq ++> leq) bang.

Fixpoint res_parse (expr:res_expr RA_B.Classname.t) :=
  match expr with
    | List.nil => e
    | (List.cons (true,c) t) => match r_new c with None => res_parse t | Some r => (!r) :*: (res_parse t) end
    | (List.cons (false,c) t) => match r_new c with None => res_parse t | Some r => r :*: (res_parse t) end
  end.

End RESOURCE_ALGEBRA.


(* Exercise 46 *)

Require Import BenB.

Variables A B C D : Prop.

Theorem exercise_046 : B -> (A -> B).
Proof.
imp_i a1.
imp_i a2.
hyp a1.
Qed.


Set Implicit Arguments.

Require Import
        String
        Syntax.Regex
        Substring.SubstringDef
        Prefix.PrefixDef
        Prefix.PrefixAntimirov
        Derivatives.Antimirov
        Tactics.Tactics.

Fixpoint antimirov_substring (e : regex)(s : string) : bool :=
  match s with
  | EmptyString => null e
  | String a' s' =>
    orb (antimirov_prefix e (String a' s'))
        (antimirov_substring e s')
  end.

Theorem antimirov_substring_sound
  : forall s e, Is_true (antimirov_substring e s) -> substring e s.
Proof.
  induction s ; intros e H ; simpl in *.
  +
    apply null_sound in H.
    eapply MkSubstring with (xs := "")(ys := "")(zs := "") ; auto.
  +
    apply orb_prop_elim in H.
    destruct H.
    -
      apply orb_prop_elim in H.
      destruct H.
      *
        apply null_sound in H.
        eapply MkSubstring with (xs := "")(ys := "")(zs := String a s) ; auto.
      *
        apply Is_true_eq_true in H.
        apply existsb_exists in H.
        destruct H as [e' [Hin Heq]].
        apply Is_true_eq_left in Heq.
        apply antimirov_prefix_sound in Heq.
        inverts Heq.
        assert (Hx : x <<<- (pderiv a e)).
           unfolds.
           apply Exists_exists ; eexists ; eauto.
        eapply pderiv_sound in Hx ; eauto.
        apply MkSubstring with (xs := "")(ys := String a x)(zs := y) ; auto.
    -
      apply IHs in H.
      inverts* H.
      apply MkSubstring with (xs := String a xs)
                             (ys := ys)
                             (zs := zs) ; auto.
Qed.

Theorem antimirov_substring_complete
  : forall s e, substring e s -> Is_true (antimirov_substring e s).
Proof.
  induction s ; intros e H ; inverts* H.
  +
    apply empty_string_concat in H1.
    destruct H1.
    symmetry in H1.
    apply empty_string_concat in H1.
    destruct H1.
    substs.
    apply null_complete ; auto.
  +
    destruct xs.
    -
      destruct ys.
      *
        simpl in H1.
        substs.
        simpl.
        apply orb_prop_intro ; left.
        apply orb_prop_intro ; left.
        apply null_complete ; auto.
      *
        simpl in *.
        injects H1.
        eapply pderiv_complete in H0 ; eauto.
        apply orb_prop_intro ; left*.
        apply orb_prop_intro ; right*.
        apply Is_true_eq_left.
        apply existsb_exists.
        inverts H0.
        **
          exists x ; simpl ; splits*.
          apply Is_true_eq_true.
          apply antimirov_prefix_complete.
          eapply MkPrefix ; eauto.
        **
          apply Exists_exists in H1.
          destruct H1 as [e' [Hin Heq]].
          exists e' ; simpl ; splits*.
          apply Is_true_eq_true.
          apply antimirov_prefix_complete.
          eapply MkPrefix ; eauto.
    -
      injects H1.
      simpl.
      apply orb_prop_intro ; right.
      apply IHs.
      eapply MkSubstring ; eauto.
Qed.


Require Export basic ZF.
Require Import ZFnats.

(* Directed set (finite union) *)
Definition isDir o := forall x y,
    lt x o -> lt y o -> exists2 z, lt z o & x ⊆ z /\ y ⊆ z.

Fixpoint plump ub (p:Acc in_set ub) x : Prop :=
  (forall y (q: y ∈ ub), y ∈ x -> plump y (Acc_inv p _ q) y) /\
  (forall z y (q: y ∈ ub), plump y (Acc_inv p _ q) z ->
   z ⊆ y -> y ∈ x -> z ∈ x).

Lemma plump_morph : forall x x' p p' y y',
  x == x' -> y == y' -> (plump x p y <-> plump x' p' y').
intros x x' p; revert x'.
induction p using Acc_indd; simpl; intros.
destruct p'; simpl.
split; destruct 1; split; intros.
 assert (q' := q).
 rewrite <- H0 in q'.
 rewrite <- H1 in H4.
 rewrite <- (H y0 q' _ _ y0 y0); auto with *.

 assert (q' := q).
 rewrite <- H0 in q'.
 rewrite <- H1 in H6|-*.
 rewrite <- (H y0 q' _ _ z z) in H4; eauto with *.

 assert (q' := q).
 rewrite H0 in q'.
 rewrite H1 in H4.
 rewrite (H _ _ y0 (a0 _ q') _ y0); auto with *.

 assert (q' := q).
 rewrite H0 in q'.
 rewrite H1 in H6|-*.
 rewrite (H _ _ y0 (a0 _ q') _ z) in H4; eauto with *.
Qed.

Lemma plump_bound : forall ub1 ub2 p1 p2 x,
 x ⊆ ub1 ->
 plump ub1 p1 x -> plump ub2 p2 x.
destruct p1; destruct p2; simpl; intros.
destruct H0.
split; intros.
 assert (y ∈ ub1).
  apply H; trivial.
 rewrite (plump_morph _ y _ (a _ H3) _ y); auto with *.

 assert (y ∈ ub1).
  apply H; trivial.
 rewrite (plump_morph _ y _ (a _ H5) _ z) in H2; auto with *.
 apply H1 with y H5; auto.
Qed.

Lemma plump_Acc : forall ub p x,
  plump ub p x -> x ⊆ ub -> Acc in_set x.
induction p using Acc_indd; simpl; intros.
destruct H0.
constructor; intros.
apply H with y (H1 _ H3); auto with *.
Qed.

Definition isOrd x :=
  { p:Acc in_set x | plump x p x }.

Lemma isOrd_ext : forall x y, x == y -> isOrd x -> isOrd y.
destruct 2.
generalize x0; rewrite H; intro.
exists H0.
rewrite <- (plump_morph x y x0 H0 x y); trivial.
Qed.

Instance isOrd_morph : Proper (eq_set ==> iff) isOrd.
do 2 red; split; intros.
 apply isOrd_ext with x; trivial.

 symmetry in H.
 apply isOrd_ext with y; trivial.
Qed.

Lemma isOrd_inv : forall x y,
  isOrd x -> lt y x -> isOrd y.
intros.
destruct H.
exists (Acc_inv x0 _ H0).
destruct x0; simpl in *.
destruct p; auto.
Qed.

Lemma isOrd_plump : forall z, isOrd z ->
 forall x y, isOrd x -> x ⊆ y -> y ∈ z -> x ∈ z.
destruct 1; intros.
revert p.
destruct x;simpl; intros.
destruct p.
apply H3 with y H1; trivial.
destruct H.
apply plump_bound with (2:=p); reflexivity.
Qed.

Lemma isOrd_intro : forall x,
  (forall a b, isOrd a -> a ⊆ b -> b ∈ x -> a ∈ x) ->
  (forall y, y ∈ x -> isOrd y) ->
  isOrd x.
intros.
exists (Acc_intro _ (fun y h => proj1_sig (H0 y h))); simpl.
split; intros.
 destruct (H0 y H1).
 rewrite <- (plump_morph y y x0 _ y y); auto with *.

 apply H with y; trivial.
 exists (plump_Acc _ _ _ H1 H2).
 apply plump_bound with (2:=H1); trivial.
Qed.

Lemma isOrd_trans : forall x y z,
  isOrd x -> lt z y -> lt y x -> lt z x.
unfold lt.
destruct 1.
revert y z p.
induction x0 using Acc_indd; simpl; intros.
assert (isOrd x).
 exists (Acc_intro _ a); simpl; trivial.
destruct p.
apply isOrd_plump with y; trivial.
 apply isOrd_inv with y; trivial.
 apply isOrd_inv with x; trivial.

 red; intros.
 apply H with H1 z; auto.
Qed.

Lemma isOrd_ind : forall x (P:set->Prop),
  (forall y, isOrd y ->
   y ⊆ x ->
   (forall z, lt z y -> P z) -> P y) ->
  isOrd x -> P x.
intros.
destruct H0.
cut (forall x', x' == x -> P x'); auto with *.
revert p H .
induction x0 using Acc_indd; simpl; intros.
destruct p.
assert (isOrd x).
 exists (Acc_intro _ a); simpl; split; trivial.
apply H0; intros; auto with *.
 rewrite H1; trivial.

 red; intros.
 rewrite <- H1; trivial.

rewrite H1 in H5.
clear x' H1.
apply H with (r:=H5); intros; auto with *.
apply H0; intros; auto.
red; intros.
apply isOrd_trans with z; auto.
apply H6; trivial.
Qed.

Lemma lt_antirefl : forall x, isOrd x -> ~ lt x x.
induction 1 using isOrd_ind; intros.
red; intros; apply H1 with y; trivial.
Qed.

Lemma isOrd_zero : isOrd zero.
apply isOrd_intro; intros.
 elim empty_ax with b; trivial.
 elim empty_ax with y; trivial.
Qed.

Definition osucc x := subset (power x) isOrd.

Instance osucc_morph : morph1 osucc.
unfold osucc; do 2 red; intros.
apply subset_morph.
 rewrite H; reflexivity.

 red; auto with *.
Qed.

Lemma lt_osucc : forall x, isOrd x -> lt x (osucc x).
unfold osucc, lt; intros.
apply subset_intro; trivial.
apply power_intro; auto.
Qed.

Hint Resolve isOrd_zero lt_osucc.

Lemma olts_le : forall x y, lt x (osucc y) -> x ⊆ y.
red; intros.
apply subset_elim1 in H.
apply power_elim with (1:=H); trivial.
Qed.

Lemma ole_lts : forall x y, isOrd x -> x ⊆ y -> lt x (osucc y).
intros.
apply subset_intro; trivial.
apply power_intro; trivial.
Qed.

Lemma oles_lt : forall x y,
  isOrd x ->
  osucc x ⊆ y ->
  lt x y.
intros.
apply H0.
apply lt_osucc; trivial.
Qed.

Lemma le_lt_trans : forall x y z, isOrd z -> lt x (osucc y) -> lt y z -> lt x z.
intros.
apply isOrd_plump with y; trivial.
 apply subset_elim2 in H0; destruct H0.
 rewrite H0; trivial.

 apply olts_le; trivial.
Qed.

Lemma isOrd_succ : forall n, isOrd n -> isOrd (osucc n).
unfold osucc.
intros.
apply isOrd_intro; intros.
 apply subset_intro; trivial.
 apply subset_elim1 in H2.
 apply power_intro; intros.
 apply H1 in H3.
 apply power_elim with (1:=H2); trivial.

 apply subset_elim2 in H0.
 destruct H0.
 rewrite H0; trivial.
Qed.
Hint Resolve isOrd_succ.

Lemma lt_osucc_compat : forall n m, isOrd m -> lt n m -> lt (osucc n) (osucc m).
intros.
apply ole_lts; auto.
 apply isOrd_succ.
 apply isOrd_inv with m; trivial.

 red; intros.
 apply le_lt_trans with n; trivial.
Qed.

  Lemma lt_osucc_inv : forall o o',
    isOrd o ->
    lt (osucc o) (osucc o') ->
    lt o o'.
unfold osucc; intros.
rewrite subset_ax in H0; destruct H0.
destruct H1.
rewrite power_ax in H0.
apply H0.
apply subset_intro; trivial.
apply power_intro; auto.
Qed.

Lemma isOrd_eq : forall o, isOrd o -> o == sup o osucc.
intros.
apply eq_intro; intros.
 rewrite sup_ax.
 2:do 2 red; intros; apply osucc_morph; trivial.
 exists z; auto.
 apply lt_osucc.
 apply isOrd_inv with o; trivial.

 rewrite sup_ax in H0.
 2:do 2 red; intros; apply osucc_morph; trivial.
 destruct H0.
 apply le_lt_trans with x; trivial.
Qed.

Module Examples.

Definition ord_0 := empty.
Definition ord_1 := osucc ord_0.
Definition ord_2 := osucc ord_1.

(* 1 = {0} *)
Lemma ord1 : forall x, x ∈ osucc zero <-> x == zero.
intros.
unfold osucc.
rewrite subset_ax.
split; intros.
 destruct H.
 rewrite power_ax in H.
 apply empty_ext.
 red; intros.
 apply H in H1.
 apply empty_ax with (1:=H1).

 split.
  apply power_intro; intros.
  rewrite H in H0; trivial.

  exists zero; auto.
Qed.

Definition ord_rk_1 P := subset ord_1 (fun _ => P).

Lemma rk1_order : forall P Q, ord_rk_1 P ⊆ ord_rk_1 Q <-> (P->Q).
split; intros.
 assert (zero ∈ ord_rk_1 P).
  apply subset_intro; trivial.
  unfold ord_1; apply lt_osucc; auto.
 apply H in H1.
 apply subset_elim2 in H1.
 destruct H1; trivial.

 red; intros.
 apply subset_intro.
  apply subset_elim1 in H0; trivial.

  apply subset_elim2 in H0.
  destruct H0; auto.
Qed.

Lemma isOrd_rk_1 : forall P, isOrd (ord_rk_1 P).
intros.
apply isOrd_intro; intros.
 unfold ord_rk_1 in H1; rewrite subset_ax in H1; destruct H1.
 destruct H2.
 clear x H2.
 apply subset_intro; auto.
 apply isOrd_plump with b; auto.
 unfold ord_1; auto.

 apply subset_elim1 in H.
 apply isOrd_inv with (osucc zero); auto.
Qed.

Definition isOrd2 x := exists P:Prop, x == ord_rk_1 P.

(* 2 = {o| 0<=o<=1 } isomorphic to Prop *)
Lemma ord2 : forall x, x ∈ ord_2 <-> exists P, x == ord_rk_1 P.
intros.
unfold ord_2, osucc at 1.
rewrite subset_ax.
rewrite power_ax.
split; intros.
 destruct H.
 destruct H0.
 rewrite <- H0 in H1; clear H0 x0.
 exists (zero ∈ x).
 apply subset_ext; intros; auto.
  apply ord1 in H0.
  rewrite H0; trivial.

  exists x0; auto with *.
  specialize H with (1:=H0).
  apply ord1 in H.
  rewrite H in H0; trivial.

 destruct H.
 split; intros.
  rewrite H in H0; clear H x.
  apply subset_elim1 with (1:=H0).

  exists x; auto with *.
  rewrite H.
  apply isOrd_rk_1.
Qed.

Definition ord_rk_2 (P2:Prop->Prop) :=
  subset ord_2 (fun x => exists2 P, x == ord_rk_1 P & P2 P).

Definition decr_2 (P2:Prop->Prop) := forall P Q:Prop, (P -> Q) -> (P2 Q -> P2 P).

Lemma isOrd_rk_2 : forall P2, decr_2 P2 -> isOrd (ord_rk_2 P2).
intros.
apply isOrd_intro; intros.
 assert (a ∈ ord_2).
  apply isOrd_plump with b; auto.
  unfold ord_2, ord_1; auto.
  apply subset_elim1 in H2; trivial.
 apply subset_intro; auto.
 rewrite ord2 in H3.
 destruct H3.
 exists x; trivial.
 unfold ord_rk_2 in H2; rewrite subset_ax in H2; destruct H2.
 destruct H4.
 destruct H5.
 apply (H x x1); trivial.
 rewrite H4 in H1; rewrite H5 in H1; rewrite H3 in H1.
 rewrite <- rk1_order; trivial.

 apply subset_elim1 in H0.
 apply isOrd_inv with (osucc (osucc zero)); auto.
Qed.

(* 3 is isomorphic to decreasing functions of type Prop->Prop *)
Lemma ord3 : forall x,
  x ∈ osucc ord_2 <-> exists2 P2, decr_2 P2 & x == ord_rk_2 P2.
intros.
unfold osucc.
rewrite subset_ax.
rewrite power_ax.
split; intros.
 destruct H.
 destruct H0.
 rewrite <- H0 in H1; clear H0 x0.
 exists (fun P => ord_rk_1 P ∈ x).
  red; intros.
  apply isOrd_plump with (ord_rk_1 Q); trivial.
   assert (ord_rk_1 P ∈ ord_2).
    rewrite ord2.
    exists P; auto with *.
   apply isOrd_inv with ord_2; auto.
   unfold ord_2, ord_1; auto.

   rewrite rk1_order; trivial.

  apply subset_ext; intros; auto.
   apply ord2 in H0.
   destruct H2.
   rewrite H2; trivial.
   exists x0; auto with *.
   specialize H with (1:=H0).
   apply ord2 in H.
   destruct H.
   exists x1; trivial.
   rewrite H in H0; trivial.

 destruct H.
 split; intros.
  rewrite H0 in H1; clear H0 x.
  apply subset_elim1 with (1:=H1).

  exists x; auto with *.
  rewrite H0.
  apply isOrd_rk_2; trivial.
Qed.

End Examples.

(* Increasing *)

Definition increasing F :=
  forall x y, isOrd x -> isOrd y -> y ⊆ x -> F y ⊆ F x.
(*
Definition directed o F :=
  forall o', isOrd o -> lt o' o -> F o' ⊆ F o.
*)
Definition increasing_bounded o F :=
  forall x x', lt x' o -> lt x x' -> F x ⊆ F x'.

Definition succOrd o := exists2 o', isOrd o' & o == osucc o'.

(* Limit ordinals *)

Definition limitOrd o := isOrd o /\ (forall x, lt x o -> lt (osucc x) o).

Lemma limit_is_ord : forall o, limitOrd o -> isOrd o.
destruct 1; trivial.
Qed.
Hint Resolve limit_is_ord.

Lemma limit_union : forall o, limitOrd o -> union o == o.
destruct 1.
apply eq_intro; intros.
 apply union_elim in H1; destruct H1.
 apply isOrd_trans with x; trivial.

 apply union_intro with (osucc z).
  apply lt_osucc.
  apply isOrd_inv with o; trivial.

  apply H0; trivial.
Qed.

Lemma limit_union_intro : forall o, isOrd o -> union o == o -> limitOrd o.
split; trivial.
unfold lt; intros.
assert (isOrd x).
 apply isOrd_inv with o; trivial.
rewrite <- H0 in H1.
apply union_elim in H1; destruct H1.
apply isOrd_plump with x0; auto.
red; intros.
apply le_lt_trans with x; trivial.
apply isOrd_inv with o; trivial.
Qed.

Lemma discr_lim_succ : forall o, limitOrd o -> succOrd o -> False.
destruct 1; destruct 1.
assert (lt (osucc x) o).
 apply H0.
 rewrite H2; auto.
rewrite <- H2 in H3.
elim lt_antirefl with o; trivial.
Qed.

Lemma isOrd_union2 : forall x y,
  isOrd x ->
  isOrd y ->
  isOrd (x ∪ y).
intros.
apply isOrd_intro; intros.
 apply union2_elim in H3; destruct H3.
  apply union2_intro1.
  apply isOrd_plump with b; trivial.

  apply union2_intro2.
  apply isOrd_plump with b; trivial.

 apply union2_elim in H1; destruct H1.
  apply isOrd_inv with x; trivial.
  apply isOrd_inv with y; trivial.
Qed.

Lemma isOrd_inter2 : forall x y,
  isOrd x -> isOrd y -> isOrd (x ∩ y).
intros.
apply isOrd_intro; intros.
 rewrite inter2_def in H3|-*; destruct H3; split.
  apply isOrd_plump with b; trivial.
  apply isOrd_plump with b; trivial.

 apply inter2_incl1 in H1.
 apply isOrd_inv with x; trivial.
Qed.

Lemma inter2_succ : forall x y,
  isOrd x -> isOrd y ->
  osucc x ∩ osucc y == osucc (x ∩ y).
intros.
apply eq_intro; intros.
 rewrite inter2_def in H1.
 destruct H1.
 apply ole_lts; eauto using isOrd_inv.
 apply olts_le in H1; apply olts_le in H2.
 red; intros; rewrite inter2_def; auto.

 assert (isOrd z).
  apply isOrd_inv with (osucc (x ∩ y)); trivial.
  apply isOrd_succ; apply isOrd_inter2; trivial.
 rewrite inter2_def; split.
  apply ole_lts; eauto using isOrd_inv.
  apply olts_le in H1.
  transitivity (x ∩ y); trivial.
  apply inter2_incl1.

  apply ole_lts; eauto using isOrd_inv.
  apply olts_le in H1.
  transitivity (x ∩ y); trivial.
  apply inter2_incl2.
Qed.

Module NotDirected.
Import Examples.
Section S.

 Variable P Q:Prop.

 Definition a := ord_rk_2 (fun A => (A->P) \/ (A->Q)).

 Lemma P_in_a : ord_rk_1 P ∈ a.
unfold a, ord_rk_2.
apply subset_intro.
 rewrite ord2.
 exists P; auto with *.

 exists P; auto with *.
Qed.

 Lemma PQ_in_a : ord_rk_1 (P\/Q) ∈ a -> (P->Q) \/ (Q->P).
unfold a, ord_rk_2; intros.
apply subset_elim2 in H; destruct H.
destruct H0.
rewrite H0 in H.
assert (P\/Q->x0).
 rewrite <- rk1_order.
 rewrite H; reflexivity.
tauto.
Qed.

End S.
End NotDirected.

Section OrdinalUpperBound.

  Variable I : set.
  Variable f : set -> set.
  Hypothesis f_ext : ext_fun I f.
  Hypothesis f_ord : forall x, x ∈ I -> isOrd (f x).

  Lemma isOrd_supf_intro : forall n, n ∈ I -> f n ⊆ sup I f.
red; intros.
rewrite sup_ax; trivial.
exists n; trivial.
Qed.

  Lemma isOrd_supf_elim : forall x, lt x (sup I f) -> exists2 n, n ∈ I & lt x (f n).
intros.
rewrite sup_ax in H; trivial.
Qed.

  Lemma isOrd_supf : isOrd (sup I f).
apply isOrd_intro; intros.
 elim isOrd_supf_elim with (1:=H1); intros.
 apply isOrd_supf_intro with x; trivial.
 apply isOrd_plump with b; auto.

 elim isOrd_supf_elim with (1:=H); intros.
 apply isOrd_inv with (f x); auto.
Qed.

End OrdinalUpperBound.

(* Projection toward ordinals *)

Definition toOrd (x : set) :=
  sup (subset x isOrd) osucc.

Instance toOrd_morph : morph1 toOrd.
do 2 red; intros.
unfold toOrd.
apply sup_morph.
 apply subset_morph; auto with *.

 red; intros; rewrite H1; reflexivity.
Qed.

Lemma toOrd_isOrd : forall x, isOrd (toOrd x).
intros.
unfold toOrd.
apply isOrd_supf; intros.
 red; red; intros.
 rewrite H0; reflexivity.

 apply isOrd_succ.
 destruct subset_elim2 with (1:=H).
 rewrite H0; trivial.
Qed.

Lemma toOrd_ord : forall o, isOrd o -> toOrd o == o.
intros.
unfold toOrd.
apply eq_intro; intros.
 rewrite sup_ax in H0.
 2:red; red; intros; rewrite H2; reflexivity.
 destruct H0.
 apply le_lt_trans with x; auto.
 apply subset_elim1 with (1:=H0).

 rewrite sup_ax.
 2:red; red; intros; rewrite H2; reflexivity.
 exists z.
  apply subset_intro; trivial.
  apply isOrd_inv with o; trivial.

  apply lt_osucc.
  apply isOrd_inv with o; trivial.
Qed.

Section TransfiniteRecursion.

  Variable F : (set -> set) -> set -> set.

  Variable ord : set.
  Hypothesis Fmorph : forall o o' f f', isOrd o -> o ⊆ ord ->
    o == o' -> eq_fun o f f' -> F f o == F f' o'.

  Definition TR_rel o y := (isOrd o/\o⊆ ord) /\
    forall (P:set->set->Prop),
    (forall o o' x x', isOrd o -> o ⊆ ord -> o == o' -> x == x' -> P o x -> P o' x') ->
    (forall o' f, isOrd o' -> o' ⊆ ord -> ext_fun o' f ->
     (forall n, lt n o' -> P n (f n)) ->
     P o' (F f o')) ->
    P o y.

  Instance TR_rel_morph : Proper (eq_set ==> eq_set ==> iff) TR_rel.
apply morph_impl_iff2; auto with *.
do 4 red; unfold TR_rel; intros.
destruct H1 as ((xo, xle),Hrec); split; intros.
 rewrite <- H; auto.

 apply (H1 x y x0 y0); auto.
 apply Hrec; auto.
Qed.

  Lemma TR_rel_intro : forall x f,
    isOrd x ->
    x ⊆ ord ->
    ext_fun x f ->
    (forall y, y ∈ x -> TR_rel y (f y)) ->
    TR_rel x (F f x).
red; intros.
split; intros; auto.
apply H4; trivial; intros.
apply H2; trivial.
Qed.

  Lemma TR_rel_inv : forall x y,
    TR_rel x y ->
    exists2 f,
      ext_fun x f /\ (forall y, y ∈ x -> TR_rel y (f y)) &
      y == F f x.
intros.
apply (@proj2 (TR_rel x y)).
destruct H as ((H,Hle),H0).
apply H0; intros.
 destruct H5; split.
  rewrite <- H3; rewrite <- H4; trivial.

  destruct H6 as (f,(fm,eqf),eqF); exists f; trivial.
   split; intros.
    do 2 red; intros.
    rewrite <- H3 in H6; auto.
    rewrite <- H3 in H6; auto.

    rewrite <- H4; rewrite eqF; auto.
assert (TR_relsub := fun n h => proj1 (H4 n h)); clear H4.
split.
 apply TR_rel_intro; trivial.

 exists f; auto with *.
Qed.

  Lemma TR_rel_fun :
    forall x y, TR_rel x y -> forall y', TR_rel x y' -> y == y'.
intros x y (xo,H).
apply H; intros.
 rewrite <- H3; rewrite <- H2 in H5; auto.
apply TR_rel_inv in H4; destruct H4.
destruct H4.
rewrite H5; clear y' H5.
apply Fmorph; intros; auto with *.
red; intros.
apply H3; trivial.
rewrite H7 in H5|-*; auto.
Qed.

Require Import ZFrepl.

  Lemma TR_rel_repl_rel :
    forall x, repl_rel x TR_rel.
split; intros.
 rewrite <- H0; rewrite <- H1; trivial.

 apply TR_rel_fun with x0; trivial.
Qed.

  Lemma TR_rel_def : forall o, isOrd o -> o ⊆ ord -> exists y, TR_rel o y.
induction 1 using isOrd_ind; intros.
assert (forall z, lt z y -> uchoice_pred (fun y => TR_rel z y)).
 intros.
 destruct H1 with z; trivial.
  red; intros; apply H2; apply isOrd_trans with z; trivial.
 split; intros.
  rewrite <- H5; trivial.
 split; intros.
  exists x; trivial.
 apply TR_rel_fun with z; trivial.
exists (F (fun z => uchoice (fun y => TR_rel z y)) y).
apply TR_rel_intro; intros; trivial.
 do 2 red; intros.
 apply uchoice_morph; intros; auto.
 rewrite H5; reflexivity.
apply uchoice_def; auto.
Qed.

  Lemma TR_rel_choice_pred : forall o, isOrd o -> o ⊆ ord ->
    uchoice_pred (fun y => TR_rel o y).
split; intros.
 rewrite <- H1; trivial.
split; intros.
 apply TR_rel_def; trivial.
apply TR_rel_fun with o; trivial.
Qed.

  Definition TR := uchoice (fun y => TR_rel ord y).

(*
  Lemma TR_morph : forall x x', isOrd x -> x == x' -> TR x == TR x'.
intros.
unfold TR.
unfold uchoice.
apply union_morph.
apply eq_intro; intros.
 rewrite repl_ax in H1; intros.
  rewrite repl_ax; intros.
   destruct H1.
   destruct H2.
   exists x0; trivial.
   exists x1; trivial.
   revert H3; apply basic.iff_impl.
   apply TR_rel_morph; auto with *.

   apply TR_rel_fun with x'; trivial.

  apply TR_rel_fun with x; trivial.

 rewrite repl_ax in H1; intros.
  rewrite repl_ax; intros.
   destruct H1.
   destruct H2.
   exists x0; trivial.
   exists x1; trivial.
   revert H3; apply basic.iff_impl.
   apply TR_rel_morph; auto with *.

   apply TR_rel_fun with x; trivial.

  apply TR_rel_fun with x'; trivial.
Qed.
*)

  Lemma TR_eqn0 : forall o, isOrd o -> o ⊆ ord ->
     uchoice (fun y => TR_rel o y) == F (fun o => uchoice (fun y => TR_rel o y)) o.
intros.
specialize TR_rel_choice_pred with (1:=H) (2:=H0); intro.
apply uchoice_def in H1.
apply TR_rel_inv in H1.
destruct H1.
destruct H1.
rewrite H2.
apply Fmorph; intros; auto with *.
red; intros.
apply TR_rel_fun with x'.
 rewrite <- H5; auto.

 apply uchoice_def.
 apply TR_rel_choice_pred.
 rewrite <- H5; apply isOrd_inv with o; trivial.
 red; intros; apply H0; apply isOrd_trans with x'; trivial.
 rewrite <- H5; trivial.
Qed.

End TransfiniteRecursion.

  Lemma TR_rel_irrel : forall F b1 b2 o y,
    o ⊆ b2 ->
    TR_rel F b1 o y -> TR_rel F b2 o y.
intros.
revert H; apply H0; intros.
 rewrite <- H2 in H5.
 generalize (H4 H5).
 apply TR_rel_morph; auto with *.

 apply TR_rel_intro; trivial; intros.
 apply H3; trivial.
 transitivity o'; trivial.
 red; intros; apply isOrd_trans with y0; trivial.
Qed.

  Instance TR_morph : forall F, morph1 (TR F).
do 2 red; intros.
unfold TR.
apply uchoice_morph_raw.
red; intros.
transitivity (TR_rel F x y y0).
 apply TR_rel_morph; trivial.

 split; apply TR_rel_irrel; auto with *.
 rewrite H; reflexivity.
Qed.

  Lemma TR_morph_gen : forall o o' F F',
    isOrd o ->
    (forall x x' f f', isOrd x -> x ⊆ o -> x == x' -> eq_fun x f f' -> F f x == F' f' x') ->
    o == o' -> TR F o == TR F' o'.
unfold TR; intros.
apply uchoice_morph_raw.
red; intros.
split; intros.
 red; intros.
 destruct H3; split.
  rewrite <- H1; trivial.

  intros.
  destruct H3.
  apply H5 with o x; trivial.
   rewrite H1; reflexivity.

   apply H4; intros.
    rewrite H1 in H9; eauto.

    rewrite H1 in H9.
    apply H5 with o'0 (F' f o'0); auto with *.
    symmetry; apply H0; auto with *.
    rewrite H1; trivial.

 red; intros.
 destruct H3; split.
  rewrite H1; trivial.

  intros.
  destruct H3.
  apply H5 with o' y; auto with *.
   rewrite H1; reflexivity.

   apply H4; intros.
    rewrite <- H1 in H9; eauto.

    rewrite <- H1 in H9.
    apply H5 with o'0 (F f o'0); auto with *.
Qed.

  Lemma TR_eqn : forall F o,
    isOrd o ->
    (forall x x' f f', isOrd x -> x ⊆ o -> x == x' -> eq_fun x f f' -> F f x == F f' x') ->
    TR F o == F (TR F) o.
intros.
unfold TR; rewrite TR_eqn0; eauto with *.
apply H0; auto with *.
red; intros.
apply uchoice_morph_raw.
red; intros.
transitivity (TR_rel F o x' y).
 apply TR_rel_morph; trivial.
rewrite H2 in H1.
split; apply TR_rel_irrel; auto with *.
red; intros; apply isOrd_trans with x'; trivial.
Qed.

  Lemma TR_ind : forall F o (P:set->set->Prop),
    (forall x x' f f', isOrd x -> x ⊆ o -> x == x' -> eq_fun x f f' -> F f x == F f' x') ->
    (forall x, isOrd x -> x ⊆ o ->
     forall y y', y == y' -> P x y -> P x y') ->
    isOrd o ->
    (forall y, isOrd y -> y ⊆ o ->
     (forall x, lt x y -> P x (TR F x)) ->
     P y (F (TR F) y)) ->
    P o (TR F o).
induction 3 using isOrd_ind; intros.
apply H0 with (F (TR F) y); auto with *.
 symmetry; apply TR_eqn; trivial; intros.
 apply H; auto.
 transitivity y; trivial.
apply H4; trivial; intros.
 reflexivity.
apply H3; trivial; intros.
apply H4; trivial.
red; intros; apply isOrd_trans with x; auto.
apply H7; trivial.
Qed.

  Lemma TR_typ : forall F o X,
    isOrd o ->
    (forall x x' f f', isOrd x -> x ⊆ o -> x == x' -> eq_fun x f f' -> F f x == F f' x') ->
    morph1 X ->
    (forall y f, isOrd y -> y ⊆ o ->
     (forall z, lt z y -> f z ∈ X z) -> F f y ∈ X y) ->
    TR F o ∈ X o.
intros F o X oo Fm Xm Hrec.
apply TR_ind; intros; auto.
rewrite <- H1; trivial.
Qed.

(* Specialized version where the case of limit ordinals is union *)
Section TransfiniteIteration.

  Variable F : set -> set.
  Hypothesis Fmorph : Proper (eq_set ==> eq_set) F.

Let G f o := sup o (fun o' => F (f o')).

Lemma Gmorph : forall o o' f f',
    o == o' -> eq_fun o f f' -> G f o == G f' o'.
unfold G; intros.
apply sup_morph; trivial.
red; auto.
Qed.
Hint Resolve Gmorph.

  Definition TI := TR G.

(*
  Lemma TI_morph : forall x x', isOrd x -> x == x' -> TI x == TI x'.
unfold TI; intros.
apply TR_morph; auto with *.
Qed.
*)
  Instance TI_morph : morph1 TI.
unfold TI; do 2 red; intros.
apply TR_morph; auto with *.
Qed.

  Lemma TI_fun_ext : forall x, ext_fun x (fun y => F (TI y)).
do 2 red; intros.
apply Fmorph.
apply TI_morph; trivial.
(*apply isOrd_inv with x; trivial.*)
Qed.
(*
  Lemma TI_fun_ext : forall x, isOrd x -> ext_fun x (fun y => F (TI y)).
do 2 red; intros.
apply Fmorph.
apply TI_morph; trivial.
apply isOrd_inv with x; trivial.
Qed.
*)
Hint Resolve TI_fun_ext.

  Lemma TI_eq : forall o,
    isOrd o ->
    TI o == sup o (fun o' => F (TI o')).
intros.
unfold TI.
apply TR_eqn; auto.
Qed.

  Lemma TI_intro : forall o o' x,
    isOrd o ->
    lt o' o ->
    x ∈ F (TI o') ->
    x ∈ TI o.
intros.
rewrite TI_eq; trivial.
rewrite sup_ax; auto.
exists o'; trivial.
Qed.

  Lemma TI_elim : forall o x,
    isOrd o ->
    x ∈ TI o ->
    exists2 o', lt o' o & x ∈ F (TI o').
intros.
rewrite TI_eq in H0; trivial.
rewrite sup_ax in H0; auto.
Qed.

  Lemma TI_initial : TI zero == empty.
apply empty_ext; red; intros.
apply TI_elim in H.
 destruct H.
 elim empty_ax with (1:=H).

 apply isOrd_zero.
Qed.

  Lemma TI_typ : forall n X,
    (forall a, a ∈ X -> F a ∈ X) ->
    isOrd n ->
    (forall m G, isOrd m -> m ⊆ n ->
     ext_fun m G ->
     (forall x, lt x m -> G x ∈ X) -> sup m G ∈ X) ->
    TI n ∈ X.
induction 2 using isOrd_ind; intros.
rewrite TI_eq; trivial.
apply H3 with (G:=fun o => F (TI o)); intros; auto with *.
apply H.
apply H2; trivial; intros.
apply H3; auto.
red; intros.
apply H6 in H9.
apply isOrd_trans with x; trivial.
Qed.

End TransfiniteIteration.
Hint Resolve TI_fun_ext.

(********************************************************************)

Require Import ZFrepl.

Section LimOrd.

  Variable f : nat -> set.
  Variable ford : forall n, isOrd (f n).

  Definition ord_sup :=
    union (repl N (fun x y => exists2 n, x == nat2set n & f n == y)).

  Lemma repl_sup :
    repl_rel N (fun x y => exists2 n, x == nat2set n & f n == y).
split; intros.
 destruct H2.
 exists x0.
  rewrite <- H0; trivial.
  rewrite <- H1; trivial.

 destruct H0.
 destruct H1.
 rewrite <- H2; rewrite <- H3.
 replace x1 with x0; try reflexivity.
 apply nat2set_inj.
 rewrite <- H0; trivial.
Qed.

  Lemma isOrd_sup_intro : forall n, f n ⊆ ord_sup.
unfold ord_sup.
red; intros.
apply union_intro with (f n); trivial.
apply repl_intro with (nat2set n).
 exact repl_sup.

 apply nat2set_typ.

 exists n; reflexivity.
Qed.

  Lemma isOrd_sup_elim : forall x, lt x ord_sup -> exists n, lt x (f n).
unfold ord_sup; intros.
elim union_elim with (1:=H); clear H; intros.
elim repl_elim with (1:=repl_sup) (2:=H0); intros.
destruct H2.
exists x2.
rewrite H3; trivial.
Qed.

  Lemma isOrd_sup : isOrd ord_sup.
apply isOrd_intro; intros.
 elim isOrd_sup_elim with (1:=H1); intros.
 apply isOrd_sup_intro with x.
 apply isOrd_plump with b; auto.

 elim isOrd_sup_elim with (1:=H); intros.
 apply isOrd_inv with (f x); trivial.
Qed.

End LimOrd.

Lemma isOrd_union : forall x,
  (forall y, y ∈ x -> isOrd y) -> isOrd (union x).
intros.
apply isOrd_intro; intros.
 rewrite union_ax in H2|-*; destruct H2.
 exists x0; trivial.
 apply isOrd_plump with b; auto.

 rewrite union_ax in H0; destruct H0.
 apply isOrd_inv with x0; auto.
Qed.

Lemma isOrd_inter : forall x,
  (forall y, y ∈ x -> isOrd y) -> isOrd (inter x).
intros.
apply isOrd_intro; intros.
 apply inter_intro; trivial.
  intros.
  apply isOrd_plump with b; auto.
  apply inter_elim with (1:=H2); trivial.

  destruct inter_non_empty with (1:=H2); eauto.

 destruct inter_non_empty with (1:=H0).
 eauto using isOrd_inv.
Qed.

Fixpoint nat2ordset n :=
  match n with
  | 0 => zero
  | S k => osucc (nat2ordset k)
  end.

Lemma nat2ordset_typ : forall n, isOrd (nat2ordset n).
induction n; simpl; intros.
 apply isOrd_zero.
 apply isOrd_succ; trivial.
Qed.
Hint Resolve nat2ordset_typ.

(* Ordinal omega *)

Definition omega := ord_sup nat2ordset.

Lemma isOrd_omega : isOrd omega.
apply isOrd_sup; trivial.
Qed.
Hint Resolve isOrd_omega.

Lemma zero_omega : lt zero omega.
apply isOrd_sup_intro with 1; simpl.
apply lt_osucc; trivial.
Qed.
Hint Resolve zero_omega.

Lemma osucc_omega : forall n, lt n omega -> lt (osucc n) omega.
intros.
apply isOrd_sup_elim in H; destruct H.
apply isOrd_sup_intro with (S x); simpl.
apply lt_osucc_compat; auto.
Qed.
Hint Resolve osucc_omega.

Lemma omega_limit_ord : limitOrd omega.
split; auto.
Qed.
Hint Resolve omega_limit_ord.

Require Import Peano_dec.
Require Import Compare_dec.

  Lemma isDir_omega : isDir omega.
red; intros.
apply isOrd_sup_elim in H.
destruct H.
apply isOrd_sup_elim in H0.
destruct H0.
exists (nat2ordset (Peano.max x0 x1)).
 apply isOrd_sup_intro with (f:=nat2ordset) (n:=S(Peano.max x0 x1)).
  simpl.
  apply lt_osucc.
  apply nat2ordset_typ.

 split; red; intros.
  destruct (le_gt_dec x0 x1).
   rewrite Peano.max_r; auto with arith.
   apply isOrd_trans with x; trivial.
   clear H1; revert x H.
   elim l; simpl; intros; auto.
   apply isOrd_trans with (nat2ordset m); auto.

   rewrite Peano.max_l; auto with arith.
   apply isOrd_trans with x; trivial.

  destruct (le_gt_dec x0 x1).
   rewrite Peano.max_r; auto with arith.
   apply isOrd_trans with y; trivial.

   rewrite Peano.max_l; auto with arith.
   apply isOrd_trans with y; trivial.
   clear H1; revert y H0.
   elimtype (x1 <= x0)%nat; simpl; intros; auto with arith.
   apply isOrd_trans with (nat2ordset m); auto.
Qed.

Hint Resolve isDir_omega.

(* Higher ordinals *)

Inductive ord : Set := OO | OS (o:ord) | OL (f:nat->ord).

Fixpoint ord2set (o:ord) : set :=
  match o with
  | OO => zero
  | OS k => osucc (ord2set k)
  | OL f => ord_sup (fun k => ord2set (f k))
  end.

Lemma ord2set_typ : forall o, isOrd (ord2set o).
induction o; simpl; intros.
 apply isOrd_zero.
 apply isOrd_succ; trivial.
 apply isOrd_sup; trivial.
Qed.
Hint Resolve ord2set_typ.

(* f^w(o) *)
Definition iter_w (f:set->set) o :=
  ord_sup(nat_rect(fun _=>set) o (fun _ => f)).

Lemma isOrd_iter_w : forall f o,
  (forall x, isOrd x -> isOrd (f x)) ->
  isOrd o ->
  isOrd (iter_w f o).
intros.
unfold iter_w.
apply isOrd_sup.
induction n; simpl; intros; auto.
Qed.

Definition plus_w := iter_w osucc.


Require Import
  MathClasses.theory.categories
  MathClasses.interfaces.functors
  MathClasses.interfaces.abstract_algebra
  MathClasses.interfaces.sequences.

Section contents.
  Context `{Sequence sq}.

  (* Some derived properties about inject, extend, and fmap: *)
  Lemma inject_epi `{Setoid A} `{Equiv B} `{SgOp B} `{MonUnit B}
    (f g: sq A → B) `{!Monoid_Morphism f} `{!Monoid_Morphism g} :
      f ∘ inject A = g ∘ inject A → f = g.
  Proof with intuition.
   intros.
   pose proof (setoidmor_a f).
   pose proof (monmor_b (f:=g)).
   pose proof (sequence_only_extend_commutes sq (f ∘ inject A) _) as E.
   pose proof (_ : Setoid_Morphism (f ∘ inject A)) as cm.
   rewrite (E f), (E g)...
    apply (sequence_extend_morphism sq)...
    apply cm.
   apply cm.
  Qed.

  Lemma extend_comp
    `{Equiv A}
    `{Equiv B} `{SgOp B} `{MonUnit B}
    `{Equiv C} `{SgOp C} `{MonUnit C}
     (f: B → C) (g: A → B) `{!Monoid_Morphism f} `{!Setoid_Morphism g} :
    extend (f ∘ g) (free:=sq) = f ∘ extend g (free:=sq).
  Proof with try apply _.
   intros.
   pose proof (setoidmor_a g).
   pose proof (monmor_a (f:=f)).
   pose proof (monmor_b (f:=f)).
   symmetry.
   apply (sequence_only_extend_commutes sq (f ∘ g))...
   symmetry.
   rewrite <- (sequence_extend_commutes sq g _) at 1.
   apply sm_proper.
  Qed.

  Lemma extend_inject `{Setoid A}: extend (inject A) = @id (sq A).
  Proof.
   symmetry. apply (sequence_only_extend_commutes sq); try apply _.
   apply sm_proper.
  Qed.

(*
  Lemma fmap_alt `{Equiv A} `{Equiv B} (f: A → B) `{!Setoid_Morphism f} :
    extend (inject B ∘ f) = (fmap (v:=A) (w:=B) sq f: sq A → sq B). (* Remove (v:=A) (w:=B) *)
  Proof with try apply _.
   intros.
   pose proof (setoidmor_a f).
   pose proof (setoidmor_b f).
   symmetry.
   apply (sequence_only_extend_commutes sq (inject B ∘ f))...

   symmetry.
   apply (sequence_inject_natural sq)...
  Qed.
*)

  Lemma fold_inject `{Monoid A}: fold sq ∘ inject A = id.
  Proof. apply (sequence_extend_commutes sq id). apply _. Qed.

(*
  Lemma fold_map `{Setoid A} `{Monoid B} (f: A → B) `{!Setoid_Morphism f} :
    extend f (free:=sq) = fold sq ∘ fmap (v:=A) (w:=B) sq f. (* Remove (v:=A) (w:=B) *)
  Proof with try apply _.
   intros.
   symmetry.
   apply (sequence_only_extend_commutes sq _)...
   symmetry.
   change (f = extend id ∘ ((fmap sq f: sq A → sq B) ∘ inject A)).
   rewrite <- (sequence_inject_natural sq f _).
   change (f = fold sq ∘ inject B ∘ f).
   pose proof (_ : Morphisms.ProperProxy equiv f).
   rewrite fold_inject.
   rewrite compose_id_left.
   apply sm_proper.
  Qed.
*)
End contents.

(* In the context of a SemiRing, we have two particularly useful folds: sum and product. *)
Section semiring_folds.
  Context `{SemiRing R} `{Sequence sq}.

  Definition sum: sq R → R := @fold sq _ _ (0:R) (+).
  Definition product: sq R → R := @fold sq _ _ (1:R) mult.

  (* These are implicitly Monoid_Morphisms, and we also easily have: *)
(*
  Lemma distribute_sum (a: R): (a *.) ∘ sum = sum ∘ fmap (v:=R) (w:=R) sq (a *.).
  Proof.
   unfold sum, fold.
   pose proof (_ : Monoid_Morphism (a *.)).
   rewrite <-(extend_comp (a *.) id).
   rewrite compose_id_right.
   rewrite (fold_map (a *.)).
   intros x y E. now rewrite E.
  Qed.
*)
End semiring_folds.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                                                          *)
(*  freevars.v                                                              *)
(*                                                                          *)
(*  This file contains the definition of free variables                     *)
(*  and some related properties.                                            *)
(*                                                                          *)
(*                                                                          *)
(*  Jill Seaman                                                             *)
(*  Coq V5.8                                                                *)
(*  November  1993                                                          *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                                freevars.v                                *)
(****************************************************************************)

Require Import syntax.
Require Import utils.

(********************************************************)
(*   Free Variables, Definition                         *)
(*							*)
(*   (FV x e) -> x in FV(e)				*)
(*							*)
(********************************************************)

Inductive FV (z : vari) : tm -> Prop :=
  | FV_abs :
      forall e : tm,
      FV z e -> forall v : vari, z <> v -> forall t : ty, FV z (abs v t e)
  | FV_fix :
      forall e : tm,
      FV z e -> forall v : vari, z <> v -> forall t : ty, FV z (Fix v t e)
  | FV_appl1 : forall e_1 e_2 : tm, FV z e_1 -> FV z (appl e_1 e_2)
  | FV_appl2 : forall e_1 e_2 : tm, FV z e_2 -> FV z (appl e_1 e_2)
  | FV_cond1 : forall e_1 e_2 e_3 : tm, FV z e_1 -> FV z (cond e_1 e_2 e_3)
  | FV_cond2 : forall e_1 e_2 e_3 : tm, FV z e_2 -> FV z (cond e_1 e_2 e_3)
  | FV_cond3 : forall e_1 e_2 e_3 : tm, FV z e_3 -> FV z (cond e_1 e_2 e_3)
  | FV_var : forall v : vari, z = v -> FV z (var v)
  | FV_succ : forall e : tm, FV z e -> FV z (succ e)
  | FV_prd : forall e : tm, FV z e -> FV z (prd e)
  | FV_is_o : forall e : tm, FV z e -> FV z (is_o e)
  | FV_closa :
      forall (v : vari) (t : ty) (e e_1 : tm),
      FV z e_1 -> FV z (clos e v t e_1)
  | FV_closb :
      forall (v : vari) (t : ty) (e e_1 : tm),
      FV z e -> z <> v -> FV z (clos e v t e_1).

(****************************************************************)
(*  notFV							*)
(*    These theorems state what ~(FV v e) implies:		*)
(*								*)
(*    ~(FV x (abs v t e)) ---> x=v \/ ~(FV x e)		        *)
(*    ~(FV v (appl e1 e2)) ---> ~(FV v e1) /\ ~(FV v e2)	*)
(*    ~(FV v (cond e1 e2 e3)) ---> 				*)
(*		    ~(FV v e1) /\ ~(FV v e2) /\ ~(FV v e3)	*)
(*    ~(FV v (var x)) --->  ~v=x				*)
(*    ~(FV v (succ e)) ---> ~(FV v e)				*)
(*    ~(FV v (prd e)) ---> ~(FV v e)				*)
(*    ~(FV v (is_o e)) ---> ~(FV v e)				*)
(*    ~(FV x (fix v t e)) ---> x=v \/ ~(FV x e)		        *)
(*    ~(FV x (clos e v t a))->					*)
(*                   ~(FV x a) /\ (x=v \/ ~(FV x e))	        *)
(****************************************************************)

Goal
forall (x v : vari) (t : ty) (e : tm),
~ FV x (abs v t e) -> x = v \/ ~ FV x e.
intros.
specialize (Xmidvar x v); simple induction 1; intro A.
left; assumption.
right; red in |- *; intro; apply H; apply FV_abs; assumption.
Save notFV_abs.

Goal
forall (v : vari) (e1 e2 : tm), ~ FV v (appl e1 e2) -> ~ FV v e1 /\ ~ FV v e2.
intros v e1 e2 N.
split.
red in |- *; intro; apply N; apply FV_appl1; assumption.
red in |- *; intro; apply N; apply FV_appl2; assumption.
Save notFV_appl.

Goal
forall (v : vari) (e1 e2 e3 : tm),
~ FV v (cond e1 e2 e3) -> ~ FV v e1 /\ ~ FV v e2 /\ ~ FV v e3.
intros v e1 e2 e3 N.
split.
red in |- *; intro; apply N; apply FV_cond1; assumption.
split.
red in |- *; intro; apply N; apply FV_cond2; assumption.
red in |- *; intro; apply N; apply FV_cond3; assumption.
Save notFV_cond.

Goal forall v x : vari, ~ FV v (var x) -> v <> x.
intros v x N.
red in |- *; intro; apply N; apply FV_var; assumption.
Save notFV_var.

Goal forall (v : vari) (e : tm), ~ FV v (succ e) -> ~ FV v e.
intros v e N.
red in |- *; intro; apply N; apply FV_succ; assumption.
Save notFV_succ.

Goal forall (v : vari) (e : tm), ~ FV v (prd e) -> ~ FV v e.
intros v e N.
red in |- *; intro; apply N; apply FV_prd; assumption.
Save notFV_prd.

Goal forall (v : vari) (e : tm), ~ FV v (is_o e) -> ~ FV v e.
intros v e N.
red in |- *; intro; apply N; apply FV_is_o; assumption.
Save notFV_is_o.

Goal
forall (x v : vari) (t : ty) (e : tm),
~ FV x (Fix v t e) -> x = v \/ ~ FV x e.
intros.
specialize (Xmidvar x v); simple induction 1; intro A.
left; assumption.
right; red in |- *; intro; apply H; apply FV_fix; assumption.
Save notFV_fix.

Goal
forall (x v : vari) (t : ty) (e a : tm),
~ FV x (clos e v t a) -> ~ FV x a /\ (x = v \/ ~ FV x e).
intros.
split.
red in |- *; intro; apply H; apply FV_closa; assumption.
specialize (Xmidvar x v); simple induction 1; intro A.
left; assumption.
right; red in |- *; intro; apply H; apply FV_closb; assumption.
Save notFV_clos.

(********************************************************)
(*  inv_FV						*)
(*     These theorems state what (FV v e) implies.	*)
(*  							*)
(*  (FV v 0) ---> False					*)
(*  (FV v ttt) ---> False				*)
(*  (FV v fff) ---> False				*)
(*  (FV v (abs x t e)) ---> (FV v e) /\ ~v=x		*)
(*  (FV v (fix x t e)) ---> (FV v e) /\ ~v=x	        *)
(*  (FV v (appl e1 e2)) --->  (FV v e1)\/(FV v e2)	*)
(*  (FV v (succ e) ---> (FV v e)			*)
(*  (FV v (prd e) ---> (FV v e)			        *)
(*  (FV v (is_o e) ---> (FV v e)			*)
(*  (FV v (clos e x t a)) ---> (FV v a) \/ 		*)
(*                             (FV v e)/\~v=x	        *)
(*  							*)
(*  They use the function fv : vari->tm->Prop which	*)
(*  defines the free variable relation in terms of the	*)
(*  Match operator.  The theorem FV_fv is proved 	*)
(*  by induction, and each of the individual FV_e	*)
(*  theorems is an instance of the FV_fv theorem.	*)
(*  							*)
(********************************************************)

Definition fv (v : vari) (e : tm) :=
  match e return Prop with
  | o =>
      (* o *)	 False
      (* ttt *)
  | ttt => False
      (* fff *)
  | fff => False
      (* abs x s e *)
  | abs y s e => FV v e /\ v <> y
                           (* appl e1 e2 *)
  | appl e1 e2 => FV v e1 \/ FV v e2
                  (* cond e1 e2 e3 *)
  | cond e1 e2 e3 => FV v e1 \/ FV v e2 \/ FV v e3
                                (* var x *)
  | var y => v = y
             (* succ n *)
  | succ n => FV v n
      (* prd n *)
  | prd n => FV v n
      (* is_o n *)
  | is_o n => FV v n
      (* fix x s e *)
  | Fix y s e => FV v e /\ v <> y
                           (* clos e x s e1 *)
  | clos e y s e1 => FV v e1 \/ FV v e /\ v <> y
  end.

Goal forall (v : vari) (e : tm), FV v e -> fv v e.

simple induction 1; simpl in |- *; intros.
split; assumption.
split; assumption.
left; assumption.
right; assumption.
left; assumption.
right; left; assumption.
right; right; assumption.
assumption.
assumption.
assumption.
assumption.
left; assumption.
right; split; assumption.
Save FV_fv.

Goal forall v : vari, ~ FV v o.
intro v; red in |- *; intro F.
change (fv v o) in |- *.
apply FV_fv; assumption.
Save inv_FV_o.

Goal forall v : vari, ~ FV v ttt.
intro v; red in |- *; intro F.
change (fv v ttt) in |- *.
apply FV_fv; assumption.
Save inv_FV_ttt.

Goal forall v : vari, ~ FV v fff.
intro v; red in |- *; intro F.
change (fv v fff) in |- *.
apply FV_fv; assumption.
Save inv_FV_fff.

Goal
forall (v x : vari) (t : ty) (e : tm), FV v (abs x t e) -> FV v e /\ v <> x.
intros v x t e F.
change (fv v (abs x t e)) in |- *.
apply FV_fv; assumption.
Save inv_FV_abs.

Goal
forall (v x : vari) (t : ty) (e : tm), FV v (Fix x t e) -> FV v e /\ v <> x.
intros v x t e F.
change (fv v (Fix x t e)) in |- *.
apply FV_fv; assumption.
Save inv_FV_fix.

Goal forall (v : vari) (e1 e2 : tm), FV v (appl e1 e2) -> FV v e1 \/ FV v e2.
intros v e1 e2 F.
change (fv v (appl e1 e2)) in |- *.
apply FV_fv; assumption.
Save inv_FV_appl.

Goal
forall (v : vari) (e1 e2 e3 : tm),
FV v (cond e1 e2 e3) -> FV v e1 \/ FV v e2 \/ FV v e3.
intros v e1 e2 e3 F.
change (fv v (cond e1 e2 e3)) in |- *.
apply FV_fv; assumption.
Save inv_FV_cond.

Goal forall v x : vari, FV v (var x) -> v = x.
intros v x F.
change (fv v (var x)) in |- *.
apply FV_fv; assumption.
Save inv_FV_var.

Goal forall (v : vari) (e : tm), FV v (succ e) -> FV v e.
intros v e F.
change (fv v (succ e)) in |- *.
apply FV_fv; assumption.
Save inv_FV_succ.

Goal forall (v : vari) (e : tm), FV v (prd e) -> FV v e.
intros v e F.
change (fv v (prd e)) in |- *.
apply FV_fv; assumption.
Save inv_FV_prd.

Goal forall (v : vari) (e : tm), FV v (is_o e) -> FV v e.
intros v e F.
change (fv v (is_o e)) in |- *.
apply FV_fv; assumption.
Save inv_FV_is_o.

Goal
forall (v x : vari) (t : ty) (e a : tm),
FV v (clos e x t a) -> FV v a \/ FV v e /\ v <> x.
intros v x t e a F.
change (fv v (clos e x t a)) in |- *.
apply FV_fv; assumption.
Save inv_FV_clos.


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

Contents:
 - Category of coalgebras over an endofunctor.
 - Dual of Lambek's lemma: if (A,α) is terminal coalgebra, α is an isomorphism.

******************************************************************)

Require Import UniMath.Foundations.Propositions.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.limits.terminal.

Local Open Scope cat.

Section Coalgebra_Definition.

Context {C : precategory} (F : functor C C).

Definition coalgebra : UU := ∑ X : C, X --> F X.

Definition coalgebra_ob (X : coalgebra) : C := pr1 X.
Local Coercion coalgebra_ob : coalgebra >-> ob.

Definition coalgebra_mor (X : coalgebra) : C ⟦X, F X ⟧ := pr2 X.

(** A homomorphism of F-coalgebras (F A, α : C ⟦A, F A⟧) and (F B, β : C ⟦B, F B⟧)
    is a morphism f : C ⟦A, B⟧ s.t. the below diagram commutes.

  <<
         f
     A -----> B
     |        |
     | α      | β
     |        |
     V        V
    F A ---> F B
        F f
  >>
*)

Definition is_coalgebra_homo {X Y : coalgebra} (f : C ⟦X, Y⟧) : UU
  := (coalgebra_mor X) · #F f = f · (coalgebra_mor Y).

Definition coalgebra_homo (X Y : coalgebra) := ∑ f : C ⟦X, Y⟧, is_coalgebra_homo f.

Definition mor_from_coalgebra_homo (X Y : coalgebra) (f : coalgebra_homo X Y)
  : C ⟦X, Y⟧ := pr1 f.
Coercion mor_from_coalgebra_homo : coalgebra_homo >-> precategory_morphisms.

Definition coalgebra_homo_eq (hasHom : has_homsets C) {X Y : coalgebra}
           (f g : coalgebra_homo X Y) : (f : C ⟦X, Y⟧) = g ≃ f = g.
Proof.
  apply invweq.
  apply subtypeInjectivity.
  intro. apply hasHom.
Defined.

Lemma coalgebra_homo_commutes {X Y : coalgebra} (f : coalgebra_homo X Y)
  : (coalgebra_mor X) · #F f = f · (coalgebra_mor Y).
Proof.
  exact (pr2 f).
Defined.

Definition coalgebra_homo_id (X : coalgebra) : coalgebra_homo X X.
Proof.
  exists (identity _).
  unfold is_coalgebra_homo.
  rewrite id_left.
  rewrite functor_id.
  rewrite id_right.
  apply idpath.
Defined.

Definition coalgebra_homo_comp (X Y Z : coalgebra) (f : coalgebra_homo X Y)
           (g : coalgebra_homo Y Z) : coalgebra_homo X Z.
Proof.
  exists (f · g).
  unfold is_coalgebra_homo.
  rewrite functor_comp.
  rewrite assoc.
  rewrite coalgebra_homo_commutes.
  rewrite <- assoc.
  rewrite coalgebra_homo_commutes.
  rewrite assoc.
  apply idpath.
Defined.

Definition CoAlg_precategory_ob_mor : precategory_ob_mor :=
  make_precategory_ob_mor coalgebra coalgebra_homo.

Definition CoAlg_precategory_data: precategory_data :=
  make_precategory_data CoAlg_precategory_ob_mor
                        coalgebra_homo_id
                        coalgebra_homo_comp.

End Coalgebra_Definition.

Definition isaset_coalgebra_homo {C : category}  (F : functor C C) {X Y : coalgebra F}
           : isaset (coalgebra_homo F X Y).
Proof.
  apply (isofhleveltotal2 2).
  - apply C.
  - intro f.
    apply isasetaprop.
    apply C.
Defined.

Lemma CoAlg_is_precategory {C : category}  (F : functor C C)
  : is_precategory (CoAlg_precategory_data F).
Proof.
  split.
  - split.
    + intros. apply coalgebra_homo_eq.
      * apply C.
      * apply id_left.
    + intros. apply coalgebra_homo_eq.
      * apply C.
      * apply id_right.
  - { split.
      - intros.
        apply coalgebra_homo_eq.
        + apply C.
        + apply assoc.
      - intros.
        apply coalgebra_homo_eq.
        + apply C.
        + apply assoc'. }
Defined.

Definition CoAlg_precategory {C : category}  (F : functor C C) : precategory
  := make_precategory (CoAlg_precategory_data F) (CoAlg_is_precategory F).

Lemma has_homsets_coalgebra {C : category}  (F : functor C C) : has_homsets (CoAlg_precategory F).
Proof.
  intros f g.
  apply isaset_coalgebra_homo.
Defined.

Definition CoAlg_category {C : category}  (F : functor C C) : category
  := make_category _ (has_homsets_coalgebra F).

Section Lambek_dual.
(** Dual of Lambeks Lemma : If (A,α) is terminal F-coalgebra, then α is an iso *)

Context (C : category)
        (F : functor C C)
        (X : coalgebra F).

Local Notation F_CoAlg := (CoAlg_category F).

Context (isTerminalX : isTerminal F_CoAlg X).

Definition TerminalX : Terminal F_CoAlg := make_Terminal _ isTerminalX.

Local Notation α := (coalgebra_mor _ (TerminalObject TerminalX)).
Local Notation A := (coalgebra_ob _ (TerminalObject TerminalX)).

(** FX := (FA,Fα) is also an F-coalgebra *)
Definition FX : coalgebra F := tpair _ (F A) (#F α).

(** By terminality there is an arrow α' : FA → A, s.t.:
  <<
         α'
    FA ------> A
    |          |
    | Fα       | α
    V          V
   FFA ------> FA
         Fα'
  >>
  commutes *)

Definition f : F_CoAlg ⟦FX, TerminalX⟧ := (@TerminalArrow F_CoAlg TerminalX FX).

Definition α' : C ⟦F A, A⟧ := mor_from_coalgebra_homo F FX X f.

Definition αα'_mor : coalgebra_homo F X X.
Proof.
  exists (α · α').
  unfold is_coalgebra_homo.
  rewrite <- assoc.
  apply cancel_precomposition.
  rewrite functor_comp.
  apply (coalgebra_homo_commutes F f).
Defined.

Definition αα'_idA : α · α' = identity A
  := maponpaths pr1 (TerminalEndo_is_identity (T:=TerminalX) αα'_mor).

Lemma α'α_idFA : α' · α = identity (F A).
Proof.
  rewrite <- functor_id.
  rewrite <- αα'_idA.
  rewrite functor_comp.
  unfold α'.
  apply pathsinv0.
  apply (coalgebra_homo_commutes F f).
Defined.

Lemma terminalcoalgebra_isiso : is_iso α.
Proof.
  apply (is_iso_qinv α α').
  split.
  - exact αα'_idA.
  - exact α'α_idFA.
Defined.

Definition terminalcoalgebra_iso : iso A (F A) := make_iso α terminalcoalgebra_isiso.

End Lambek_dual.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section bachmann_s_lotschnittaxiom_variant.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma bachmann_s_lotschnittaxiom_aux : bachmann_s_lotschnittaxiom <->
  forall A1 A2 B1 B2 C1 C2 D1 D2 IAB IAC IBD, IAB <> IAC -> IAB <> IBD ->
  Perp A1 A2 B1 B2 -> Perp A1 A2 C1 C2 -> Perp B1 B2 D1 D2 ->
  Col A1 A2 IAB -> Col B1 B2 IAB -> Col A1 A2 IAC ->
  Col C1 C2 IAC -> Col B1 B2 IBD -> Col D1 D2 IBD ->
  Coplanar IAB IAC IBD C1 -> Coplanar IAB IAC IBD C2 ->
  Coplanar IAB IAC IBD D1 -> Coplanar IAB IAC IBD D2 ->
  exists I, Col C1 C2 I /\ Col D1 D2 I.
Proof.
  split.
  - intros bla A1 A2 B1 B2 C1 C2 D1 D2 IAB IAC IBD Hd Hd' HPerpAB HPerpAC HPerpBD.
    intros HCol1 HCol2 HCol3 HCol4 HCol5 HCol6 HCop1 HCop2 HCop3 HCop4.
    assert (Col IAB IAC A1) by ColR.
    assert (Col IAB IAC A2) by ColR.
    assert (Col IAB IBD B1) by ColR.
    assert (Col IAB IBD B2) by ColR.
    assert (Coplanar IAB IAC IBD A1) by Cop.
    assert (Coplanar IAB IAC IBD A2) by Cop.
    assert (Coplanar IAB IAC IBD B1) by Cop.
    assert (Coplanar IAB IAC IBD B2) by Cop.
    assert (Per IAC IAB IBD) by (apply perp_per_1, (perp_col4 A1 A2 B1 B2); auto).
    assert (HNC1 : ~ Col IAC IAB IBD) by (apply per_not_col; auto).
    assert (HParA : Par_strict A1 A2 D1 D2).
      {
      clear dependent C1; clear dependent C2;
      apply par_not_col_strict with IBD; Col.
        apply l12_9 with B1 B2; Perp; CopR.
      intro; apply HNC1; ColR.
      }
    assert (HParB : Par_strict B1 B2 C1 C2).
      {
      clear dependent D1; clear dependent D2;
      apply par_not_col_strict with IAC; Col.
        apply l12_9 with A1 A2; Perp; CopR.
      intro; apply HNC1; ColR.
      }
    assert (HPQ : IAC <> IAB) by (assert_diffs; auto).
    assert (HQR : IAB <> IBD) by (assert_diffs; auto).
    destruct (diff_col_ex3 C1 C2 IAC) as [P1 [HC1P1 [HC2P1 [HPP1 HCP1]]]]; Col.
    destruct (diff_col_ex3 D1 D2 IBD) as [R1 [HD1R1 [HD2R1 [HRR1 HDR1]]]]; Col.
    assert_diffs.
    destruct (bla IAC IAB IBD P1 R1) as [I [HI1 HI2]]; auto.
      apply perp_per_1, (perp_col4 A1 A2 C1 C2); Col.
      apply perp_per_1, (perp_col4 B1 B2 D1 D2); Col.
      apply col_cop2__cop with C1 C2; Cop.
      apply col_cop2__cop with D1 D2; Cop.
    exists I.
    split; ColR.

  - intros lotschnitt P Q R P1 R1 HPQ HQR HPerQ HPerP HPerR HCop1 HCop2.
    destruct (eq_dec_points P P1).
      subst; exists R; Col.
    destruct (eq_dec_points R R1).
      subst; exists P; Col.
    destruct (lotschnitt P Q Q R P P1 R R1 Q P R) as [S [HS1 HS2]]; Col; Perp; Cop.
    exists S; split; assumption.
Qed.

End bachmann_s_lotschnittaxiom_variant.


Require Import Arith.
Require Import type.

Inductive Var : Type :=
| var : nat -> FType -> Var
.

Inductive Term : Type :=
| VarTerm : Var -> Term
| AbsTerm : Var -> Term -> Term
| AppTerm : Term -> Term -> Term
| TAbsTerm: TVar -> Term -> Term
| TAppTerm: Term -> FType -> Term
.

Definition varEqual (x x':Var) : bool :=
    match x, x' with
    | (var x T), (var x' T') => andb (beq_nat x x') (FTypeEqual T T')
    end.


Require Export Classification_Axiom_Scheme.
From mathcomp Require Export ssreflect.

Module Algebra.

Definition Union x y := {| λ z, z ∈ x \/ z ∈ y|}.
Notation "x ∪ y" := (Union x y) (at level 65, right associativity).
Hint Unfold Union : set.

Definition Intersection x y := {| λ z, z ∈ x /\  z ∈ y|}.
Notation "x ∩ y" := (Intersection x y)(at level 60, right associativity).

Theorem bel_union x y z :
  z ∈ x \/ z ∈ y <-> z ∈ (x ∪ y).
Proof.
  rewrite Axiom_Scheme; split => [[zx|zy]|[z_ [zx|zy]] ]; Ens.
Qed.

Theorem bel_inter x y z :
  z ∈ x /\ z ∈ y <-> z ∈ (x ∩ y).
Proof.
  rewrite Axiom_Scheme; split => [[zx zy]| [z_ [zx zy]]]; Ens.
Qed.

Hint Resolve bel_union bel_inter : set.

Theorem union_fix x :
  x ∪ x = x.
Proof.
  rewrite Axiom_Extent => z; rewrite -bel_union; split => [[H|H]|H]; auto.
Qed.

Theorem inter_fix x :
  x ∩ x = x.
Proof.
  rewrite Axiom_Extent => z.
  rewrite -bel_inter.
  split => [[H _] | H]; auto.
Qed.

Hint Rewrite union_fix inter_fix : set.

Theorem union_com x y :
    x ∪ y = y ∪ x.
Proof.
  extent.
  rewrite -!bel_union.
  split => [[zx | zy]|[zy |zx]]; auto.
Qed.

Theorem inter_com x y :
    x ∩ y = y ∩ x.
Proof.
  extent.
  rewrite -!bel_inter.
  split => [[zx zy]| [zy zx]] //.
Qed.

Hint Rewrite union_com inter_com : set.

Theorem union_ass x y z :
  (x ∪ y) ∪ z = x ∪ (y ∪ z).
Proof.
  extent.
  rewrite -!bel_union.
  split => [[[x_|y_]|z_]|[x_|[y_|z_]]]; auto.
Qed.

Theorem inter_ass x y z :
  (x ∩ y) ∩ z = x ∩ (y ∩ z).
Proof.
  extent.
  rewrite -!bel_inter.
  split => [ [ [x_ y_] z_] |[x_ [y_ z_]]]; auto.
Qed.

Theorem union_dist x y z :
  x ∩ (y ∪ z) = (x ∩ y) ∪ (x ∩ z).
Proof.
  extent; rewrite -!bel_union -!bel_inter -!bel_union.
  split => [[x_ [y_ | z_]]|[[x_ y_]|[x_ z_]]]; auto.
Qed.

Theorem inter_dist x y z :
  x ∪ (y ∩ z) = (x ∪ y) ∩ (x ∪ z).
Proof.
  extent; rewrite -!bel_union -!bel_inter -!bel_union.
  split => [[x_ | [y_ z_]]|[[x_ | y_] [x__ | z_]]]; auto.
Qed.

Hint Rewrite union_dist inter_dist.

Definition Complement x := {|λ y, ~ y ∈ x|}.
Notation "¬ x" := (Complement x) (at level 5, right associativity).
Hint Unfold Complement : set.

Theorem comp_fix x :
  ¬ ¬ x = x.
Proof.
  extent.
  rewrite !Axiom_Scheme.
  split => [[z_ H]|H].
  + case: (not_and_or _ _ H) => {H} [H | H] => //.
    by apply NNPP.
  + split; Ens.
    apply or_not_and.
    by right.
Qed.

Hint Rewrite comp_fix : set.

Theorem demorgan_union x y :
  ¬ (x ∪ y) = ¬ x ∩ ¬ y.
Proof.
  extent; rewrite Axiom_Scheme -bel_union -bel_inter !Axiom_Scheme.
  split => [ [z_ H] | [[z_ _zx] [_ _zy]] ].
  + by move /not_or_and : H => [_zx _zy].
  + by split => //; apply and_not_or.
Qed.

Theorem demorgan_inter x y :
  ¬ (x ∩ y) = (¬ x) ∪ (¬ y).
Proof.
  extent; rewrite Axiom_Scheme -bel_union -bel_inter !Axiom_Scheme.
  split => [ [z_ H] |  H ].
  + by case /not_and_or : H => [_zx | _zy]; constructor.
  + by case H => [[z_ zx]|[z_ zy]]; apply (conj z_); apply or_not_and; constructor.
Qed.

Hint Rewrite demorgan_union demorgan_inter : set.

Definition Difference x y := x ∩ (¬ y).
Notation "x ~ y" := (Difference x y) (at level 50, left associativity).
Hint Unfold Difference : set.

Theorem inter_diff x y z :
    x ∩ (y ~ z) = (x ∩ y) ~ z.
Proof.
  by rewrite /Difference inter_ass.
Qed.

Corollary Property_Ineq (x y : Class):
  x <> y <-> y <> x.
Proof.
  split => [F H|F H]; auto.
Qed.

Hint Resolve Property_Ineq : set.

Definition Φ := {|λ x, x <> x|}.
Hint Unfold Φ : set.

Theorem not_bel_zero x :
  ~ x ∈ Φ.
Proof.
  move /Axiom_Scheme => [_ F]; auto.
Qed.

Hint Resolve not_bel_zero : set.

Ltac zero H := case (not_bel_zero _ H).

Theorem zero_union x :
 Φ ∪ x = x.
Proof.
  extent; rewrite -bel_union.
  by split => [[F | zx]|zx] => //; [zero F| right].
Qed.

Theorem zero_inter x:
  Φ ∩ x = Φ.
Proof.
  extent; rewrite -bel_inter.
  split => [[F _]|F]; zero F.
Qed.

Definition μ := {|λ x, x = x|}.

Corollary Property_μ x :
  x ∪ (¬ x) = μ.
Proof.
  extent; rewrite -bel_union !Axiom_Scheme.
  split => [[zx | [z_ _zx]]| [z_ _]]; [split | split |] => //; [Ens|].
  case (classic (z ∈ x)) => [zx | _zx]; [left|right] => //.
Qed.

Hint Unfold μ : set.
Hint Resolve Property_μ : set.

Theorem bel_universe_set x :
  x ∈ μ <-> Ensemble x.
Proof.
  rewrite Axiom_Scheme; split => [[H _]| H] //.
Qed.

Theorem universe_union x :
  x ∪ μ = μ.
Proof.
  extent; rewrite -bel_union bel_universe_set.
  split => [[zx|H]|H] => //; [|right]; Ens.
Qed.

Theorem universe_inter x :
  x ∩ μ = x.
Proof.
  extent; rewrite -bel_inter bel_universe_set.
  split => [[zx z_] | zx] => //.
  split => //; Ens.
Qed.

Hint Rewrite universe_union universe_inter : set.

Theorem zero_comp_universe :
  ¬ Φ = μ.
Proof.
  extent; rewrite !Axiom_Scheme.
  split => [[z_ H]|[z_ _]]; split => //.
  move => [_ F]; auto.
Qed.

Theorem universe_comp_zero :
  ¬ μ = Φ.
Proof.
  extent; rewrite !Axiom_Scheme.
  split => [[z_ F]|[z_ F]]; split => //.
  move => _; apply F; split => //.
Qed.

Hint Resolve zero_comp_universe universe_comp_zero : set.

Definition Element_I x := {|λ z, forall y, y ∈ x -> z ∈ y|}.
Notation "⊓ x" := (Element_I x)(at level 66).

Definition Element_U x := {|λ z, exists y, z ∈ y /\ y ∈ x|}.
Notation "⊔ x" := (Element_U x)(at level 66).

Hint Unfold Element_I Element_U : set.

Theorem zero_eleI_universe :
  ⊓ Φ = μ.
Proof.
  extent; rewrite !Axiom_Scheme.
  split => [[z_ _] | [z_ _]]; split => // y F; zero F.
Qed.

Theorem zero_eleU_zero :
  ⊔ Φ = Φ.
Proof.
  extent; rewrite !Axiom_Scheme.
  split => [[z_ [y [zy F]]] |[z_ F]]; split => //; zero F.
Qed.

Definition Subclass x y := forall z, z ∈ x -> z ∈ y.
Notation "x ⊂ y" := (Subclass x y) (at level 70).
Hint Unfold Subclass : set.

Theorem zero_sub x :
  Φ ⊂ x.
Proof.
  move => z F; zero F.
Qed.

Theorem sub_universe x :
  x ⊂ μ.
Proof.
  move => z zx; rewrite bel_universe_set; Ens.
Qed.

Hint Resolve zero_sub sub_universe : set.

Theorem sub_eq x y :
  (x ⊂ y /\ y ⊂ x) <-> x = y.
Proof.
  split => [[xy yx] | H].
  + extent; split => [zx | zy].
    - apply (xy z zx).
    - apply (yx z zy).
  + subst y.
    by suff xx :  (x ⊂ x).
Qed.

Hint Resolve sub_eq : set.

Theorem sub_tran x y z :
  x ⊂ y -> y ⊂ z -> x ⊂ z.
Proof.
  move => xy yz p px; auto.
Qed.

Theorem union_sub x y :
  x ∪ y = y <-> x ⊂ y.
Proof.
  split => [H p px|xy].
  + by rewrite -H -bel_union; left.
  + extent; rewrite -bel_union.
    split => [[zx | zy]|zy] => //.
    - apply (xy z zx).
    - by right.
Qed.

Hint Resolve union_sub : set.

Theorem sub_ele x y :
  x ⊂ y -> (⊔  x ⊂ ⊔ y) /\ (⊓ y ⊂ ⊓ x).
Proof.
  move => xy; split => [p|p]; rewrite !Axiom_Scheme; case => p_ H; split => //.
  + case H => [q [pq qx]].
    exists q; split => //.
    apply (xy q qx).
  + move => q qx.
    apply H.
    by apply xy.
Qed.

Theorem bel_ele x y :
  x ∈ y -> (x ⊂ ⊔ y) /\ (⊓ y ⊂ x).
Proof.
  move => xy; split => z; rewrite Axiom_Scheme => H.
  + Ens.
  + case H => {H} [z_ H].
    by apply H.
Qed.

Hint Resolve bel_ele : set.

Definition ProperSubclass x y := x ⊂ y /\ x <> y.
Notation "x ⊆ y" := (ProperSubclass x y)(at level 70).

Corollary Property_ProperSubclass x y :
  x ⊂ y -> (x ⊆ y ) \/ x = y.
Proof.
  case (classic (x = y)) => [xy | xy]; [right|left] => //.
Qed.

Hint Unfold ProperSubclass : set.
Hint Resolve Property_ProperSubclass : set.

Lemma bel_diff x y z :
  z ∈ x /\ ~ z ∈ y <-> z ∈ (x ~ y).
Proof.
  rewrite !Axiom_Scheme.
  split => [[zx _zy]|[z_ [zx [_ _zy]]]] => //.
  suff H : Ensemble z; by Ens.
Qed.

Lemma diff_zero x :
  x ~ x = Φ.
Proof.
  extent; rewrite -bel_diff.
  split => [[T F]|F] //; zero F.
Qed.

Lemma Property_Φ x y :
  y ⊂ x -> x ~ y = Φ <-> x = y.
Proof.
  move => yx.
  split => [H | H]; extent.
  + move: (not_bel_zero z); rewrite -H -bel_diff.
    move /not_and_or; case => H0; split => [zx|zy] //.
    - by apply yx.
    - by apply NNPP.
    - by apply yx.
  + subst y.
    by rewrite diff_zero.
Qed.

Hint Resolve Property_Φ : set.

End Algebra.

Export Algebra.


Require Import NArith RList List Rbase.

Class Isomorphism (A B:Type) :=
  {
    iso_f : A -> B ;
    iso_b : B -> A ;
    iso_f_b : forall b, iso_f (iso_b b) = b ;
    iso_b_f : forall a, iso_b (iso_f a) = a
  }.

(*
We would like to just declare
Require Import RelationClasses.
Global Instance Isomorphism_equiv : Equivalence Isomorphism.

But this runs into universe issues.
 *)

Global Instance Isomorphism_refl {A} : Isomorphism A A
  := {
      iso_b a := a ;
      iso_f a := a ;
      iso_f_b := @eq_refl A;
      iso_b_f := @eq_refl A
    }.

Instance Isomorphism_symm {A B} (iso:Isomorphism A B) : Isomorphism B A
  := {
      iso_b := iso_f ;
      iso_f := iso_b ;
      iso_f_b := iso_b_f ;
      iso_b_f := iso_f_b
    }.

Program Instance Isomorphism_trans {A B C} (iso1:Isomorphism A B) (iso2:Isomorphism B C) : Isomorphism A C
  := {
      iso_f a := @iso_f _ _ iso2 (@iso_f _ _ iso1 a) ;
      iso_b b := @iso_b _ _ iso1 (@iso_b _ _ iso2 b)
    }.
Next Obligation.
  repeat rewrite iso_f_b; trivial.
Qed.
Next Obligation.
  repeat rewrite iso_b_f; trivial.
Qed.

Program Instance Isomorphism_prod {A B C D} (iso1:Isomorphism A C) (iso2:Isomorphism B D) : Isomorphism (A*B) (C*D)
  := {
      iso_f '(a,c) := (iso_f a, iso_f c) ;
      iso_b '(b,d) := (iso_b b, iso_b d)
    }.
Next Obligation.
  repeat rewrite iso_f_b; trivial.
Qed.
Next Obligation.
  repeat rewrite iso_b_f; trivial.
Qed.

Program Instance Isomorphism_list {A B} (iso1:Isomorphism A B) : Isomorphism (list A) (list B)
  := {
      iso_f := map iso_f ;
      iso_b := map iso_b
    }.
Next Obligation.
  rewrite map_map.
  erewrite map_ext; try apply map_id.
  intros.
  apply iso_f_b.
Qed.
Next Obligation.
  rewrite map_map.
  erewrite map_ext; try apply map_id.
  intros.
  apply iso_b_f.
Qed.

Global Instance nat_to_N_iso : Isomorphism nat N
  := {
      iso_f := N.of_nat ;
      iso_b := N.to_nat ;
      iso_f_b := N2Nat.id ;
      iso_b_f := Nat2N.id ;
    }.

Global Program Instance Rlist_to_list_iso : Isomorphism Rlist (list R)
  := {
      iso_f := (fix iso_f (l:Rlist) : list R
                := match l with
                   | RList.nil => nil
                   | RList.cons x y => cons x (iso_f y)
                   end) ;
      iso_b := (fix iso_b (l:list R) : Rlist
                := match l with
                   | nil => RList.nil
                   | cons x y => RList.cons x (iso_b y)
                   end)

      }.
Next Obligation.
  induction b; simpl; congruence.
Qed.
Next Obligation.
  induction a; simpl; congruence.
Qed.