(** * Miscellaneous Well-Foundedness Facts *)
Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.Setoids.Setoid Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat Coq.Classes.Morphisms Coq.Init.Wf.
Require Import Fiat.Common.Telescope.Core.
Require Import Fiat.Common.Telescope.Instances.
Require Import Fiat.Common.Telescope.Equality.
Require Import Fiat.Common.
Require Import Fiat.Common.Equality.
Import Init.Wf.

Set Implicit Arguments.

Local Ltac Fix_eq_t F_ext Rwf :=
  let generalize_if_not_var x :=
      first [ is_var x; fail 1
            | generalize x ] in
  intros;
  unfold Fix;
  rewrite <- Fix_F_eq;
  apply F_ext; intros;
  repeat match goal with
           | [ |- context[Fix_F _ _ ?x] ] => generalize_if_not_var x
           | [ |- context[Fix_F _ _ ?x _] ] => generalize_if_not_var x
         end;
  clear -F_ext Rwf;
  match goal with
    | [ |- forall x : Acc _ ?a, _ ] => induction (Rwf a)
  end;
  intros; rewrite <- !Fix_F_eq;
  apply F_ext; eauto.

Local Ltac Fix_Proper_t Fix_eq wf :=
  change (@flatten_forall_eq_relation) with (@flatten_forall_eq);
  change (@flatten_forall_eq_relation_with_assumption) with (@flatten_forall_eq_with_assumption);
  let H := fresh "H" in
  let a := fresh "a" in
  unfold forall_relation, pointwise_relation, respectful;
  intros ?? H a; repeat intro;
  induction (wf a);
  rewrite !Fix_eq; [ erewrite H; [ reflexivity | .. ] | .. ]; eauto; intros;
  [ etransitivity; [ symmetry; apply H; reflexivity | apply H; eassumption ]; reflexivity
  | etransitivity; [ apply H; eassumption | symmetry; apply H; reflexivity ]; reflexivity ].

Section FixV.
  Context A (B : A -> Telescope)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a, flattenT (B a) Type).

  Local Notation FixV := (@Fix A R Rwf (fun a : A => flatten_forall (P a))).

  Section F.
    Context (F : forall x : A, (forall y : A, R y x -> flatten_forall (P y)) -> flatten_forall (P x)).

    Definition FixV_eq
               (F_ext : forall x (f g : forall y, R y x -> flatten_forall (P y)),
                          (forall y (p : R y x), flatten_forall_eq (f y p) (g y p))
                          -> flatten_forall_eq (@F x f) (@F x g))
    : forall a, flatten_forall_eq (@FixV F a) (@F a (fun y (_ : R y a) => @FixV F y)).
    Proof. Fix_eq_t F_ext Rwf. Defined.

    Definition FixV_eq_with_assumption
               Q
               (F_ext : forall x (f g : forall y, R y x -> flatten_forall (P y)),
                          (forall y (p : R y x), flatten_forall_eq_with_assumption (Q y) (f y p) (g y p))
                          -> flatten_forall_eq_with_assumption (Q x) (@F x f) (@F x g))
    : forall a, flatten_forall_eq_with_assumption (Q a) (@FixV F a) (@F a (fun y (_ : R y a) => @FixV F y)).
    Proof. Fix_eq_t F_ext Rwf. Defined.

    Definition FixV_rect
               (Q : forall a, flattenT (Telescope_append (B a) (P a)) Type)
               (H0 : forall x, (forall y, R y x -> flatten_append_forall (@Q y) (@FixV F y))
                              -> flatten_append_forall (@Q x) (@F x (fun (y : A) (_ : R y x) => @FixV F y)))
               (F_ext : forall x (f g : forall y, R y x -> flatten_forall (@P y)),
                          (forall y (p : R y x), flatten_forall_eq (f y p) (g y p))
                          -> flatten_forall_eq (@F x f) (@F x g))
               a
    : flatten_append_forall (@Q a) (@FixV F a).
    Proof.
      induction (Rwf a).
      eapply flatten_append_forall_Proper; auto with nocore.
      symmetry; eapply FixV_eq; auto with nocore.
    Defined.
  End F.

  Global Instance FixV_Proper_eq
  : Proper
      ((forall_relation
          (fun a =>
             (forall_relation
                (fun a' =>
                   pointwise_relation
                     _
                     (flatten_forall_eq_relation)))
               ==> flatten_forall_eq_relation))
         ==> (forall_relation (fun a => flatten_forall_eq_relation)))
      FixV.
  Proof. Fix_Proper_t @FixV_eq Rwf. Qed.

  Global Instance FixV_Proper_eq_with_assumption
         Q
  : Proper
      ((forall_relation
          (fun a : A =>
             (forall_relation
                (fun a' : A =>
                   pointwise_relation
                     (R a' a)
                     (flatten_forall_eq_relation_with_assumption (Q a'))))
               ==> flatten_forall_eq_relation_with_assumption (Q a)))
         ==> (forall_relation (fun a => flatten_forall_eq_relation_with_assumption (Q a))))
      FixV.
  Proof. Fix_Proper_t @FixV_eq_with_assumption Rwf. Qed.
End FixV.

Arguments FixV_Proper_eq {A B R Rwf P} _ _ _ _.
Arguments FixV_Proper_eq_with_assumption {A B R Rwf P} _ _ _ _ _.

Local Arguments flatten_forall / _ _.
Local Arguments flattenT / _ _.
Local Arguments flatten_forall_eq / _ _ _ _.
Local Arguments flatten_forall_eq_relation / _ _ _ _.
Local Arguments flatten_forall_eq_with_assumption / _ _ _ _ _.
Local Arguments flatten_forall_eq_relation_with_assumption / _ _ _ _ _.
Local Arguments flatten_append_forall / _ _ _ _.

Local Notation type_of x := ((fun T (y : T) => T) _ x).

Section FixVTransfer.
  Context A (B B' : A -> Telescope)
          (f0 : forall a, flattenT_sig (B a) -> flattenT_sig (B' a))
          (g0 : forall a, flattenT_sig (B' a) -> flattenT_sig (B a))
          (sect : forall a x, g0 a (f0 a x) = x)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a, flattenT (B a) Type).

  Let P' : forall a, flattenT (B' a) Type
    := fun a => flattenT_unapply (fun x => flattenT_apply (P a) (g0 _ x)).

  Local Notation FixV := (@Fix A R Rwf (fun a : A => flatten_forall (P a))).
  Local Notation FixV' := (@Fix A R Rwf (fun a : A => flatten_forall (P' a))).

  Section F.
    Context (F : forall x : A, (forall y : A, R y x -> flatten_forall (P y)) -> flatten_forall (P x)).

    Let transfer
    : forall y,
        flatten_forall
          (flattenT_unapply
             (fun x : flattenT_sig (B y) => flattenT_apply (P' y) (f0 y x)))
        -> flatten_forall (P y).
    Proof.
      intro y.
      refine (flatten_forall_eq_rect
                (transitivity
                   ((_ : Proper (pointwise_relation _ _ ==> _) flattenT_unapply)
                      _ _
                      (fun x' => transitivity
                                   (symmetry (flattenT_apply_unapply _ _))
                                   (f_equal (flattenT_apply _) (sect _ _))))
                   (symmetry (flattenT_unapply_apply _)))).
    Defined.

    Let transfer'
    : forall a,
        flatten_forall (P a)
        -> flatten_forall (P' a).
    Proof.
      intro a.
      refine (fun f' => flatten_forall_unapply (fun x' => flatten_forall_apply f' (g0 _ x'))).
    Defined.

    Let untransfer'
    : forall a,
        flatten_forall (P' a)
        -> flatten_forall (P a).
    Proof.
      intro a.
      refine (fun f' => _).
      refine (transfer
                _
                (flatten_forall_unapply (fun x => flatten_forall_apply f' (f0 _ x)))).
    Defined.

    Let F' : forall x : A, (forall y : A, R y x -> flatten_forall (P' y)) -> flatten_forall (P' x)
      := fun a F' => transfer' _ (@F a (fun y pf => transfer _ (flatten_forall_unapply (fun x => flatten_forall_apply (F' y pf) (f0 _ x))))).

    Context (F_ext : forall x (f g : forall y, R y x -> flatten_forall (P y)),
                       (forall y (p : R y x), flatten_forall_eq (f y p) (g y p))
                       -> flatten_forall_eq (@F x f) (@F x g)).

    Lemma F'_ext
    : forall x (f g : forall y, R y x -> flatten_forall (P' y)),
        (forall y (p : R y x), flatten_forall_eq (f y p) (g y p))
        -> flatten_forall_eq (@F' x f) (@F' x g).
    Proof.
      intros x f' g' IH.
      subst F' transfer transfer'; cbv beta.
      apply (_ : Proper (forall_relation _ ==> _) flatten_forall_unapply); intro.
      apply flatten_forall_apply_Proper.
      apply F_ext; intros.
      refine ((_ : Proper (flatten_forall_eq ==> _) (@flatten_forall_eq_rect _ _ _ _)) _ _ _).
      apply (_ : Proper (forall_relation _ ==> _) flatten_forall_unapply); intro.
      apply flatten_forall_apply_Proper.
      apply IH.
    Qed.

    Definition FixV_transfer_eq
               a
    : flatten_forall_eq (@FixV F a) (untransfer' _ (@FixV' F' a)).
    Proof.
      induction (Rwf a).
      rewrite FixV_eq by eauto with nocore.
      etransitivity_rev _.
      { unfold transfer, untransfer'; cbv beta.
        apply flatten_forall_eq_rect_Proper, flatten_forall_unapply_Proper; intro.
        apply flatten_forall_apply_Proper.
        rewrite FixV_eq by auto using F'_ext with nocore.
        reflexivity. }
      etransitivity.
      { apply F_ext; intros.
        set_evars.
        match goal with
          | [ H : forall y r, flatten_forall_eq _ _ |- _ ] => rewrite H by assumption
        end.
        match goal with
          | [ |- ?R ?a (?e ?x ?y) ]
            => revert x y
        end.
        match goal with
          | [ H := ?e |- _ ] => is_evar e; subst H
        end.
        match goal with
          | [ |- forall x y, ?R (@?LHS x y) (?RHS x y) ]
            => unify LHS RHS; cbv beta
        end.
        reflexivity. }
      lazymatch goal with
        | [ |- context[FixV' ?F _] ]
          => generalize (FixV' F)
      end.
      subst F'; cbv beta.
      subst untransfer' transfer transfer'; cbv beta.
      intro.
      rewrite flatten_forall_eq_rect_trans.
      match goal with
        | [ |- context[flatten_forall_eq_rect
                            (flattenT_unapply_Proper ?P ?Q ?H)
                            (flatten_forall_unapply ?f)] ]
          => rewrite (@flatten_forall_eq_rect_flattenT_unapply_Proper _ P Q H f)
      end.
      etransitivity_rev _.
      { apply flatten_forall_eq_rect_Proper.
        apply flatten_forall_unapply_Proper; intro.
        match goal with
          | [ |- context[@transitivity _ (@eq ?A) ?P _ _ _ _ _] ]
            => change (@transitivity _ (@eq ?A) P) with (@eq_trans A)
        end.
        match goal with
          | [ |- context[@symmetry _ (@eq ?A) ?P _ _ _] ]
            => change (@symmetry _ (@eq ?A) P) with (@eq_sym A)
        end.
        set_evars.
        rewrite @transport_pp.
        match goal with
          | [ |- context G[eq_rect _ (fun T => T) (flatten_forall_apply (flatten_forall_unapply ?k) ?x0) _ (eq_sym (flattenT_apply_unapply ?f1 ?x0))] ]
            => let H := fresh in
               pose proof (@eq_rect_symmetry_flattenT_apply_unapply _ f1 x0 k) as H;
                 cbv beta in H |- *;
                 let RHS := match type of H with _ = ?RHS => constr:(RHS) end in
                 let LHS := match type of H with ?LHS = _ => constr:(LHS) end in
                 let G' := context G[LHS] in
                 change G';
                   rewrite H;
                   clear H
        end.
        match goal with
          | [ |- context[f_equal _ ?p] ]
            => destruct p; unfold f_equal; simpl @eq_rect
        end.
        subst_body.
        reflexivity. }
      rewrite flatten_forall_eq_rect_symmetry_flattenT_unapply_apply.
      apply F_ext; intros.
      reflexivity.
    Qed.
  End F.
End FixVTransfer.

Section Fix_rect.
  Context (A : Type).
  Local Notation T := (fun _ : A => bottom).

  Let Fix_rect' := @FixV_rect A T.
  Let Fix_rect'T := Eval simpl in type_of Fix_rect'.

  Let Fix_Proper_eq' := @FixV_Proper_eq A T.
  Let Fix_Proper_eq'T := Eval simpl in type_of Fix_Proper_eq'.

  Let Fix_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T.
  Let Fix_Proper_eq_with_assumption'T := Eval simpl in type_of Fix_Proper_eq_with_assumption'.

  Definition Fix_rect : Fix_rect'T := Fix_rect'.
  Definition Fix_Proper_eq : Fix_Proper_eq'T := Fix_Proper_eq'.
  Definition Fix_Proper_eq_with_assumption : Fix_Proper_eq_with_assumption'T := Fix_Proper_eq_with_assumption'.
End Fix_rect.

Arguments Fix_Proper_eq {A R Rwf P} _ _ _ _.
Arguments Fix_Proper_eq_with_assumption {A R Rwf P} _ _ _ _ _ _.
Global Existing Instance Fix_Proper_eq.
Global Existing Instance Fix_Proper_eq_with_assumption.

(** A variant of [Fix] that has a nice [Fix_eq] for functions which
    doesn't require [functional_extensionality]. *)
(* Following code generated by the following Python script:
<<
ALPHA = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
alpha = ALPHA.lower()
for fixn in range(1, 11):
    print(r"""Section Fix%(fixn)d.""" % locals())
    def make_forall(n, pat, skip_forall=0):
        mycur = ''
        if n > skip_forall + 1:
            mycur += 'forall ' + ' '.join(alpha[skip_forall:n-1]) + ', '
        mycur2 = ''
        if n > 1:
            mycur2 += ' ' + ' '.join(alpha[:n-1])
        return mycur + (pat % mycur2)

    cur = '  Context A'
    for j in range(1, fixn + 1):
        cur += ' (%s : ' % ALPHA[j]
        cur += make_forall(j, '%s%%s -> Type)' % ALPHA[j-1])
    print(cur)
    print(r"""          (R : A -> A -> Prop) (Rwf : well_founded R)""")
    cur = "          (P : "
    cur += make_forall(j+1, '%s%%s -> Type).' % ALPHA[j])
    print(cur)
    print("")
    cur = "  Local Notation Fix%d := (@Fix A R Rwf (fun a : A => %s))."
    cur = cur % (j, make_forall(j+2, '@P%s', skip_forall=1))
    print(cur)
    def make_tele(chars, final, append=''):
        if chars:
            return '(fun %s => tele _ %s)' % (chars[0], make_tele(chars[1:], final, append + ' ' + chars[0]))
        else:
            return '(fun _ : %s%s => bottom)' % (final, append)
    print('  Local Notation T := %s.' % make_tele(alpha[:fixn], '@' + ALPHA[fixn]))
    fix_underscores = ' '.join('_' for i in range(fixn + 4))
    letters = ' '.join(ALPHA[:fixn+1])
    preletters = ' '.join(ALPHA[:fixn])
    print(r"""
  Let Fix%(fixn)d_eq' := @FixV_eq A T R Rwf P.
  Let Fix%(fixn)d_eq'T := Eval simpl in type_of Fix%(fixn)d_eq'.

  Let Fix%(fixn)d_rect' := @FixV_rect A T R Rwf P.
  Let Fix%(fixn)d_rect'T := Eval simpl in type_of Fix%(fixn)d_rect'.

  Let Fix%(fixn)d_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix%(fixn)d_Proper_eq'T := Eval simpl in type_of Fix%(fixn)d_Proper_eq'.

  Let Fix%(fixn)d_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix%(fixn)d_Proper_eq_with_assumption'T := Eval simpl in type_of Fix%(fixn)d_Proper_eq_with_assumption'.

  Definition Fix%(fixn)d_eq : Fix%(fixn)d_eq'T := Fix%(fixn)d_eq'.
  Definition Fix%(fixn)d_rect : Fix%(fixn)d_rect'T := Fix%(fixn)d_rect'.
  Definition Fix%(fixn)d_Proper_eq : Fix%(fixn)d_Proper_eq'T := Fix%(fixn)d_Proper_eq'.
  Definition Fix%(fixn)d_Proper_eq_with_assumption : Fix%(fixn)d_Proper_eq_with_assumption'T := Fix%(fixn)d_Proper_eq_with_assumption'.
End Fix%(fixn)d.

Arguments Fix%(fixn)d_Proper_eq {%(letters)s R Rwf P} %(fix_underscores)s.
Arguments Fix%(fixn)d_Proper_eq_with_assumption {%(letters)s R Rwf P} _ _ %(fix_underscores)s.
Global Existing Instance Fix%(fixn)d_Proper_eq.
Global Existing Instance Fix%(fixn)d_Proper_eq_with_assumption.
""" % locals())
>> *)
Section Fix1.
  Context A (B : A -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a, B a -> Type).

  Local Notation Fix1 := (@Fix A R Rwf (fun a : A => forall b, @P a b)).
  Local Notation T := (fun a => tele _ (fun _ : @B a => bottom)).

  Let Fix1_eq' := @FixV_eq A T R Rwf P.
  Let Fix1_eq'T := Eval simpl in type_of Fix1_eq'.

  Let Fix1_rect' := @FixV_rect A T R Rwf P.
  Let Fix1_rect'T := Eval simpl in type_of Fix1_rect'.

  Let Fix1_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix1_Proper_eq'T := Eval simpl in type_of Fix1_Proper_eq'.

  Let Fix1_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix1_Proper_eq_with_assumption'T := Eval simpl in type_of Fix1_Proper_eq_with_assumption'.

  Definition Fix1_eq : Fix1_eq'T := Fix1_eq'.
  Definition Fix1_rect : Fix1_rect'T := Fix1_rect'.
  Definition Fix1_Proper_eq : Fix1_Proper_eq'T := Fix1_Proper_eq'.
  Definition Fix1_Proper_eq_with_assumption : Fix1_Proper_eq_with_assumption'T := Fix1_Proper_eq_with_assumption'.
End Fix1.

Arguments Fix1_Proper_eq {A B R Rwf P} _ _ _ _ _.
Arguments Fix1_Proper_eq_with_assumption {A B R Rwf P} _ _ _ _ _ _ _.
Global Existing Instance Fix1_Proper_eq.
Global Existing Instance Fix1_Proper_eq_with_assumption.

Section Fix2.
  Context A (B : A -> Type) (C : forall a, B a -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b, C a b -> Type).

  Local Notation Fix2 := (@Fix A R Rwf (fun a : A => forall b c, @P a b c)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun _ : @C a b => bottom))).

  Let Fix2_eq' := @FixV_eq A T R Rwf P.
  Let Fix2_eq'T := Eval simpl in type_of Fix2_eq'.

  Let Fix2_rect' := @FixV_rect A T R Rwf P.
  Let Fix2_rect'T := Eval simpl in type_of Fix2_rect'.

  Let Fix2_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix2_Proper_eq'T := Eval simpl in type_of Fix2_Proper_eq'.

  Let Fix2_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix2_Proper_eq_with_assumption'T := Eval simpl in type_of Fix2_Proper_eq_with_assumption'.

  Definition Fix2_eq : Fix2_eq'T := Fix2_eq'.
  Definition Fix2_rect : Fix2_rect'T := Fix2_rect'.
  Definition Fix2_Proper_eq : Fix2_Proper_eq'T := Fix2_Proper_eq'.
  Definition Fix2_Proper_eq_with_assumption : Fix2_Proper_eq_with_assumption'T := Fix2_Proper_eq_with_assumption'.
End Fix2.

Arguments Fix2_Proper_eq {A B C R Rwf P} _ _ _ _ _ _.
Arguments Fix2_Proper_eq_with_assumption {A B C R Rwf P} _ _ _ _ _ _ _ _.
Global Existing Instance Fix2_Proper_eq.
Global Existing Instance Fix2_Proper_eq_with_assumption.

Section Fix3.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c, D a b c -> Type).

  Local Notation Fix3 := (@Fix A R Rwf (fun a : A => forall b c d, @P a b c d)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun _ : @D a b c => bottom)))).

  Let Fix3_eq' := @FixV_eq A T R Rwf P.
  Let Fix3_eq'T := Eval simpl in type_of Fix3_eq'.

  Let Fix3_rect' := @FixV_rect A T R Rwf P.
  Let Fix3_rect'T := Eval simpl in type_of Fix3_rect'.

  Let Fix3_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix3_Proper_eq'T := Eval simpl in type_of Fix3_Proper_eq'.

  Let Fix3_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix3_Proper_eq_with_assumption'T := Eval simpl in type_of Fix3_Proper_eq_with_assumption'.

  Definition Fix3_eq : Fix3_eq'T := Fix3_eq'.
  Definition Fix3_rect : Fix3_rect'T := Fix3_rect'.
  Definition Fix3_Proper_eq : Fix3_Proper_eq'T := Fix3_Proper_eq'.
  Definition Fix3_Proper_eq_with_assumption : Fix3_Proper_eq_with_assumption'T := Fix3_Proper_eq_with_assumption'.
End Fix3.

Arguments Fix3_Proper_eq {A B C D R Rwf P} _ _ _ _ _ _ _.
Arguments Fix3_Proper_eq_with_assumption {A B C D R Rwf P} _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix3_Proper_eq.
Global Existing Instance Fix3_Proper_eq_with_assumption.

Section Fix4.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d, E a b c d -> Type).

  Local Notation Fix4 := (@Fix A R Rwf (fun a : A => forall b c d e, @P a b c d e)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun _ : @E a b c d => bottom))))).

  Let Fix4_eq' := @FixV_eq A T R Rwf P.
  Let Fix4_eq'T := Eval simpl in type_of Fix4_eq'.

  Let Fix4_rect' := @FixV_rect A T R Rwf P.
  Let Fix4_rect'T := Eval simpl in type_of Fix4_rect'.

  Let Fix4_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix4_Proper_eq'T := Eval simpl in type_of Fix4_Proper_eq'.

  Let Fix4_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix4_Proper_eq_with_assumption'T := Eval simpl in type_of Fix4_Proper_eq_with_assumption'.

  Definition Fix4_eq : Fix4_eq'T := Fix4_eq'.
  Definition Fix4_rect : Fix4_rect'T := Fix4_rect'.
  Definition Fix4_Proper_eq : Fix4_Proper_eq'T := Fix4_Proper_eq'.
  Definition Fix4_Proper_eq_with_assumption : Fix4_Proper_eq_with_assumption'T := Fix4_Proper_eq_with_assumption'.
End Fix4.

Arguments Fix4_Proper_eq {A B C D E R Rwf P} _ _ _ _ _ _ _ _.
Arguments Fix4_Proper_eq_with_assumption {A B C D E R Rwf P} _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix4_Proper_eq.
Global Existing Instance Fix4_Proper_eq_with_assumption.

Section Fix5.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e, F a b c d e -> Type).

  Local Notation Fix5 := (@Fix A R Rwf (fun a : A => forall b c d e f, @P a b c d e f)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun _ : @F a b c d e => bottom)))))).

  Let Fix5_eq' := @FixV_eq A T R Rwf P.
  Let Fix5_eq'T := Eval simpl in type_of Fix5_eq'.

  Let Fix5_rect' := @FixV_rect A T R Rwf P.
  Let Fix5_rect'T := Eval simpl in type_of Fix5_rect'.

  Let Fix5_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix5_Proper_eq'T := Eval simpl in type_of Fix5_Proper_eq'.

  Let Fix5_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix5_Proper_eq_with_assumption'T := Eval simpl in type_of Fix5_Proper_eq_with_assumption'.

  Definition Fix5_eq : Fix5_eq'T := Fix5_eq'.
  Definition Fix5_rect : Fix5_rect'T := Fix5_rect'.
  Definition Fix5_Proper_eq : Fix5_Proper_eq'T := Fix5_Proper_eq'.
  Definition Fix5_Proper_eq_with_assumption : Fix5_Proper_eq_with_assumption'T := Fix5_Proper_eq_with_assumption'.
End Fix5.

Arguments Fix5_Proper_eq {A B C D E F R Rwf P} _ _ _ _ _ _ _ _ _.
Arguments Fix5_Proper_eq_with_assumption {A B C D E F R Rwf P} _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix5_Proper_eq.
Global Existing Instance Fix5_Proper_eq_with_assumption.

Section Fix6.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f, G a b c d e f -> Type).

  Local Notation Fix6 := (@Fix A R Rwf (fun a : A => forall b c d e f g, @P a b c d e f g)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun _ : @G a b c d e f => bottom))))))).

  Let Fix6_eq' := @FixV_eq A T R Rwf P.
  Let Fix6_eq'T := Eval simpl in type_of Fix6_eq'.

  Let Fix6_rect' := @FixV_rect A T R Rwf P.
  Let Fix6_rect'T := Eval simpl in type_of Fix6_rect'.

  Let Fix6_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix6_Proper_eq'T := Eval simpl in type_of Fix6_Proper_eq'.

  Let Fix6_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix6_Proper_eq_with_assumption'T := Eval simpl in type_of Fix6_Proper_eq_with_assumption'.

  Definition Fix6_eq : Fix6_eq'T := Fix6_eq'.
  Definition Fix6_rect : Fix6_rect'T := Fix6_rect'.
  Definition Fix6_Proper_eq : Fix6_Proper_eq'T := Fix6_Proper_eq'.
  Definition Fix6_Proper_eq_with_assumption : Fix6_Proper_eq_with_assumption'T := Fix6_Proper_eq_with_assumption'.
End Fix6.

Arguments Fix6_Proper_eq {A B C D E F G R Rwf P} _ _ _ _ _ _ _ _ _ _.
Arguments Fix6_Proper_eq_with_assumption {A B C D E F G R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix6_Proper_eq.
Global Existing Instance Fix6_Proper_eq_with_assumption.

Section Fix7.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type) (H : forall a b c d e f, G a b c d e f -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f g, H a b c d e f g -> Type).

  Local Notation Fix7 := (@Fix A R Rwf (fun a : A => forall b c d e f g h, @P a b c d e f g h)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun g => tele _ (fun _ : @H a b c d e f g => bottom)))))))).

  Let Fix7_eq' := @FixV_eq A T R Rwf P.
  Let Fix7_eq'T := Eval simpl in type_of Fix7_eq'.

  Let Fix7_rect' := @FixV_rect A T R Rwf P.
  Let Fix7_rect'T := Eval simpl in type_of Fix7_rect'.

  Let Fix7_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix7_Proper_eq'T := Eval simpl in type_of Fix7_Proper_eq'.

  Let Fix7_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix7_Proper_eq_with_assumption'T := Eval simpl in type_of Fix7_Proper_eq_with_assumption'.

  Definition Fix7_eq : Fix7_eq'T := Fix7_eq'.
  Definition Fix7_rect : Fix7_rect'T := Fix7_rect'.
  Definition Fix7_Proper_eq : Fix7_Proper_eq'T := Fix7_Proper_eq'.
  Definition Fix7_Proper_eq_with_assumption : Fix7_Proper_eq_with_assumption'T := Fix7_Proper_eq_with_assumption'.
End Fix7.

Arguments Fix7_Proper_eq {A B C D E F G H R Rwf P} _ _ _ _ _ _ _ _ _ _ _.
Arguments Fix7_Proper_eq_with_assumption {A B C D E F G H R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix7_Proper_eq.
Global Existing Instance Fix7_Proper_eq_with_assumption.

Section Fix8.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type) (H : forall a b c d e f, G a b c d e f -> Type) (I : forall a b c d e f g, H a b c d e f g -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f g h, I a b c d e f g h -> Type).

  Local Notation Fix8 := (@Fix A R Rwf (fun a : A => forall b c d e f g h i, @P a b c d e f g h i)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun g => tele _ (fun h => tele _ (fun _ : @I a b c d e f g h => bottom))))))))).

  Let Fix8_eq' := @FixV_eq A T R Rwf P.
  Let Fix8_eq'T := Eval simpl in type_of Fix8_eq'.

  Let Fix8_rect' := @FixV_rect A T R Rwf P.
  Let Fix8_rect'T := Eval simpl in type_of Fix8_rect'.

  Let Fix8_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix8_Proper_eq'T := Eval simpl in type_of Fix8_Proper_eq'.

  Let Fix8_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix8_Proper_eq_with_assumption'T := Eval simpl in type_of Fix8_Proper_eq_with_assumption'.

  Definition Fix8_eq : Fix8_eq'T := Fix8_eq'.
  Definition Fix8_rect : Fix8_rect'T := Fix8_rect'.
  Definition Fix8_Proper_eq : Fix8_Proper_eq'T := Fix8_Proper_eq'.
  Definition Fix8_Proper_eq_with_assumption : Fix8_Proper_eq_with_assumption'T := Fix8_Proper_eq_with_assumption'.
End Fix8.

Arguments Fix8_Proper_eq {A B C D E F G H I R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _.
Arguments Fix8_Proper_eq_with_assumption {A B C D E F G H I R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix8_Proper_eq.
Global Existing Instance Fix8_Proper_eq_with_assumption.

Section Fix9.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type) (H : forall a b c d e f, G a b c d e f -> Type) (I : forall a b c d e f g, H a b c d e f g -> Type) (J : forall a b c d e f g h, I a b c d e f g h -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f g h i, J a b c d e f g h i -> Type).

  Local Notation Fix9 := (@Fix A R Rwf (fun a : A => forall b c d e f g h i j, @P a b c d e f g h i j)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun g => tele _ (fun h => tele _ (fun i => tele _ (fun _ : @J a b c d e f g h i => bottom)))))))))).

  Let Fix9_eq' := @FixV_eq A T R Rwf P.
  Let Fix9_eq'T := Eval simpl in type_of Fix9_eq'.

  Let Fix9_rect' := @FixV_rect A T R Rwf P.
  Let Fix9_rect'T := Eval simpl in type_of Fix9_rect'.

  Let Fix9_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix9_Proper_eq'T := Eval simpl in type_of Fix9_Proper_eq'.

  Let Fix9_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix9_Proper_eq_with_assumption'T := Eval simpl in type_of Fix9_Proper_eq_with_assumption'.

  Definition Fix9_eq : Fix9_eq'T := Fix9_eq'.
  Definition Fix9_rect : Fix9_rect'T := Fix9_rect'.
  Definition Fix9_Proper_eq : Fix9_Proper_eq'T := Fix9_Proper_eq'.
  Definition Fix9_Proper_eq_with_assumption : Fix9_Proper_eq_with_assumption'T := Fix9_Proper_eq_with_assumption'.
End Fix9.

Arguments Fix9_Proper_eq {A B C D E F G H I J R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _.
Arguments Fix9_Proper_eq_with_assumption {A B C D E F G H I J R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix9_Proper_eq.
Global Existing Instance Fix9_Proper_eq_with_assumption.

Section Fix10.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type) (H : forall a b c d e f, G a b c d e f -> Type) (I : forall a b c d e f g, H a b c d e f g -> Type) (J : forall a b c d e f g h, I a b c d e f g h -> Type) (K : forall a b c d e f g h i, J a b c d e f g h i -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f g h i j, K a b c d e f g h i j -> Type).

  Local Notation Fix10 := (@Fix A R Rwf (fun a : A => forall b c d e f g h i j k, @P a b c d e f g h i j k)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun g => tele _ (fun h => tele _ (fun i => tele _ (fun j => tele _ (fun _ : @K a b c d e f g h i j => bottom))))))))))).

  Let Fix10_eq' := @FixV_eq A T R Rwf P.
  Let Fix10_eq'T := Eval simpl in type_of Fix10_eq'.

  Let Fix10_rect' := @FixV_rect A T R Rwf P.
  Let Fix10_rect'T := Eval simpl in type_of Fix10_rect'.

  Let Fix10_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix10_Proper_eq'T := Eval simpl in type_of Fix10_Proper_eq'.

  Let Fix10_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix10_Proper_eq_with_assumption'T := Eval simpl in type_of Fix10_Proper_eq_with_assumption'.

  Definition Fix10_eq : Fix10_eq'T := Fix10_eq'.
  Definition Fix10_rect : Fix10_rect'T := Fix10_rect'.
  Definition Fix10_Proper_eq : Fix10_Proper_eq'T := Fix10_Proper_eq'.
  Definition Fix10_Proper_eq_with_assumption : Fix10_Proper_eq_with_assumption'T := Fix10_Proper_eq_with_assumption'.
End Fix10.

Arguments Fix10_Proper_eq {A B C D E F G H I J K R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Arguments Fix10_Proper_eq_with_assumption {A B C D E F G H I J K R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix10_Proper_eq.
Global Existing Instance Fix10_Proper_eq_with_assumption.


Set Automatic Coercions Import.

Require Import c_util.
Require Import util.
Require Import geometry.
Require Import CRreal.
Require Import CRexp.
Require Import CRln.
Require Import Morphisms.
Set Implicit Arguments.
Open Local Scope CR_scope.

(* We require CR because we use it for Time.
 Todo: Take an arbitrary (C)Ring/(C)Field for Time, so that
 the classical development does not need a separate concrete module. *)

Let Time := CRasCSetoid.
Let Duration := NonNegCR.

Record Flow (X: CSetoid): Type :=
  { flow_morphism:> morpher (@st_eq X ==> @st_eq Time ==> @st_eq X)%signature
  ; flow_zero: forall x, flow_morphism x 0 [=] x
  ; flow_additive: forall x t t',
      flow_morphism x (t + t') [=] flow_morphism (flow_morphism x t) t'
  }.

Definition mono (f: Flow CRasCSetoid): Type :=
  ((forall x, strongly_increasing (f x)) + (forall x, strongly_decreasing (f x)))%type.

Definition range_flow_inv_spec (f: Flow CRasCSetoid)
  (i: OpenRange -> OpenRange -> OpenRange): Prop :=
    forall a p, in_orange a p -> forall b t, in_orange b (f p t) -> in_orange (i a b) t.

Hint Unfold range_flow_inv_spec.

Obligation Tactic := idtac.

Program Definition product_flow (X Y: CSetoid) (fx: Flow X) (fy: Flow Y):
  Flow (ProdCSetoid X Y) :=
    Build_Flow _ (fun xy t => (fx (fst xy) t, fy (snd xy) t)) _ _.

Next Obligation.
  intros X Y fx fy [s s0] [s1 s2] [A B] x y H0.
  split; [rewrite A | rewrite B]; rewrite H0; reflexivity.
Qed.

Next Obligation. destruct x. split; apply flow_zero. Qed.
Next Obligation. destruct x. split; apply flow_additive. Qed.

Module constant.
Section contents.

  Program Definition flow: Flow CRasCSetoid := Build_Flow _ (fun x _ => x) _ _.

  Next Obligation. exact (fun _ _ H _ _ _ => H). Qed.
  Next Obligation. reflexivity. Qed.
  Next Obligation. reflexivity. Qed.

  Let eps: Qpos := (1#100)%Qpos. (* todo: turn into parameter *)

  Definition neg_range: OpenRange.
    exists (Some (-'1%Q), Some (-'1%Q)).
    unfold uncurry. simpl. auto.
  Defined.

  Definition inv (a b: OpenRange): OpenRange :=
    if overestimate_oranges_overlap eps a b: bool then unbounded_range else neg_range.

  Lemma inv_correct: range_flow_inv_spec flow inv.
  Proof with auto.
    unfold range_flow_inv_spec, inv.
    intros.
    destruct_call overestimate_oranges_overlap.
    destruct x...
    elimtype False.
    apply n, oranges_share_point with p...
  Qed.

End contents.
End constant.

Module scale.
Section contents.

  Variables (s: CR) (sp: CRpos s) (f: Flow CRasCSetoid).

  Program Definition flow: Flow CRasCSetoid :=
    Build_Flow _ (fun x t => f x (s * t)) _ _.

  Next Obligation. intros a a' e b b' e'. rewrite e, e'. reflexivity. Qed.

  Next Obligation.
    intros. unfold morpher_to_func, proj1_sig.
    rewrite CRmult_0_r. apply flow_zero.
  Qed.

  Next Obligation.
    intros.
    unfold morpher_to_func at 1 3 5, proj1_sig.
    rewrite
      <- flow_additive,
      (Rmul_comm CR_ring_theory),
      (Rmul_comm CR_ring_theory s t),
      (Rmul_comm CR_ring_theory s t'),
      (Rdistr_l CR_ring_theory).
    reflexivity.
  Qed.

  Lemma inc: (forall x, strongly_increasing (f x)) ->
    forall x, strongly_increasing (flow x).
  Proof.
    repeat intro. unfold flow. simpl.
    apply X, CRmult_lt_pos_r; assumption.
  Qed.

  Variable old_inv: OpenRange -> OpenRange -> OpenRange.
  Hypothesis old_inv_correct: range_flow_inv_spec f old_inv.

  Lemma CRpos_apart_0 x: CRpos x -> x >< 0.
    right. apply CRpos_lt_0_rev. assumption.
  Defined.

  Definition sinv: CR := CRinvT s (CRpos_apart_0 sp).

  Lemma sinv_nonneg: 0 <= sinv.
  Proof.
    apply CRlt_le.
    apply CRpos_lt_0_rev.
    unfold sinv.
    apply CRinvT_pos.
    assumption.
  Qed.

  Definition inv (a b: OpenRange): OpenRange := scale_orange sinv_nonneg (old_inv a b).

  Lemma inv_correct: range_flow_inv_spec flow inv.
  Proof with auto.
    unfold range_flow_inv_spec in *.
    intros.
    unfold inv.
    simpl in H0.
    set (old_inv_correct H _ H0).
    clearbody i.
    assert (fst (` (scale_orange sinv_nonneg (old_inv a b))) [=] fst (` (scale_orange sinv_nonneg (old_inv a b)))) by reflexivity.
    assert (snd (` (scale_orange sinv_nonneg (old_inv a b))) [=] snd (` (scale_orange sinv_nonneg (old_inv a b)))) by reflexivity.
    assert (sinv * (s * t) == t).
      rewrite (Rmul_assoc CR_ring_theory).
      unfold sinv.
      rewrite (Rmul_comm CR_ring_theory (CRinvT s _)).
      unfold CRinv.
      rewrite (CRinvT_mult).
      apply (Rmul_1_l CR_ring_theory).
    rewrite <- H3. (* todo: this takes ridiculously long *)
    apply in_scale_orange...
  Qed.

End contents.
End scale.

Hint Resolve scale.inc scale.inv_correct.

Module positive_linear.
Section contents.

  Program Definition f: Flow CRasCSetoid :=
    Build_Flow _ (ucFun2 CRplus_uc) CRadd_0_r (Radd_assoc CR_ring_theory).

  Definition inv (x x': CR): Time := x' - x.

  Lemma inv_correct x x': f x (inv x x') == x'.
  Proof. intros. symmetry. apply t11. Qed.

  Lemma increasing: forall x : CRasCSetoid, strongly_increasing (f x).
  Proof. repeat intro. apply t1_rev. assumption. Qed.

  Definition mono: mono f := inl increasing.

End contents.
End positive_linear.

Hint Immediate positive_linear.increasing.

Module negative_linear.
Section contents.

  Let B x t t': x - (t + t') == x - t - t'.
    intros.
    rewrite (@Ropp_add _ _ _ _ _ _ _ _ t3 CR_ring_eq_ext CR_ring_theory ).
    apply (Radd_assoc CR_ring_theory).
  Qed.

  Program Definition f: Flow CRasCSetoid :=
    Build_Flow _ (fun x t => x - t) CRminus_zero B.

  Definition inv (x x': CR): Time := x - x'.

  Lemma inv_correct x x': f x (inv x x') == x'.
    intros.
    unfold f, inv.
    simpl morpher_to_func.
    rewrite <- diff_opp.
    symmetry.
    apply t11.
  Qed.

  Lemma decreasing: forall x : CRasCSetoid, strongly_decreasing (f x).
    repeat intro. simpl.
    apply t1_rev, CRlt_opp_compat.
    assumption.
  Qed.

  Definition mono: mono f := inr decreasing.

End contents.
End negative_linear.

Require Import vector_setoid.
Require Import VecEq.

Lemma Vforall2n_aux_inv (A B: Type) (R: A -> B -> Prop) n (v: vector A n) m (w: vector B m):
  Vforall2n_aux R v w -> forall i (p: lt i n) (q: lt i m), R (Vnth v p) (Vnth w q).
Admitted. (*
Proof.
  induction v; destruct w; simpl; intros; intuition.
    elimtype False.
    apply (lt_n_O _ p).
  destruct i; auto.
Qed. *)

Definition eq_vec_inv (T: Type) (R: relation T) n (x y: vector T n) (e: eq_vec R x y)
  i (p: (i < n)%nat): R (Vnth x p) (Vnth y p)
  := Vforall2n_aux_inv _ _ _ e p p.

(* Todo: Move the above two elsewhere. *)

Section vector_flow.

  Variable n : nat.
  Variable X : CSetoid.
  Variable vec_f : vector (Flow X) n.

  Let f (vec_x : vecCSetoid X n) (t : Time) : vecCSetoid X n :=
    let flow_dim i ip :=
      let f := Vnth vec_f ip in
      let x := Vnth vec_x ip in
        f x t
    in
      Vbuild flow_dim.

  Program Definition vector_flow : Flow (vecCSetoid X n) :=
    Build_Flow _ f _ _.

  Next Obligation. (* well-defined-ness *)
    do 6 intro.
    apply Veq_vec_nth. intros.
    unfold f.
    repeat rewrite Vbuild_nth.
    unfold morpher_to_func.
    rewrite (eq_vec_inv (@st_eq _) x y H).
    rewrite H0.
    reflexivity.
  Qed.

  Next Obligation. (* flow_zero *)
    apply Veq_vec_nth. intros. unfold f.
    repeat rewrite Vbuild_nth. apply flow_zero.
  Qed.

  Next Obligation. (* flow_additive *)
    apply Veq_vec_nth. intros. unfold f.
    repeat rewrite Vbuild_nth. apply flow_additive.
  Qed.

End vector_flow.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Extraction of [positive], [N] and [Z] into Ocaml's [big_int] *)

Require Coq.extraction.Extraction.

Require Import ZArith NArith.
Require Import ExtrOcamlBasic.

(** NB: The extracted code should be linked with [nums.cm(x)a]
    from ocaml's stdlib and with the wrapper [big.ml] that
    simplifies the use of [Big_int] (it can be found in the sources
    of Coq). *)

(** Disclaimer: trying to obtain efficient certified programs
    by extracting [Z] into [big_int] isn't necessarily a good idea.
    See the Disclaimer in [ExtrOcamlNatInt]. *)

(** Mapping of [positive], [Z], [N] into [big_int]. The last strings
    emulate the matching, see documentation of [Extract Inductive]. *)

Extract Inductive positive => "Big.big_int"
 [ "Big.doubleplusone" "Big.double" "Big.one" ] "Big.positive_case".

Extract Inductive Z => "Big.big_int"
 [ "Big.zero" "" "Big.opp" ] "Big.z_case".

Extract Inductive N => "Big.big_int"
 [ "Big.zero" "" ] "Big.n_case".

(** Nota: the "" above is used as an identity function "(fun p->p)" *)

(** Efficient (but uncertified) versions for usual functions *)

Extract Constant Pos.add => "Big.add".
Extract Constant Pos.succ => "Big.succ".
Extract Constant Pos.pred => "fun n -> Big.max Big.one (Big.pred n)".
Extract Constant Pos.sub => "fun n m -> Big.max Big.one (Big.sub n m)".
Extract Constant Pos.mul => "Big.mult".
Extract Constant Pos.min => "Big.min".
Extract Constant Pos.max => "Big.max".
Extract Constant Pos.compare =>
 "fun x y -> Big.compare_case Eq Lt Gt x y".
Extract Constant Pos.compare_cont =>
 "fun c x y -> Big.compare_case c Lt Gt x y".

Extract Constant N.add => "Big.add".
Extract Constant N.succ => "Big.succ".
Extract Constant N.pred => "fun n -> Big.max Big.zero (Big.pred n)".
Extract Constant N.sub => "fun n m -> Big.max Big.zero (Big.sub n m)".
Extract Constant N.mul => "Big.mult".
Extract Constant N.min => "Big.min".
Extract Constant N.max => "Big.max".
Extract Constant N.div =>
 "fun a b -> if Big.eq b Big.zero then Big.zero else Big.div a b".
Extract Constant N.modulo =>
 "fun a b -> if Big.eq b Big.zero then Big.zero else Big.modulo a b".
Extract Constant N.compare => "Big.compare_case Eq Lt Gt".

Extract Constant Z.add => "Big.add".
Extract Constant Z.succ => "Big.succ".
Extract Constant Z.pred => "Big.pred".
Extract Constant Z.sub => "Big.sub".
Extract Constant Z.mul => "Big.mult".
Extract Constant Z.opp => "Big.opp".
Extract Constant Z.abs => "Big.abs".
Extract Constant Z.min => "Big.min".
Extract Constant Z.max => "Big.max".
Extract Constant Z.compare => "Big.compare_case Eq Lt Gt".

Extract Constant Z.of_N => "fun p -> p".
Extract Constant Z.abs_N => "Big.abs".

(** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod).
    For the moment we don't even try *)

(** Test:
Require Import ZArith NArith.

Extraction "/tmp/test.ml"
 Pos.add Pos.pred Pos.sub Pos.mul Pos.compare N.pred N.sub N.div N.modulo N.compare
 Z.add Z.mul Z.compare Z.of_N Z.abs_N Z.div Z.modulo.
*)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable m_ : Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Prop.
Variable j_ : Universe -> Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable z_ : Universe.
Variable y_ : Universe.
Variable x_ : Universe.
Variable w_ : Universe.
Variable v_ : Universe.
Variable u_ : Universe.
Variable t_ : Universe.
Variable p_ : Universe.

Variable initial_model_1 : (dom_ y_ /\ (dom_ p_ /\ (dom_ v_ /\ (dom_ u_ /\ (dom_ z_ /\ (dom_ w_ /\ (dom_ t_ /\ (dom_ x_ /\ (j_ x_ y_ t_ /\ (j_ x_ z_ u_ /\ (m_ t_ u_ v_ /\ (m_ y_ z_ w_ /\ j_ x_ w_ p_)))))))))))).
Variable goal_ax_2 : (lt_ v_ p_ -> goal_).
Variable lt_refl_3 : (forall X : Universe, (dom_ X -> lt_ X X)).
Variable lt_trans_4 : (forall X Y Z : Universe, ((lt_ X Y /\ lt_ Y Z) -> lt_ X Z)).
Variable lb_meet_5 : (forall X Y Z : Universe, (m_ X Y Z -> (lt_ Z X /\ lt_ Z Y))).
Variable glb_meet_6 : (forall X Y Z U : Universe, ((m_ X Y Z /\ (lt_ U X /\ lt_ U Y)) -> lt_ U Z)).
Variable ub_join_7 : (forall X Y Z : Universe, (j_ X Y Z -> (lt_ X Z /\ lt_ Y Z))).
Variable lub_join_8 : (forall X Y Z U : Universe, ((j_ X Y Z /\ (lt_ X U /\ lt_ Y U)) -> lt_ Z U)).
Variable lt_m_j_9 : (forall X Y : Universe, (lt_ X Y -> (m_ X Y X /\ j_ X Y Y))).
Variable commute_m_10 : (forall X Y Z : Universe, (m_ X Y Z -> m_ Y X Z)).
Variable commute_j_11 : (forall X Y Z : Universe, (j_ X Y Z -> j_ Y X Z)).
Variable assoc_m_12 : (forall X Y U Z V W : Universe, ((m_ X Y U /\ (m_ U Z V /\ m_ Y Z W)) -> m_ X W V)).
Variable assoc_j_13 : (forall X Y U Z V W : Universe, ((j_ X Y U /\ (j_ U Z V /\ j_ Y Z W)) -> j_ X W V)).
Variable lo_le_distr_14 : (forall Y Z T X U V W P : Universe, ((j_ Y Z T /\ (m_ X T U /\ (m_ X Y V /\ (m_ X Z W /\ j_ V W P)))) -> lt_ U P)).
Variable do_latt_15 : (forall X Y : Universe, ((dom_ X /\ dom_ Y) -> (exists U : Universe, (dom_ U /\ m_ X Y U)))).

Theorem latt_16 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Util
               Entropy.
Require Export rewriting_system.

Module Type ABSTRACT_MACHINE.

  Parameters
  (term          : Set)
  (configuration : Set)
  (value         : Set)

  (load          : term -> configuration)
  (final         : configuration -> option value)
  (transition    : configuration -> configuration -> Prop)
  (next_conf     : entropy -> configuration -> option configuration).

  Definition is_final c := exists v, final c = Some v.

  Instance rws : REWRITING_SYSTEM configuration :=
  { transition := transition }.

  Axioms
  (final_correct :                                                              forall c,
       final c <> None -> ~exists c', c → c')
  (trans_computable :                                                       forall c1 c2,
       c1 → c2 <-> exists e, next_conf e c1 = Some c2).

  Class SafeRegion (P : configuration -> Prop) :=
  {
      preservation :                                                        forall c1 c2,
          P c1  ->  c1 → c2  ->  P c2;
      progress :                                                               forall c1,
          P c1  ->  (is_final c1) \/ (exists c2, c1 → c2)
  }.

End ABSTRACT_MACHINE.

Module Type DET_ABSTRACT_MACHINE.

  Include ABSTRACT_MACHINE.

  Parameter dnext_conf : configuration -> option configuration.
  Axiom dnext_is_next  : forall e c, next_conf e c = dnext_conf c.

End DET_ABSTRACT_MACHINE.


Set Implicit Arguments.
Require Import Logic.

(*Global Set Universe Polymorphism.*)
Global Set Asymmetric Patterns.
Local Set Primitive Projections.

Local Open Scope type_scope.

Record prod (A B : Type) : Type :=
  pair { fst : A; snd : B }.

Arguments pair {A B} _ _.

Notation "x * y" := (prod x y) : type_scope.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.

Generalizable Variables X A B f g n.

Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.

Arguments idpath {A a} , [A] a.

Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.

Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
  match p with idpath => u end.

Definition transport_prod' {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a')
  (z : P a * Q a)
  : transport (fun a => P a * Q a) p z  =  (transport _ p (fst z), transport _ p (snd z))
  := match p as p' return transport (fun a0 => P a0 * Q a0) p' z = (transport P p' (fst z), transport Q p' (snd z)) with
       | idpath => idpath
     end. (* success *)

Definition transport_prod {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a')
  (z : P a * Q a)
  : transport (fun a => P a * Q a) p z  =  (transport _ p (fst z), transport _ p (snd z))
  := match p with
       | idpath => idpath
     end.


(**

This file describes the grouping transformation relations as a function.

Author: Ramon Fernandez I Mir and Arthur Charguéraud.

License: MIT.

*)

Set Implicit Arguments.
Require Export Semantics LibSet LibMap TLCbuffer TrGroup.

(* ---------------------------------------------------------------------- *)
(** Explicit definitions *)

Fixpoint fun_tr_accesses (gt:group_tr) (π:accesses) : accesses :=
  let aux := fun_tr_accesses gt in
  match π with
  | nil => nil
  | ((access_array T i)::π') => ((access_array T i)::(aux π'))
  | ((access_field T f)::π') =>
      if isTrue(T = typ_var (group_tr_struct_name gt)) then
        if isTrue(f \in group_tr_fields gt) then
          let Tg := typ_var (group_tr_new_struct_name gt) in
          let fg := group_tr_new_struct_field gt in
          ((access_field T fg)::(access_field Tg f)::(aux π'))
        else
          ((access_field T f)::(aux π'))
      else
        ((access_field T f)::(aux π'))
  end.

Fixpoint fun_tr_val_depth (depth:nat) (gt:group_tr) (v:val) : val :=
  match depth with
    | O => v
    | S n =>
      let aux := fun_tr_val_depth n gt in
      match v with
      | val_error => val_error
      | val_uninitialized => val_uninitialized
      | val_unit => val_unit
      | val_bool b => val_bool b
      | val_int i => val_int i
      | val_double d => val_double d
      | val_abstract_ptr l π => val_abstract_ptr l (fun_tr_accesses gt π)
      | val_concrete_ptr l o => val_concrete_ptr l o (* TODO: This is not correct. *)
      | val_array T nil => val_array T nil
      | val_array T vs => (val_array T (LibList.map aux vs))
      | val_struct T s =>
          let m : monoid_op (map field val) := monoid_make (fun a b => a \u b) \{} in
          let g : field -> val -> map field val := fun f v => (\{})[f:=(aux v)] in
          if isTrue(T=typ_var (group_tr_struct_name gt)) then
            let Tg := typ_var (group_tr_new_struct_name gt) in
            let fg := group_tr_new_struct_field gt in
            let fs := group_tr_fields gt in
            let s' := fold m g s in
            let g1' : field -> val -> map field val :=
              fun f v => if (isTrue(f \in fs)) then (\{}) else (\{})[f:=v] in
            let g2' : field -> val -> map field val :=
              fun f v => if (isTrue(f \in fs)) then (\{})[f:=v] else (\{}) in
            let s1' := fold m g1' s' in
            let s2' := fold m g2' s' in
            val_struct T (s1'[fg:=(val_struct Tg s2')])
          else
            val_struct T (fold m g s)
        | val_words lw => val_words lw (* TODO: Not correct either. *)
      end
   end.

(* ---------------------------------------------------------------------- *)
(** Lemmas outline. Some ideas. *)

Lemma tr_val_fun_tr_val : forall gt n v,
  fun_tr_val_depth n gt v = fun_tr_val_depth (S n) gt v ->
  tr_val gt v (fun_tr_val_depth n gt v).
Proof using.
Admitted.

Lemma fixpoint_fun_tr_val : forall gt v,
  exists n, fun_tr_val_depth n gt v = fun_tr_val_depth (S n) gt v.
Proof using.
Admitted.

Lemma depth_fun_tr_val : forall gt v,
  exists n, tr_val gt v (fun_tr_val_depth n gt v).
Proof using.
  intros. forwards (n&H): fixpoint_fun_tr_val gt v.
  exists n. applys tr_val_fun_tr_val.
  unfolds fun_tr_val_depth. auto.
Qed.

Lemma total_tr_accesses : forall gt π,
  exists π', tr_accesses gt π π'.
Proof using.
  induction π; eauto. destruct a.
  { inverts IHπ; exists __. constructors*.  }
  { tests: (t = typ_var (group_tr_struct_name gt)).
    { tests: (f \in group_tr_fields gt).
      { inverts IHπ. destruct gt. exists __.
        applys* tr_accesses_field_group. }
      { inverts IHπ. destruct gt. exists __.
        applys* tr_accesses_field_other. } }
    { inverts IHπ; exists __. applys* tr_accesses_field_other. } }
Qed.

Lemma total_tr_val : forall gt v,
  exists v', tr_val gt v v'.
Proof using.
  intros. forwards* (n&H): depth_fun_tr_val gt v.
Qed.


(** Adapted from "Elements of Set Theory" Chapter 7 **)
(** Coq coding by choukh, Dec 2020 **)

Require Export ZFC.Elements.EST7_3.
Require Export ZFC.Lib.Class.
Require Import ZFC.Lib.FuncFacts.

(*** EST第七章4：序数的定义，序数的序，布拉利-福尔蒂悖论，
  后继序数，极限序数，序数上的超限归纳模式 ***)

Import WoStruct.
Section EpsilonImageWellDefined.
Import WoStruct.EpsilonImage.

Local Lemma eq_α : ∀ f S T, f:ₒₑ S ⟺ T →
  (∀x ∈ A S, (E S)[x] = (E T)[f[x]]) → α S = α T.
Proof with eauto; try congruence.
  intros * [Hf Hoe] Heq.
  destruct (e_bijective S) as [[Hf1 _] [Hd1 _]].
  destruct (e_bijective T) as [[Hf2 _] [Hd2 _]].
  apply inv_bijection in Hf as Hf'.
  apply bijection_is_func in Hf as [Hf [Hif Hrf]].
  apply bijection_is_func in Hf' as [Hf' _].
  unfold α. rewrite ran_eq_repl_by_ap, ran_eq_repl_by_ap...
  ext y Hy.
  - apply ReplAx in Hy as [x [Hx Hap]]. rewrite Heq in Hap...
    apply ReplAx. exists (f[x]). split... rewrite Hd2.
    eapply ap_ran...
  - apply ReplAx in Hy as [x [Hx Hap]].
    rewrite <- (inv_ran_reduction f Hif x), <- Heq in Hap...
    apply ReplAx. exists (f⁻¹[x]). split...
    rewrite Hd1. eapply ap_ran... eapply ap_ran...
Qed.

Import OrderedStruct.

(* 伊普西隆像良定义 *)
Theorem epsilon_image_well_defined :
  ∀ S T, parent S ≅ parent T ↔ α S = α T.
Proof with eauto; try congruence.
  intros S T. split; revgoals. {
    intros Heq. rewrite wo_iso_epsilon, wo_iso_epsilon.
    unfold ε. rewrite Heq. reflexivity.
  }
  intros [f [Hf Hoe]].
  eapply eq_α. split... intros x Hx.
  set {x ∊ WoStruct.A S | (E S)[x] = (E T)[f[x]]} as B.
  replace (WoStruct.A S) with B in Hx.
  apply SepE2 in Hx... clear x Hx.
  eapply transfinite_induction...
  split. intros t Ht. apply SepE1 in Ht...
  intros t Ht Hsub. apply SepI...
  assert (Hft: f[t] ∈ WoStruct.A T). {
    eapply ap_ran... apply bijection_is_func...
  }
  rewrite e_ap, e_ap...
  ext Hx.
  - apply ReplAx in Hx as [s [Hs Heq]]. subst x.
    apply ReplAx. exists (f[s]). split.
    + apply SepE in Hs as [Hs Hlt].
      eapply dom_binRel in Hs; [|apply (WoStruct.wo S)].
      apply segI. apply Hoe...
    + apply Hsub in Hs. apply SepE2 in Hs...
  - apply inv_bijection in Hf as Hf'.
    apply bijection_is_func in Hf as [_ [Hi Hr]].
    apply bijection_is_func in Hf' as [Hf' _].
    apply ReplAx in Hx as [s [Hs Heq]]. subst x.
    apply SepE in Hs as [Hs Hlt].
    eapply dom_binRel in Hs; [|apply (WoStruct.wo T)].
    assert (Hsr: s ∈ ran f) by (rewrite Hr; apply Hs).
    apply ReplAx. exists (f⁻¹[s]). split.
    + apply segI. apply Hoe...
      * eapply ap_ran...
      * rewrite inv_ran_reduction...
    + rewrite <- (inv_ran_reduction f Hi s) in Hlt...
      apply Hoe in Hlt; [|eapply ap_ran|]...
      assert (f⁻¹[s] ∈ seg t (WoStruct.R S)). {
        apply SepI... eapply domI...
      }
      apply Hsub in H. apply SepE2 in H.
      rewrite inv_ran_reduction in H...
Qed.

End EpsilonImageWellDefined.

Section OrdDef.
Import WoStruct.EpsilonImage.

(* 序数 *)
Definition ord := λ S, α S.
(* 序数类 *)
Definition is_ord := λ α, ∃ S, α = ord S.
Notation 𝐎𝐍 := is_ord.

Lemma ord_is_ord : ∀ S, ord S ⋵ 𝐎𝐍.
Proof. intros. exists S. auto. Qed.
Hint Immediate ord_is_ord : core.

(* 序数良定义 *)
Lemma ord_well_defined : ∀ S T, S ≅ T ↔ ord S = ord T.
Proof with auto.
  split; intros.
  - unfold ord, α. apply epsilon_image_well_defined.
    rewrite <- parent_iso...
  - apply epsilon_image_well_defined in H. apply parent_iso...
Qed.

Lemma ordI : ∀ S t, ∀s ∈ A S, (E S)[s] = t → t ∈ ord S.
Proof. exact α_intro. Qed.

Lemma ordE : ∀ S, ∀t ∈ ord S, ∃s ∈ A S, (E S)[s] = t.
Proof. exact α_elim. Qed.

(* 由同构关系导出序数的序 *)
Lemma ord_lt_intro : ∀ S T, ∀t ∈ A T, S ≅ Seg t T → ord S ∈ ord T.
Proof with eauto.
  intros S T t Ht Hiso. eapply ordI...
  apply ord_well_defined in Hiso. rewrite seg_α in Hiso...
Qed.

(* 由序数的序导出同构关系 *)
Lemma ord_lt_elim : ∀ S T, ord S ∈ ord T → ∃t ∈ A T, S ≅ Seg t T.
Proof with eauto.
  intros. apply ordE in H as [t [Ht H]]. exists t. split...
  apply ord_well_defined. rewrite seg_α...
Qed.

(* 序数的序数等于自身 *)
Lemma ord_of_ord : ∀ S, ord S = ord (Epsilon S).
Proof.
  intros. apply ord_well_defined. apply iso_epsilon.
Qed.

(* 空集的序数等于零 *)
Lemma ord_empty : ∀ S, A S = ∅ → ord S = ∅.
Proof.
  intros. apply e_empty in H.
  unfold ord, α. rewrite H. apply ran_of_empty.
Qed.

(* 序数是良序集 *)
Lemma ord_woset : ∀α ⋵ 𝐎𝐍, woset α (MemberRel α).
Proof. intros α [S H]. subst. apply (wo (Epsilon S)). Qed.

(* 可以以成员关系良序排列的传递集是序数 *)
Theorem transitive_set_well_ordered_by_epsilon_is_ord :
  ∀ α, trans α → woset α (MemberRel α) → α ⋵ 𝐎𝐍.
Proof with eauto.
  intros α Htr Hwo.
  set (constr α (MemberRel α) Hwo) as S.
  cut (∀x ∈ α, (E S)[x] = x). {
    intros H. exists S.
    pose proof (e_bijective S) as [[Hf _] [Hd _]]...
    ext Hx.
    - apply (ranI _ x). apply func_point...
      rewrite Hd. apply Hx.
    - apply ranE in Hx as [w Hp].
      apply domI in Hp as Hw. rewrite Hd in Hw.
      apply func_ap in Hp... rewrite H in Hp... subst...
  }
  intros x Hx.
  set {x ∊ α | (E S)[x] = x} as B.
  replace α with B in Hx. apply SepE2 in Hx... clear Hx x.
  eapply transfinite_induction. apply (wo S). split.
  intros x Hx. apply SepE1 in Hx...
  intros t Ht Hsub. apply SepI... rewrite e_ap...
  ext Hx.
  - apply ReplAx in Hx as [s [Hs H1]]. apply Hsub in Hs as Hsb.
    apply SepE in Hsb as [_ H2]. apply SepE in Hs as [_ H].
    rewrite <- H2, H1 in H.
    apply binRelE3 in H...
  - assert (x ∈ seg t (R S)). {
      apply segI. apply binRelI...
    }
    apply ReplAx. exists x. split...
    apply Hsub in H. apply SepE2 in H...
Qed.

(* 序数里都是序数 *)
Theorem ord_is_ords : ∀α ⋵ 𝐎𝐍, α ⪽ 𝐎𝐍.
Proof.
  intros α [S H] x Hx. subst.
  apply ordE in Hx as [t [Ht Heqx]]. subst x.
  set (Seg t S) as T. exists T.
  symmetry. apply seg_α. apply Ht.
Qed.

(* 序数是传递集 *)
Theorem ord_trans : ∀α ⋵ 𝐎𝐍, trans α.
Proof.
  intros α [S H]. subst. apply α_trans.
Qed.

(* 序数的序反自反 *)
Theorem ord_irrefl : ∀α ⋵ 𝐎𝐍, α ∉ α.
Proof.
  intros α [S H]. subst. intros H.
  pose proof (ordE _ _ H) as [s [Hs Heq]].
  rewrite <- Heq in H. eapply e_irrefl; eauto.
Qed.

End OrdDef.
Notation 𝐎𝐍 := is_ord.
Global Hint Immediate ord_is_ord : core.

(* 序数的序满足三歧性 *)
Theorem ord_trich : ∀ α β ⋵ 𝐎𝐍,
  α ∈ β ∧ α ≠ β ∧ β ∉ α ∨
  α ∉ β ∧ α = β ∧ β ∉ α ∨
  α ∉ β ∧ α ≠ β ∧ β ∈ α.
Proof with eauto.
  intros α Hα β Hβ.
  assert (α ∈ β ∨ α = β ∨ β ∈ α). {
    destruct Hα as [S Heqα].
    destruct Hβ as [T Heqβ]. subst.
    destruct (wo_iso_at_least_trich S T) as [H|[[t [Ht H]]|[t [Ht H]]]].
    - right; left. apply ord_well_defined...
    - left. eapply ord_lt_intro...
    - right; right. eapply ord_lt_intro... symmetry...
  }
  destruct H as [Hab|[Hnq|Hba]].
  - left. split... split; intros H; subst;
    eapply ord_irrefl... eapply ord_trans...
  - right; left. repeat split; auto; intros H; subst;
    eapply ord_irrefl...
  - right; right. repeat split; auto; intros H; subst;
    eapply ord_irrefl... eapply ord_trans...
Qed.

(* 序数的序是连通的 *)
Corollary ord_connected : ∀ α β ⋵ 𝐎𝐍, α ≠ β → α ∈ β ∨ β ∈ α.
Proof.
  intros α Hα β Hβ Hnq.
  destruct (ord_trich α Hα β) as [[H []]|[[H []]|[H []]]]; tauto.
Qed.

(* 序数具有可比较性 *)
Corollary ord_comparability : ∀ α β ⋵ 𝐎𝐍, α ⋸ β ∨ β ⋸ α.
Proof with auto.
  intros α Hα β Hβ.
  destruct (classic (α = β)). left. right...
  apply ord_connected in H as []...
Qed.

(* 序数的小于等于关系与子集关系等价 *)
Corollary ord_le_iff_sub : ∀ α β ⋵ 𝐎𝐍, α ⋸ β ↔ α ⊆ β.
Proof with eauto.
  intros α Hα β Hβ. split.
  - intros [].
    + intros x Hx. eapply ord_trans...
    + subst. apply sub_refl.
  - intros H. destruct (classic (α = β)). right...
    left. apply ord_connected in H0 as []...
    apply H in H0. exfalso. eapply ord_irrefl...
Qed.

Ltac ord_ext := apply sub_antisym; apply ord_le_iff_sub.

(* 序数的任意前节也是序数 *)
Fact seg_of_ord : ∀α ⋵ 𝐎𝐍, ∀β ∈ α, seg β (MemberRel α) = β.
Proof with eauto.
  intros α Hα β Hlt.
  ext Hx.
  - apply SepE2 in Hx. apply binRelE3 in Hx...
  - apply segI. apply binRelI... eapply ord_trans...
Qed.

(* 序数的非空集合一定有最小序数 *)
Theorem ords_has_minimum : ∀ A, A ⪽ 𝐎𝐍 → ⦿ A →
  ∃μ ∈ A, ∀α ∈ A, μ ⋸ α.
Proof with eauto.
  intros A Hord [β Hβ].
  destruct (classic (β ∩ A = ∅)) as [H0|Hne].
  - exists β. split... intros α Hα.
    destruct (classic (α = β))...
    apply ord_connected in H as []; [| |apply Hord..]...
    eapply EmptyE in H0. exfalso. apply H0. apply BInterI...
  - set (β ∩ A) as B. fold B in Hne.
    apply EmptyNE in Hne... apply Hord in Hβ.
    set (constr β (MemberRel β) (ord_woset β Hβ)) as S.
    pose proof (min_correct S B) as [Hm Hmin]...
    + intros b Hb. apply BInterE in Hb as []...
    + set ((Min S)[B]) as μ. fold μ in Hm, Hmin.
      apply BInterE in Hm as [Hμβ Hμs]...
      exists μ. split... intros α Hαs.
      destruct (classic (α ∈ β)) as [Hαβ|Hαβ].
      * assert (α ∈ B) by (apply BInterI; auto).
        apply Hmin in H as []... apply binRelE3 in H...
      * apply Hord in Hαs.
        assert (β ⋸ α). {
          destruct (ord_trich α Hαs β) as [[H []]|[[H []]|[H []]]];
          auto; tauto.
        }
        apply ord_le_iff_sub in H...
Qed.

(* 序数集是良序集 *)
Theorem ords_woset : ∀ A, A ⪽ 𝐎𝐍 → woset A (MemberRel A).
Proof with eauto.
  intros S Hord. repeat split.
  - apply memberRel_is_binRel.
  - intros α β γ Hαβ Hβγ.
    apply binRelE2 in Hαβ as [Hα [Hβ Hαβ]].
    apply binRelE2 in Hβγ as [_  [Hγ Hβγ]].
    apply binRelI... eapply ord_trans...
  - intros α Hα β Hβ.
    destruct (ord_trich α (Hord α Hα) β (Hord β Hβ))
      as [[H []]|[[H []]|[H []]]].
    + left. repeat split... apply binRelI...
      intros H2. apply H1. apply binRelE3 in H2...
    + right; left. repeat split...
      intros H2. apply H. apply binRelE3 in H2...
      intros H2. apply H1. apply binRelE3 in H2...
    + right; right. repeat split...
      intros H2. apply H. apply binRelE3 in H2...
      apply binRelI...
  - intros B Hne Hsub.
    pose proof (ords_has_minimum B) as [μ Hmin]...
    exists μ. eapply ε_minimum_iff...
Qed.

(* 由序数组成的传递集是序数 *)
Corollary transitive_set_of_ords_is_ord :
  ∀ A, A ⪽ 𝐎𝐍 → trans A → A ⋵ 𝐎𝐍.
Proof with auto.
  intros A Hord Htr.
  apply transitive_set_well_ordered_by_epsilon_is_ord...
  apply ords_woset...
Qed.

(* 零是序数 *)
Corollary empty_is_ord : ∅ ⋵ 𝐎𝐍.
Proof.
  apply transitive_set_of_ords_is_ord.
  intros x Hx. exfalso0. intros x y _ Hy. exfalso0.
Qed.
Global Hint Resolve empty_is_ord : core.

(* 后继序数是序数 *)
Corollary ord_suc_is_ord : ∀ α, α ⋵ 𝐎𝐍 → α⁺ ⋵ 𝐎𝐍.
Proof with eauto.
  intros α Hord.
  apply transitive_set_of_ords_is_ord.
  - intros x Hx. apply BUnionE in Hx as [].
    + eapply ord_is_ords...
    + apply SingE in H. subst...
  - apply ex4_2. apply ord_trans...
Qed.
Global Hint Resolve ord_suc_is_ord : core.

(* 序数集的并是序数 *)
Corollary union_of_ords_is_ord : ∀ A, A ⪽ 𝐎𝐍 → ⋃ A ⋵ 𝐎𝐍.
Proof with eauto.
  intros A Hord.
  apply transitive_set_of_ords_is_ord.
  - intros x Hx. apply UnionAx in Hx as [y [Hy Hx]].
    apply Hord in Hy. eapply ord_is_ords...
  - apply trans_sub. intros δ Hδ.
    apply UnionAx in Hδ as [α [Hα Hδ]].
    eapply sub_trans; revgoals. apply union_is_ub...
    apply ord_le_iff_sub... eapply ord_is_ords.
    apply Hord... apply Hδ.
Qed.

(* 两个序数的二元并是序数 *)
Corollary bunion_of_ords_is_ord : ∀ α β ⋵ 𝐎𝐍, α ∪ β ⋵ 𝐎𝐍.
Proof.
  intros α Hoα β Hoβ. apply union_of_ords_is_ord.
  intros x Hx. apply PairE in Hx as []; subst; auto.
Qed.

(* 序数上界 *)
Definition is_ub := λ μ A, μ ⋵ 𝐎𝐍 ∧ ∀α ∈ A, α ⋸ μ.

(* 序数/序数集上确界 *)
Definition sup := λ A, ⋃ A.
Definition is_sup := λ μ A, is_ub μ A ∧ ∀ α, is_ub α A → μ ⋸ α.

(* 序数集的并是其上界 *)
Lemma ord_sup_is_ub : ∀ A, A ⪽ 𝐎𝐍 → is_ub (sup A) A.
Proof with auto.
  intros A Hord.
  apply union_of_ords_is_ord in Hord as Hu.
  split... intros α Hα. apply ord_le_iff_sub...
  apply union_is_ub...
Qed.

(* 序数集的并是其上确界 *)
Lemma ord_sup_correct : ∀ A, A ⪽ 𝐎𝐍 → is_sup (sup A) A.
Proof with auto.
  intros A Hord.
  split. apply ord_sup_is_ub...
  intros α [H1 H2]. apply ord_le_iff_sub...
  apply union_of_ords_is_ord...
  apply union_is_sup. intros a Ha.
  apply ord_le_iff_sub...
Qed.

(* 两个序数的二元并等于它们中较大的一个 *)
Lemma ord_max_l : ∀ α β ⋵ 𝐎𝐍, β ⋸ α → α ∪ β = α.
Proof with auto.
  intros α Hoα β Hoβ Hle.
  apply ord_le_iff_sub in Hle...
  ext Hx.
  - apply BUnionE in Hx as []...
  - apply BUnionI1...
Qed.

Lemma ord_max_r : ∀ α β ⋵ 𝐎𝐍, α ⋸ β → α ∪ β = β.
Proof with auto.
  intros α Hoα β Hoβ Hle.
  apply ord_le_iff_sub in Hle...
  ext Hx.
  - apply BUnionE in Hx as []...
  - apply BUnionI2...
Qed.

(* 后继序数是大于该序数的最小序数 *)
Lemma ord_suc_correct : ∀ α β ⋵ 𝐎𝐍, α ∈ β → α⁺ ⋸ β.
Proof with eauto.
  intros α Hoα β Hoβ Hα. apply ord_le_iff_sub...
  intros x Hx. apply BUnionE in Hx as [].
  - eapply ord_trans...
  - apply SingE in H. subst...
Qed.

(* ω是序数 *)
Fact ω_is_ord : ω ⋵ 𝐎𝐍.
Proof.
  exists ℕ̃. symmetry. apply α_ω.
Qed.
Global Hint Resolve ω_is_ord : core.

(* ω是序数集 *)
Fact ω_is_ords : ω ⪽ 𝐎𝐍.
Proof. apply ord_is_ords. apply ω_is_ord. Qed.
Global Hint Resolve ω_is_ords : core.

(* 自然数是序数 *)
Fact nat_is_ord : ∀ n : nat, n ⋵ 𝐎𝐍.
Proof. intros. apply ω_is_ords. apply embed_ran. Qed.
Global Hint Immediate nat_is_ord : number_hint.

(* 有限序数的上确界是ω *)
Fact sup_of_ω_is_ω : is_sup ω ω.
Proof.
  replace ω with (⋃ ω) at 1.
  apply ord_sup_correct. apply ω_is_ords.
  apply sub_antisym. apply trans_union_sub. apply ω_trans.
  intros n Hn. apply UnionAx. exists n⁺. split.
  apply ω_inductive. apply Hn. apply suc_has_n.
Qed.

(* 布拉利-福尔蒂悖论：不存在包含所有序数的集合 *)
Theorem Burali_Forti : ¬ ∃ A, ∀α ⋵ 𝐎𝐍, α ∈ A.
Proof with eauto.
  intros [A HA].
  set {x ∊ A | x ⋵ 𝐎𝐍} as Ω.
  assert (HΩ: ∀ α, α ⋵ 𝐎𝐍 ↔ α ∈ Ω). {
    split; intros H. apply SepI... apply SepE2 in H...
  }
  cut (Ω ⋵ 𝐎𝐍). {
    intros Hord. apply HΩ in Hord as Hrefl.
    eapply ord_irrefl...
  }
  apply transitive_set_well_ordered_by_epsilon_is_ord.
  - intros x y Hxy Hy. apply HΩ.
    eapply ord_is_ords. apply SepE2 in Hy... apply Hxy.
  - apply ords_woset. intros α Hα. apply SepE2 in Hα...
Qed.

(** more about order of ord parallel to nat in EST4_3 **)

Lemma ord_trans_le : ∀ α β, ∀ γ ⋵ 𝐎𝐍, α ⋸ β → β ⋸ γ → α ⋸ γ.
Proof with eauto.
  intros α β γ Hγ [Hαβ|Hαβ] [Hβγ|Hβγ].
  - left. eapply ord_trans...
  - subst. left...
  - subst. left...
  - subst. right...
Qed.

Lemma ord_trans_lt_le : ∀ α β, ∀ γ ⋵ 𝐎𝐍, α ∈ β → β ⋸ γ → α ∈ γ.
Proof with eauto.
  intros α β γ Hγ Hαβ [Hβγ|Hβγ].
  eapply ord_trans... subst...
Qed.

Lemma ord_trans_le_lt : ∀ α β, ∀ γ ⋵ 𝐎𝐍,  α ⋸ β → β ∈ γ → α ∈ γ.
Proof with eauto.
  intros α β γ Hγ [Hαβ|Hαβ] Hβγ.
  eapply ord_trans... subst...
Qed.

(* 两个序数不能同时满足大于关系和小于关系 *)
Lemma ord_not_lt_gt : ∀ α β ⋵ 𝐎𝐍, α ∈ β → β ∈ α → False.
Proof.
  intros α Hα β Hβ Hαβ Hβα. eapply ord_irrefl. apply Hα.
  eapply ord_trans; eauto.
Qed.

(* 两个序数不能同时满足等于关系和小于关系 *)
Lemma ord_not_lt_self : ∀ α β ⋵ 𝐎𝐍, α = β → α ∈ β → False.
Proof.
  intros α Hα β Hβ Heq Hαβ. subst. eapply ord_irrefl; eauto.
Qed.

(* 两个序数不能同时满足小于等于关系和大于关系 *)
Lemma ord_not_le_gt : ∀ α β ⋵ 𝐎𝐍, α ⋸ β → β ∈ α → False.
Proof with eauto.
  intros α Hα β Hβ Hle Hgt. destruct Hle.
  - eapply ord_not_lt_gt; revgoals...
  - eapply ord_not_lt_self; revgoals...
Qed.

(* 序数的小于等于关系与小于后继的转化 *)
Lemma ord_le_iff_lt_suc : ∀ α β ⋵ 𝐎𝐍, α ⋸ β ↔ α ∈ β⁺.
Proof with nauto.
  intros α Hα β Hβ. split.
  - intros []. apply BUnionI1... subst...
  - intros H. apply BUnionE in H as []. left...
    right. apply SingE in H...
Qed.

(* 序数后继保序 *)
Lemma ord_suc_preserve_lt : ∀ α β ⋵ 𝐎𝐍, α ∈ β ↔ α⁺ ∈ β⁺.
Proof with eauto.
  intros α Hα β Hβ. split; intros H.
  - destruct (classic (α⁺ = β)) as [|Hnq]. {
      apply BUnionI2. subst...
    }
    apply BUnionI1.
    apply ord_connected in Hnq as [|Hβα]... exfalso.
    apply BUnionE in Hβα as [Hβα|Heq].
    + eapply ord_not_lt_gt;revgoals...
    + apply SingE in Heq. eapply ord_not_lt_self; revgoals...
  - apply ord_le_iff_lt_suc in H as []...
    + eapply ord_trans; revgoals...
    + rewrite <- H...
Qed.

(* 序数后继是单射 *)
Lemma ord_suc_injective : ∀ α β ⋵ 𝐎𝐍, α⁺ = β⁺ → α = β.
Proof with auto.
  intros α Hα β Hβ Heq.
  assert (⋃α⁺ = ⋃β⁺) by congruence.
  apply ord_trans in Hα. apply ord_trans in Hβ.
  apply trans_union_suc in Hα.
  apply trans_union_suc in Hβ. congruence.
Qed.

Corollary ord_suc_preserve_le : ∀ α β ⋵ 𝐎𝐍, α ⋸ β ↔ α⁺ ⋸ β⁺.
Proof with auto.
  intros α Hα β Hβ. split; intros H.
  - destruct H. left. rewrite <- ord_suc_preserve_lt...
    right. congruence.
  - destruct H. left. rewrite ord_suc_preserve_lt...
    right. apply ord_suc_injective...
Qed.

(* 任意序数不等于其后继 *)
Lemma ord_neq_suc : ∀α ⋵ 𝐎𝐍, α ≠ α⁺.
Proof.
  intros α Hα. pose proof (suc_has_n α). intros Heq.
  rewrite <- Heq in H at 1. apply (ord_irrefl α); auto.
Qed.

(* 不等于零的序数大于零 *)
Lemma ord_neq_0_gt_0 : ∀α ⋵ 𝐎𝐍, α ≠ ∅ → ∅ ∈ α.
Proof.
  intros α Hα H.
  apply ord_connected in H as []; auto. exfalso0.
Qed.
Global Hint Immediate ord_neq_0_gt_0 :core.

(* 后继序数大于零 *)
Corollary ord_suc_gt_0 : ∀α ⋵ 𝐎𝐍, ∅ ∈ α⁺.
Proof. intros α Hα. apply ord_neq_0_gt_0; auto. Qed.
Global Hint Immediate ord_suc_gt_0 :core.

(* 大于零的序数不等于零 *)
Lemma ord_gt_0_neq_0 : ∀α ⋵ 𝐎𝐍, ∅ ∈ α → α ≠ ∅.
Proof.
  intros α Hα H.
  destruct (classic (α = ∅)); auto. subst. exfalso0.
Qed.
Global Hint Immediate ord_gt_0_neq_0 :core.

(* 后继序数不等于零 *)
Fact ord_suc_neq_0 : ∀α ⋵ 𝐎𝐍, α⁺ ≠ ∅.
Proof. auto. Qed.

(* 任意序数大于等于零 *)
Lemma ord_ge_0 : ∀α ⋵ 𝐎𝐍, ∅ ⋸ α.
Proof with auto.
  intros α Hα. apply ord_le_iff_sub; auto.
  apply empty_sub_all.
Qed.
Global Hint Resolve ord_ge_0 : core.

(* 序数的小于关系与真子集关系等价 *)
Lemma ord_lt_iff_psub : ∀ α β ⋵ 𝐎𝐍, α ∈ β ↔ α ⊂ β.
Proof with eauto.
  intros α Hα β Hβ. split.
  - intros Hlt. split. apply ord_le_iff_sub...
    intros Heq. subst. eapply ord_irrefl...
  - intros [Hsub Hnq].
    apply ord_connected in Hnq as []...
    apply Hsub in H. exfalso. eapply ord_irrefl...
Qed.

Lemma ord_lt_iff_not_sub : ∀ α β ⋵ 𝐎𝐍, α ∈ β ↔ β ⊈ α.
Proof with auto.
  intros α Hα β Hβ. split; intros H.
  - intros Hsub. apply Hsub in H. apply (ord_irrefl α)...
  - destruct (classic (α = β)) as [Heq|Hnq].
    + exfalso. apply H. subst...
    + apply ord_connected in Hnq as [|Hlt]... exfalso.
      apply H. apply ord_lt_iff_psub...
Qed.

Lemma ord_lt_suc_iff_sub : ∀ α β ⋵ 𝐎𝐍, α ⊆ β ↔ α ∈ β⁺.
Proof.
  intros α Hα β Hβ. rewrite <- (ord_le_iff_lt_suc α Hα β Hβ).
  symmetry. exact (ord_le_iff_sub α Hα β Hβ).
Qed.

Lemma ord_le_iff_not_gt : ∀ α β ⋵ 𝐎𝐍, α ⋸ β ↔ β ∉ α.
Proof with eauto.
  intros α Hα β Hβ.
  rewrite (ord_le_iff_sub α Hα β Hβ).
  split; intros H.
  - intros Hlt. apply ord_lt_iff_not_sub in Hlt...
  - destruct (classic (α ⊆ β))...
    exfalso. apply H. apply ord_lt_iff_not_sub...
Qed.

(* 不等于零和一的序数大于一 *)
Lemma ord_neq_0_1_gt_1 : ∀ α ⋵ 𝐎𝐍, α ≠ 0 → α ≠ 1 → 1 ∈ α.
Proof with nauto.
  intros α Hα H0 H1. contra.
  apply ord_le_iff_not_gt in H as []...
  rewrite one in H. apply SingE in H...
Qed.
Global Hint Resolve ord_neq_0_1_gt_1 :core.

(* 大于一的序数不等于零和一 *)
Lemma ord_gt_1_neq_0_1 : ∀ α ⋵ 𝐎𝐍, 1 ∈ α → α ≠ 0 ∧ α ≠ 1.
Proof.
  intros α Hα Hlt. split; intros H; subst.
  exfalso0. eapply (ord_irrefl 1); auto.
Qed.

(* 序数不稠密 *)
Lemma ord_not_dense : ∀α ⋵ 𝐎𝐍, ¬ ∃β ⋵ 𝐎𝐍, α ∈ β ∧ β ∈ α⁺.
Proof with eauto.
  intros α Hα [β [Hβ [Hαβ Hβα]]].
  apply BUnionE in Hβα as [Hlt|Heq].
  - eapply ord_not_lt_gt; revgoals...
  - apply SingE in Heq. eapply ord_not_lt_self; revgoals...
Qed.

(* 序数集最小元的两种定义等价 *)
Lemma ord_ε_minimum_iff_sub_minimum : ∀ α A, A ⪽ 𝐎𝐍 →
  ε_minimum α A ↔ sub_minimum α A.
Proof with auto.
  split; intros [Hm Hmin]; split; auto; intros β Hβ;
  apply Hmin in Hβ as Hle; (apply ord_le_iff_sub; [apply H..|])...
Qed.

(* 序数集最大元的两种定义等价 *)
Lemma ord_ε_maximum_iff_sub_maximum : ∀ α A, A ⪽ 𝐎𝐍 →
  ε_maximum α A ↔ sub_maximum α A.
Proof with auto.
  split; intros [Hm Hmax]; split; auto; intros β Hβ;
  apply Hmax in Hβ as Hle; (apply ord_le_iff_sub; [apply H..|])...
Qed.

(* 序数集的阿基米德性 *)
Definition ord_archimedean := λ A, ∀a ∈ A, ∃b ∈ A, a ∈ b.

(* 具有阿基米德性的序数集没有最大元 *)
Lemma ord_archimedean_impl_no_maximum : ∀ A, A ⪽ 𝐎𝐍 →
  ord_archimedean A → ¬∃μ, sub_maximum μ A.
Proof with auto.
  intros A Hord Hnmax [μ [Hμ Hmax]].
  pose proof (Hnmax μ Hμ) as [β [Hβ Hβμ]]. apply Hmax in Hβ.
  apply Hβ in Hβμ. apply (ord_irrefl μ)...
Qed.

(* 没有最大元的非空序数集具有阿基米德性 *)
Lemma ord_archimedean_if_no_maximum : ∀ A, ⦿ A → A ⪽ 𝐎𝐍 →
  (¬∃μ, sub_maximum μ A) → ord_archimedean A.
Proof with eauto.
  intros A [γ Hγ] Hord Hnmax α Hα.
  eapply not_ex_all_not in Hnmax.
  apply not_and_or in Hnmax as []. exfalso...
  apply set_not_all_ex_not in H as [μ [Hμ Hαμ]].
  apply ord_lt_iff_not_sub in Hαμ; [|apply Hord..]...
Qed.

(* 非空序数集具有阿基米德性当且仅当它没有最大元 *)
Theorem ord_archimedean_iff_no_maximum : ∀ A, ⦿ A → A ⪽ 𝐎𝐍 →
  ord_archimedean A ↔ ¬∃μ, sub_maximum μ A.
Proof with auto.
  intros A Hne Hord. split; intros H.
  - apply ord_archimedean_impl_no_maximum...
  - apply ord_archimedean_if_no_maximum...
Qed.

(* 后继序数 *)
Definition sucord := λ α, ∃β ⋵ 𝐎𝐍, α = β⁺.
Notation 𝐎𝐍ˢᵘᶜ := sucord.

(* 极限序数 *)
Definition limord := λ α, α ⋵ 𝐎𝐍 ∧ α = sup α.
Notation 𝐎𝐍ˡⁱᵐ := limord.

Lemma limord_is_ord : 𝐎𝐍ˡⁱᵐ ⫃ 𝐎𝐍.
Proof. intros 𝜆 []; auto. Qed.
Global Hint Resolve limord_is_ord : core.

(* 后继序数的上确界是其前驱 *)
Lemma sup_of_sucord : ∀α ⋵ 𝐎𝐍, sup α⁺ = α.
Proof.
  intros α Hα. apply ord_trans in Hα.
  apply trans_union_suc in Hα.
  unfold sup. rewrite Hα. reflexivity.
Qed.

Lemma limord_ge_ω : ∀𝜆 ⋵ 𝐎𝐍ˡⁱᵐ, 𝜆 ≠ 0 → ω ⋸ 𝜆.
Proof with auto.
  intros n [Hn Hsup] Hne. apply ord_le_iff_not_gt...
  intros H. ω_destruct n...
  rewrite sup_of_sucord in Hsup...
  apply (nat_irrefl n)... rewrite <- Hsup at 2...
Qed.

(* 后继序数大于自身的上确界 *)
Lemma sucord_contains_sup : ∀α ⋵ 𝐎𝐍ˢᵘᶜ, sup α ∈ α.
Proof.
  intros α [β [Hβ Heqα]]. subst α.
  rewrite sup_of_sucord. apply suc_has_n. apply Hβ.
Qed.

(* 后继序数的上确界是其最大元 *)
Lemma maximum_of_sucord : ∀α ⋵ 𝐎𝐍ˢᵘᶜ, ε_maximum (sup α) α.
Proof with auto.
  intros. split. apply sucord_contains_sup...
  intros β Hβ. apply ord_sup_correct...
  destruct H as [γ [Hγ Heq]]. rewrite Heq.
  apply ord_is_ords...
Qed.

(* 极限序数不大于自身的上确界 *)
Lemma limord_not_contains_sup : ∀α ⋵ 𝐎𝐍ˡⁱᵐ, sup α ∉ α.
Proof with auto.
  intros α [Hα Heq] H. rewrite Heq in H at 2.
  apply (ord_irrefl (sup α))...
  apply union_of_ords_is_ord. apply ord_is_ords...
Qed.

(* 零是极限序数（也可以单独把零分为一类） *)
Lemma empty_is_limord : ∅ ⋵ 𝐎𝐍ˡⁱᵐ.
Proof.
  split. apply empty_is_ord.
  unfold sup. rewrite union_empty. reflexivity.
Qed.

(* ω是极限序数 *)
Lemma ω_is_limord : ω ⋵ 𝐎𝐍ˡⁱᵐ.
Proof with auto.
  split... ext Hx.
  - apply UnionAx. exists x⁺. split... apply ω_inductive...
  - apply trans_union_sub... apply ω_trans.
Qed.
Global Hint Resolve ω_is_limord : core.

(* 极限序数具有阿基米德性 *)
Lemma limord_archimedean : ∀α ⋵ 𝐎𝐍ˡⁱᵐ, ord_archimedean α.
Proof.
  intros α [Hα Heq] β Hβ. rewrite Heq in Hβ.
  apply UnionAx in Hβ. apply Hβ.
Qed.

(* 极限序数无最大元 *)
Lemma limord_no_maximum : ∀α ⋵ 𝐎𝐍ˡⁱᵐ, ¬ ∃ μ, sub_maximum μ α.
Proof.
  intros α H. apply ord_archimedean_impl_no_maximum.
  apply ord_is_ords. apply H. apply limord_archimedean. apply H.
Qed.

(* 极限序数有任意成员的后继 *)
Lemma sucord_in_limord : ∀α ⋵ 𝐎𝐍ˡⁱᵐ, ∀β ∈ α, β⁺ ∈ α.
Proof with eauto.
  intros α Hlim β Hβ.
  contra.
  eapply limord_no_maximum...
  exists β. split... intros γ Hγ.
  assert (Hoα: α ⋵ 𝐎𝐍). apply Hlim.
  assert (Hoβ: β ⋵ 𝐎𝐍). eapply ord_is_ords...
  assert (Hoγ: γ ⋵ 𝐎𝐍). eapply ord_is_ords; revgoals...
  apply ord_lt_suc_iff_sub...
  apply ord_le_iff_not_gt in H...
  apply ord_le_iff_sub in H...
Qed.

(* 序数是极限序数当且仅当它不是后继序数 *)
Lemma limord_iff_not_sucord : ∀α ⋵ 𝐎𝐍, α ⋵ 𝐎𝐍ˡⁱᵐ ↔ ¬ α ⋵ 𝐎𝐍ˢᵘᶜ.
Proof with eauto.
  intros α H. split.
  - intros [Hα H1] [β [Hβ H2]]. rewrite H2 in H1 at 2.
    rewrite sup_of_sucord in H1... rewrite H1 in H2.
    eapply ord_neq_suc...
  - intros Hnsuc. destruct (classic (α ⋵ 𝐎𝐍ˡⁱᵐ)) as [|Hnlim]...
    exfalso. apply Hnsuc. clear Hnsuc.
    apply not_and_or in Hnlim as [|Hneq]. exfalso...
    assert (Hne: sup α ⊂ α). {
      split... apply union_is_sup.
      intros β Hβα. apply ord_le_iff_sub...
      eapply ord_is_ords in H...
    }
    apply comp_nonempty in Hne as [β Hβ].
    apply SepE in Hβ as [Hβ Hβ'].
    assert (Hordβ: β ⋵ 𝐎𝐍). eapply ord_is_ords in H...
    exists β. split...
    destruct (classic (α = β⁺)) as [|Hnq]...
    exfalso. apply ord_connected in Hnq as [H1|H2]...
    + apply (ord_not_dense β)...
    + apply Hβ'. apply UnionAx. exists (β⁺). split...
Qed.

(* 序数是后继序数当且仅当它不是极限序数 *)
Corollary sucord_iff_not_limord : ∀α ⋵ 𝐎𝐍, α ⋵ 𝐎𝐍ˢᵘᶜ ↔ ¬ α ⋵ 𝐎𝐍ˡⁱᵐ.
Proof.
  intros α H. pose proof (limord_iff_not_sucord α H).
  unfold InClass in *. tauto.
Qed.

(* 序数要么是后继序数要么是极限序数 *)
Theorem sucord_or_limord : ∀α ⋵ 𝐎𝐍, α ⋵ 𝐎𝐍ˢᵘᶜ ∨ α ⋵ 𝐎𝐍ˡⁱᵐ.
Proof with auto.
  intros α H. destruct (classic (α ⋵ 𝐎𝐍ˢᵘᶜ))...
  right. apply limord_iff_not_sucord...
Qed.

Ltac ord_destruct α := match goal with | H : α ⋵ 𝐎𝐍 |- _ =>
  let H0 := fresh "H0" in
  destruct (classic (α = 0)) as [H0|H0]; [|
    destruct (sucord_or_limord α H) as [?Hsuc|?Hlim]; [clear H0|]
  ]
end.

(* 序数是后继序数当且仅当它大于自身的上确界 *)
Corollary sucord_iff_contains_sup : ∀α ⋵ 𝐎𝐍, α ⋵ 𝐎𝐍ˢᵘᶜ ↔ sup α ∈ α.
Proof with auto.
  intros α Hoα. split; intros H.
  - apply sucord_contains_sup...
  - destruct (sucord_or_limord α)... exfalso.
    apply limord_not_contains_sup in H0...
Qed.

(* 序数是极限序数当且仅当它不大于自身的上确界 *)
Corollary limord_iff_not_contains_sup : ∀α ⋵ 𝐎𝐍, α ⋵ 𝐎𝐍ˡⁱᵐ ↔ sup α ∉ α.
Proof with auto.
  intros α Hoα. split; intros H.
  - apply limord_not_contains_sup...
  - destruct (sucord_or_limord α)... exfalso.
    apply H. apply sucord_contains_sup...
Qed.

(* ex7_25 序数上的超限归纳模式 *)
Theorem transfinite_induction_schema_on_ordinals : ∀ ϕ : set → Prop,
  (∀α ⋵ 𝐎𝐍, ((∀β ∈ α, ϕ β) → ϕ α)) → ∀α ⋵ 𝐎𝐍, ϕ α.
Proof with eauto.
  intros * Hind α Hoα.
  assert (Hstar: ∀ ξ ⋵ 𝐎𝐍, ¬ ϕ ξ → ∃γ ∈ ξ, ¬ ϕ γ). {
    intros ξ Hpξ Hnξ.
    contra.
    apply Hnξ. apply Hind... intros γ Hγ.
    contra.
    apply H. exists γ. split...
  }
  contra as Hnα.
  set {ξ ∊ α | ¬ ϕ ξ} as α'.
  destruct (ord_woset α) as [_ Hmα]...
  pose proof (Hmα α') as [μ [Hμ Hmin]]. {
    destruct (Hstar α) as [γ [Hγ Hnγ]]...
    exists γ. apply SepI...
  } {
    intros ξ Hξ. apply SepE1 in Hξ...
  }
  apply SepE in Hμ as [Hμ Hnμ].
  assert (Hoμ: μ ⋵ 𝐎𝐍). eapply ord_is_ords...
  set {ξ ∊ μ | ¬ ϕ ξ} as μ'.
  destruct (ord_woset μ) as [_ Hmμ]...
  pose proof (Hmμ μ') as [ν [Hν _]]. {
    destruct (Hstar μ) as [γ [Hγ Hnγ]]...
    exists γ. apply SepI...
  } {
    intros ξ Hξ. apply SepE1 in Hξ...
  }
  apply SepE in Hν as [Hν Hnν].
  assert (Hoν: ν ⋵ 𝐎𝐍). eapply ord_is_ords...
  assert (Hν': ν ∈ α'). apply SepI... eapply ord_trans...
  apply Hmin in Hν' as [].
  - apply binRelE3 in H. eapply ord_not_lt_gt; revgoals...
  - eapply ord_not_lt_self; revgoals...
Qed.

Ltac ord_induction := match goal with
  |- ∀ α ⋵ 𝐎𝐍, @?ϕ α =>
    apply (transfinite_induction_schema_on_ordinals ϕ)
  end.


(** This file defines retractions and basic properties on them. *)

Require Coq.Program.Program.
Require Coq.NArith.NArith.
Require Coq.Lists.List.

(** [Retract A B] is the type of retractions from [B] to [A]. *)
Record Retract A B := {
  inj  : B -> A;
  proj : A -> B;
  retract : forall x, proj (inj x) = x
}.
Arguments inj  {A B} _ _.
Arguments proj {A B} _ _.

Obligation Tactic := try solve [intuition eauto|intros **;cbn;now rewrite !retract].

(** * Categorical combinators *)

Program Definition id {A} : Retract A A := {|
  inj  x := x;
  proj x := x
|}.

Program Definition compose {A B C}
    (f:Retract A B) (g:Retract B C) : Retract A C := {|
  inj  x := f.(inj)  (g.(inj)  x);
  proj x := g.(proj) (f.(proj) x)
|}.

Program Definition opt_compose {A B C}
     (f:Retract A (option B)) (g:Retract B (option C))
     : Retract A (option C) := {|
  inj  x := f.(inj)  (Some (g.(inj) x));
  proj x := match f.(proj) x return _ with
            | Some y => g.(proj) y
            | None   => None
            end
|}.

Program Definition opt_lift {A B}
     (f:Retract A B) : Retract (option A) (option B) := {|
  inj  x := match x return _ with
            | Some x => Some (f.(inj) x)
            | None   => None
            end;
  proj x := match x return _ with
            | Some x => Some (f.(proj) x)
            | None   => None
            end
|}.
Next Obligation.
  intros A B f [x|].
  all: now rewrite ?retract.
Qed.

(** * Retracts of the natural numbers *)

(** Retracts of the natural numbers are of special importance as they
    are used to define countable types. *)

(** A retraction from [A] into [nat] lifts to a retraction of [A+1]
    into [nat]. *)
Program Definition retract_nat_opt {A}
     (f:Retract nat A) : Retract nat (option A) := {|
  inj  x := match x return _ with
            | Some a => S(f.(inj) a)
            | None   => 0
            end;
  proj x := match x return _ with
            | S n => Some (f.(proj) n)
            | 0 => None
            end
|}.
Next Obligation.
  intros A f [a|].
  + now rewrite !retract.
  + reflexivity.
Qed.

(** A retraction from [A+1] into [nat] restricts to a retraction from
    [A] to [nat] when [A] is inhabited. *)
Program Definition retract_nat_inh {A}
     (f:Retract nat (option A)) (a:A) : Retract nat A := {|
  inj  x := f.(inj) (Some x) ;
  proj x := match f.(proj) x return _ with
            | Some x' => x'
            | None    => a
            end
|}.

(** * Standard retractions *)

Import NArith.

Definition retract_nat_N : Retract nat N := {|
  inj  := N.to_nat ;
  proj := N.of_nat ;
  retract := N2Nat.id
|}.

(** In this module we establish that [list nat] is a retract of
    [N]. We use, to that effect the following Gӧdel numbering:
    encoding [[n₁;...;nₖ]] as [[0...n₁...01...10...nₖ...01]] (least
    significant bit to the left).

    Examples:
    - [[]] is encoded as [0].
    - [[0]] is encoded as [1].
    - [[2]] is encoded as [001] (4).
    - [[3;2]] is encoded as [0001001] (72). *)

Module RetractNListNat.

 Import NArith List List.ListNotations.

 Local Open Scope positive.
 Local Open Scope N.

 (** [encode_nat n p] is [p] preceeded by [n] [0]-s. *)
 Fixpoint encode_nat (n:nat) (p:N) : N :=
   match n with
   | 0%nat => p
   | S n => N.double (encode_nat n p)
   end
 .

 Definition encode : list nat -> N :=
   List.fold_right (fun n p => encode_nat n (N.succ_double p)) 0.

 (** Positive integers decode to non-empty lists. *)
 Fixpoint decode_positive (p:positive) : nat * list nat :=
   match p with
   | 1%positive => (0%nat,[])
   | p~0 => let (n,l) := decode_positive p in (S n, l)
   | p~1 => let (n,l) := decode_positive p in (0%nat,n::l)
   end
 .

 Definition decode (n:N) : list nat :=
   match n with
   | 0 => []
   | Npos p => let (n,l) := decode_positive p in n::l
 end.

 Lemma retract : forall l, decode (encode l) = l.
 Proof.
   assert (forall n, decode (N.succ_double n) = 0%nat::(decode n)) as decode_succ_double.
   { intros [ | p ].
     + reflexivity.
     + cbn.
       now destruct (decode_positive p). }
   intros l.
   induction l as [ | n l hl ].
   + reflexivity.
   + cbn.
     induction n as [ | n hn ].
     * cbn. rewrite decode_succ_double.
       now rewrite hl.
     * cbn.
       unfold decode in hn |- *.
       destruct (encode_nat n (N.succ_double (encode l))); cbn.
       - easy.
       - destruct (decode_positive p).
         congruence.
 Qed.

End RetractNListNat.

Definition retract_N_list_nat : Retract N (list nat) := {|
  inj  := RetractNListNat.encode ;
  proj := RetractNListNat.decode ;
  retract := RetractNListNat.retract
|}.