(** The sum of two ordinal  notations *)

(** Pierre Castéran, Univ. Bordeaux and LaBRI *)

From Coq Require Import Arith Compare_dec Lia
     Relation_Operators RelationClasses Disjoint_Union.
From hydras Require Import  ON_Generic MoreOrders.

Import Relations.
Generalizable All Variables.
Coercion is_true: bool >-> Sortclass.

(* begin snippet Defs *)
Section Defs.

  Context `(ltA: relation A)
          (cmpA : Compare A)
          (NA: ON ltA cmpA).
  Context `(ltB: relation B)
          (cmpB : Compare B)
          (NB: ON ltB cmpB).

  Definition t := (A + B)%type.
  Arguments inl  {A B} _.
  Arguments inr  {A B} _.

  Definition lt : relation t := le_AsB _ _ ltA ltB.
(* end snippet Defs *)

(* begin snippet compareDef *)
#[global] Instance compare_t : Compare t :=
fun (alpha beta: t) =>
   match alpha, beta with
     inl _, inr _ => Lt
   | inl a, inl a' => compare a a'
   | inr b, inr b' => compare b b'
   | inr _, inl _ => Gt
  end.
(* end snippet compareDef *)

Definition le := clos_refl _ lt.

#[local] Hint Unfold lt le : core.
#[local] Hint Constructors le_AsB: core.

Instance lt_strorder : StrictOrder lt.
Proof.
  split.
  -  intros x  H. inversion H. subst.
     destruct (StrictOrder_Irreflexive _ H2).
     subst.
     destruct (StrictOrder_Irreflexive _ H2).
  - intros x y z H H0.  inversion H; inversion H0; subst; try discriminate.
    + injection H5;constructor.  subst.
      now transitivity y0.
    + constructor.
    + constructor.
    + constructor.
      injection H5; intro; subst.  now transitivity y0.
Qed.

Lemma compare_reflect alpha beta :
  match (compare alpha beta)
  with
    Lt => lt alpha  beta
  | Eq => alpha = beta
  | Gt => lt beta  alpha
  end.
  destruct alpha, beta; cbn; auto.
  destruct (comparable_comp_spec a a0); (now subst || constructor; auto).
   - destruct (comparable_comp_spec b b0); (now subst || constructor; auto).
Qed.

(* begin snippet compareCorrect:: no-out  *)

Lemma compare_correct alpha beta :
    CompSpec eq lt alpha beta (compare alpha beta). (* .no-out *)
(* ... *)
(* end snippet compareCorrect *)
Proof.
  generalize (compare_reflect alpha beta).
  destruct (compare alpha beta); now constructor.
Qed.

(* begin snippet plusComp:: no-out *)

#[global] Instance plus_comp : Comparable lt compare_t.
Proof.  split; [apply lt_strorder | apply compare_correct]. Qed.
(* end snippet plusComp *)

(* begin snippet ltWf *)

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

Lemma lt_wf : well_founded lt.
Proof.
  destruct NA, NB; apply wf_disjoint_sum; [apply ON_wf | apply ON_wf0].
Qed.

(*||*)

(* end snippet ltWf *)

(* begin snippet OnPlus *)

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

#[global] Instance ON_plus : ON lt compare_t.
Proof. split; [apply plus_comp | apply lt_wf]. Qed.

(*||*)

(* end snippet OnPlus *)

Lemma lt_eq_lt_dec alpha beta :
  {lt alpha  beta} + {alpha = beta} + {lt beta  alpha}.
Proof.
  generalize (compare_reflect  alpha beta).
  destruct (compare alpha beta).
  - left;right; auto.
  - left;left; auto.
  - right;  auto.
Defined.

End Defs.

Arguments lt_eq_lt_dec {A ltA cmpA} _ {B ltB  cmpB} _.
Arguments ON_plus {A ltA cmpA} _ {B ltB cmpB}.


Require Import FSets.
Require Import ProofIrrelevance.

(* For the equality on sets to be the one of Coq, we need:
    - an order on elements, and not just a decidable equality
       (hence an OrdereredType leading to some FSets instead of
        a DecidableType leading to some FSetWeak).
    - the equality on elements must be the one of Coq
       (hence a UsualOrderedType instead of just a OrderedType)
    - an implementation of sets with canonical representation,
       for instance FSetList based on sorted lists.
    - the proof irrelevance axiom, since an implementation such
       as FSetList isn't really canonical: a set comes with
       a well-sortedness certificate.
*)

Module UsualEqual (U:UsualOrderedType).

  Module Import M := FSetList.Make U.
  Module Import P := FSetProperties.Properties M.
  Module Import P' := FSetProperties.OrdProperties M.

  (* True in any FSet: *)

  Lemma Equal_elements_eqlistA : forall s s' : t, Equal s s' ->
   eqlistA U.eq (elements s) (elements s').
  Proof.
  intros; apply sort_equivlistA_eqlistA; auto; apply elements_3.
  Qed.

  (* Since U.eq is Coq eq, then eqlistA is also Coq eq *)

  Lemma eqlistA_eq : forall (l l' : list U.t),
   eqlistA U.eq l l' -> l=l'.
  Proof.
  induction 1; auto; f_equal; auto.
  Qed.

  (* Finally, for FSetList, elements is the identity.
     Or more precisely, the removal of a proof of well-sortedness.
     So we need proof irrelevance. *)

  Lemma Equal_eq : forall s s' : t, Equal s s' -> s = s'.
  Proof.
   intros; generalize (eqlistA_eq _ _ (Equal_elements_eqlistA _ _ H)); clear H.
   destruct s as [s Hs]; destruct s' as [s' Hs']; simpl.
   intros.
   rewrite proof_irrelevance with (p1:=Hs') (p2:=eq_rect s _ Hs s' H).
   elim H using eq_indd.
   reflexivity.
  Qed.

End UsualEqual.


Require Export XR_R.
Require Export XR_R0.
Require Export XR_Rsqr.
Require Export XR_Rmult_integral.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rsqr_0_uniq : forall r, Rsqr r = R0 -> r = R0.
Proof.
  intros x h.
  unfold Rsqr in h.
  assert (mi := Rmult_integral).
  specialize (mi x x).
  specialize (mi h).
  destruct mi as [ mi | mi ].
  { exact mi. }
  { exact mi. }
Qed.


Require Import Setoid.
Require Import Morphisms.
Require Import Coq.Program.Basics.
Require Import NArith.
Require Import List.
Import ListNotations.
Open Scope list.
Require Import Lia.

Unset Printing Records.

From Ordinal Require Import Defs.
From Ordinal Require Import Operators.
From Ordinal Require Import Arith.
From Ordinal Require Import Cantor.
From Ordinal Require Import Fixpoints.
From Ordinal Require Import Reflection.
From Ordinal Require Import VeblenDefs.
From Ordinal Require Import VeblenCon.
From Ordinal Require Import VeblenFacts.
From Ordinal Require Import VTowerFin.
From Ordinal Require Import VTower.

Open Scope ord_scope.

Fixpoint bhtower (n:nat) : (Ord -> Ord) -> Ord -> Ord -> Ord :=
  match n with
  | O => fun f b y => f y
  | S m =>
    let nextCritical (f:Ord -> Ord) (y x:Ord) :=
         supOrd (fun z:y => fixOrd (bhtower m f z) x)
    in
    fun f =>
    fix vtower (b:Ord) : Ord -> Ord :=
      fix inner (y:Ord) : Ord :=
      match b, y with
      | ord B g, ord Y h =>
        f (ord Y h) ⊔
          supOrd (fun a:B => nextCritical (vtower (g a)) (1 + ord Y h)
                                 (limOrd (fun x:Y => inner (h x))))
      end
  end.

Definition nextCritical n (f:Ord -> Ord) (y x:Ord) :=
  supOrd (fun z:y => fixOrd (bhtower n f z) x).

Lemma bhtower_unroll : forall n f (b y:Ord),
    bhtower (S n) f b y =
    f y ⊔ supOrd (fun a:b => nextCritical n (bhtower (S n) f a) (1+y)
                               (limOrd (fun x:y => bhtower (S n) f b x))).
Proof.
  intros.
  destruct b as [B g].
  destruct y as [Y h].
  reflexivity.
Qed.

Lemma bhtower_index_zero : forall f b y,
    bhtower 0 f b y = f y.
Proof.
  reflexivity.
Qed.

Global Opaque bhtower.

Theorem bhtower_monotone : forall n f g a b x y,
    (forall x y, x <= y -> g x <= g y) ->
    (forall x, f x <= g x) ->
    a <= b ->
    x <= y ->
    bhtower n f a x <= bhtower n g b y.
Proof.
  induction n.
  { intros. rewrite bhtower_index_zero.
    rewrite (bhtower_index_zero g b y).
    transitivity (g x); auto. }

  intros f g a b x y Hg Hfg. revert y f g a x Hg Hfg.
  induction b as [b Hb] using ordinal_induction.
  induction y as [y Hy] using ordinal_induction.
  intros.

  rewrite (bhtower_unroll n f a x).
  rewrite (bhtower_unroll n g b y).
  apply lub_least.
  { rewrite <- lub_le1. transitivity (g x); auto. }
  apply sup_least. intro ia.
  rewrite <- lub_le2.
  destruct (ord_le_subord a b H ia) as [ib ?].
  rewrite <- (sup_le _ _ ib).
  unfold nextCritical.

  apply sup_least; intro ix.
  assert (1 + x <= 1 + y).
  { apply addOrd_monotone; auto with ord; auto. }
  destruct (ord_le_subord (1+x) (1+y) H2 ix) as [iy ?].
  rewrite <- (sup_le _ _ iy).
  unfold fixOrd. apply sup_ord_le_morphism.
  intro m.
  induction m; simpl.
  - rewrite ord_le_unfold; simpl; intro q.
    destruct (ord_le_subord x y H0 q) as [q' ?].
    rewrite ord_lt_unfold. simpl. exists q'.
    apply Hy; auto with ord.
  - apply IHn; auto with ord.
Qed.

(* TODO? is it possible to prove these together instead?
   It seems tricky to make it work out, even though the proofs
   are nearly identical.
 *)
Theorem bhtower_monotone_strong : forall m n f g a b x y,
    (forall x y, x <= y -> g x <= g y) ->
    (forall x, f x <= g x) ->
    (m <= n)%nat ->
    a <= b ->
    x <= y ->
    bhtower m f a x <= bhtower n g b y.
Proof.
  induction m.
  { intros. rewrite bhtower_index_zero.
    destruct n. rewrite bhtower_index_zero; auto with ord.
    transitivity (g x); auto.
    rewrite bhtower_unroll.
    rewrite <- lub_le1.
    transitivity (g x); auto. }

  intros n f g a b x y Hg Hfg. revert y f g a x Hg Hfg.
  induction b as [b Hb] using ordinal_induction.
  induction y as [y Hy] using ordinal_induction.
  intros.

  destruct n; [ lia | ].
  rewrite (bhtower_unroll m f a x).
  rewrite (bhtower_unroll n g b y).
  apply lub_least.
  { rewrite <- lub_le1. transitivity (g x); auto. }
  apply sup_least. intro ia.
  rewrite <- lub_le2.
  destruct (ord_le_subord a b H0 ia) as [ib ?].
  rewrite <- (sup_le _ _ ib).
  unfold nextCritical.

  apply sup_least; intro ix.
  assert (1 + x <= 1 + y).
  { apply addOrd_monotone; auto with ord; auto. }
  destruct (ord_le_subord (1+x) (1+y) H3 ix) as [iy ?].
  rewrite <- (sup_le _ _ iy).
  etransitivity; [ eapply fixOrd_monotone_func | eapply fixOrd_monotone ].
  + intros. apply IHm; auto with arith ord.
    intros. apply bhtower_monotone; auto with ord.
  + intros. apply bhtower_monotone; auto with ord.
    intros. apply bhtower_monotone; auto with ord.
  + intros. apply bhtower_monotone; auto with ord.
    intros. apply bhtower_monotone; auto with ord.
  + rewrite ord_le_unfold; simpl; intro q.
    destruct (ord_le_subord x y H1 q) as [q' ?].
    rewrite ord_lt_unfold. simpl. exists q'.
    apply Hy; auto with ord.
Qed.

Lemma nextCritical_monotone n f g y' y x' x :
  (forall x, f x <= g x) ->
  (forall x y, x <= y -> g x <= g y) ->
  y' <= y ->
  x' <= x ->
  nextCritical n f y' x' <= nextCritical n g y x.
Proof.
  intros. unfold nextCritical.
  apply sup_least; intros.
  destruct (ord_le_subord y' y H1 a) as [a' ?].
  rewrite <- (sup_le _ _ a').
  transitivity (fixOrd (bhtower n g (sz a')) x').
  apply fixOrd_monotone_func; auto.
  intros; apply bhtower_monotone; auto with ord.
  intros; apply bhtower_monotone; auto with ord.
  apply fixOrd_monotone; auto.
  intros; apply bhtower_monotone; auto with ord.
Qed.

Local Hint Resolve bhtower_monotone nextCritical_monotone : core.
Local Hint Resolve
      zero_complete
      succ_complete
      addOrd_complete
      complete_subord
      normal_monotone
      normal_complete
  : core.

Lemma bhtower_first_cont_zero f :
  scott_continuous (fun q => bhtower 0 f q 0).
Proof.
  hnf; intros.
  rewrite bhtower_index_zero.
  rewrite <- (sup_le _ _ a0).
  rewrite bhtower_index_zero.
  reflexivity.
Qed.

Lemma bhtower_index_one : forall f b y,
    normal_function f ->
    bhtower 1 f b y ≈ veblen f b y.
Proof.
  intros f b y Hf.
  revert y.
  induction b as [B g Hb].
  induction y as [Y h Hy].
  rewrite bhtower_unroll.
  rewrite veblen_unroll.
  apply ord_lub_eq_mor; auto with ord.
  apply sup_ord_eq_morphism.
  hnf; intro i.
  unfold nextCritical.
  split.
  - apply sup_least; intros.
    transitivity
      (fixOrd (bhtower 0 (bhtower 1 f (g i)) (sz a))
              (limOrd (fun x : ord Y h => veblen f (ord B g) (sz x)))).
    { apply fixOrd_monotone.
      intros.
      rewrite bhtower_index_zero.
      rewrite bhtower_index_zero.
      apply bhtower_monotone; auto with ord.
      rewrite ord_le_unfold; intro x. simpl.
      rewrite ord_lt_unfold. simpl. exists x.
      apply Hy. }
    apply fixOrd_monotone_func.
    intros. rewrite bhtower_index_zero. apply Hb.
    intros. apply veblen_monotone; auto.
  - rewrite addOrd_unfold.
    rewrite lub_unfold. simpl.
    rewrite <- (sup_le _ _ (inl _ tt)).
    transitivity
      (fixOrd (bhtower 0 (bhtower 1 f (g i)) 0)
              (limOrd (fun x : ord Y h => veblen f (ord B g) (sz x)))).
    { apply fixOrd_monotone_func.
      intros. rewrite bhtower_index_zero.
      apply Hb.
      intros.
      rewrite bhtower_index_zero.
      rewrite bhtower_index_zero.
      apply bhtower_monotone; auto with ord. }
    apply fixOrd_monotone; auto.
    intros.
    rewrite bhtower_index_zero.
    rewrite bhtower_index_zero.
    apply bhtower_monotone; auto with ord.
    rewrite ord_le_unfold; intro x. simpl.
    rewrite ord_lt_unfold. simpl. exists x.
    apply Hy.
Qed.

Lemma bhtower_zero n f x :
  bhtower n f 0 x ≈ f x.
Proof.
  destruct n; simpl; auto.
  rewrite bhtower_index_zero. auto with ord.
  rewrite bhtower_unroll.
  split.
  - apply lub_least; auto with ord.
    apply sup_least; intros [].
  - apply lub_le1.
Qed.

Lemma bhtower_above_f n f b x :
  f x <= bhtower n f b x.
Proof.
  destruct n; simpl; auto.
  rewrite bhtower_index_zero. auto with ord.
  rewrite bhtower_unroll.
  apply lub_le1.
Qed.

Lemma bhtower_nonzero n f b x :
  normal_function f ->
  0 < bhtower n f b x.
Proof.
  intros.
  rewrite <- bhtower_above_f.
  apply normal_nonzero; auto.
Qed.

Lemma nextCritical_above : forall n f y x, 0 < y -> x <= nextCritical n f y x.
Proof.
  intros. simpl.
  rewrite ord_lt_unfold in H.
  destruct H as [y0 _].
  unfold nextCritical.
  rewrite <- (sup_le _ _ y0).
  apply fixOrd_above.
Qed.

Section bhtower_normal.
  Variable n : nat.

  Hypothesis bhtower_n_normal :
    forall f a,
      normal_function f ->
      complete a ->
      normal_function (bhtower n f a).

  Hypothesis bhtower_n_continuous :
    forall f,
      normal_function f ->
      scott_continuous (fun a => bhtower n f a 0).

  Lemma nextCritical_complete : forall f y x,
    normal_function f ->
    complete y ->
    complete x ->
    complete (nextCritical n f y x).
  Proof.
    intros. simpl.
    apply sup_complete.
    - intro a. apply normal_fix_complete; auto with ord.
      intros. apply normal_inflationary; auto with ord.
    - hnf; intros.
      destruct (complete_directed y H0 a1 a2) as [a' [??]].
      exists a'.
      split; apply fixOrd_monotone_func; auto with ord.
    - destruct (complete_zeroDec y H0).
      + right. intro a.
        destruct (ord_le_subord y 0 H2 a) as [[] _].
      + rewrite ord_lt_unfold in H2. destruct H2 as [a ?].
        left. exists a.
        rewrite normal_fixpoint; auto.
        apply bhtower_nonzero; auto.
  Qed.

  Lemma nextCritical_least : forall f y x z,
      normal_function f ->
      complete y ->
      complete z ->
      x <= z ->
      (forall y', complete y' -> y' < y -> bhtower n f y' z <= z) ->
      nextCritical n f y x <= z.
  Proof.
    intros.
    unfold nextCritical.
    apply sup_least; intro y0.
    apply normal_fix_least; auto.
    apply H3; auto with ord.
  Qed.

  Lemma nextCritical_critical :
  forall f y x y',
    normal_function f ->
    complete y' ->
    complete y ->
    complete x ->
    y' < y ->
    bhtower n f y' (nextCritical n f y x) ≈ nextCritical n f y x.
  Proof.
    intros f y x y' Hf Hcy' Hcy Hcx.
    split.
    - intros. unfold nextCritical at 1.
      generalize H; intro.
      rewrite ord_lt_unfold in H0.
      destruct H0 as [y0  ?].
      etransitivity.
      { apply normal_continuous; auto.
        apply directed_monotone; auto.
        intros; apply fixOrd_monotone_func; auto with ord.
        intros. apply normal_fix_complete; auto with ord.
        intros; apply normal_inflationary; auto with ord. }

      apply sup_least; intro y1.
      destruct (complete_directed y Hcy y0 y1) as [y2 [??]].
      unfold nextCritical.
      rewrite <- (sup_le _ _ y2).
      rewrite (normal_fixpoint (bhtower n f (sz y2))); auto.
      transitivity (bhtower n f y2 (fixOrd (bhtower n f (sz y1)) x)).
      apply bhtower_monotone; auto with ord.
      rewrite H0; auto.
      apply bhtower_monotone; auto with ord.
      apply fixOrd_monotone_func; auto with ord.
    - apply normal_inflationary; auto.
      apply nextCritical_complete; auto.
  Qed.

  Lemma nextCritical_fix : forall f y x,
      normal_function f ->
      complete x ->
      complete y ->
      0 < y ->
      f (nextCritical n f y x) <= nextCritical n f y x.
  Proof.
    intros.
    transitivity (bhtower n f 0 (nextCritical n f y x)).
    { rewrite bhtower_zero. reflexivity. }
    apply nextCritical_critical; auto.
  Qed.

  Section bhtower_normal_inner.
    Variable b : Ord.
    Hypothesis Hcomplete_b : complete b.

    Hypothesis bhtower_normal :
      forall f a,
        a < b ->
        complete a ->
        normal_function f ->
        normal_function (bhtower (S n) f a).

    Lemma bhtower_complete :
      forall f x,
        normal_function f ->
        complete x ->
        complete (bhtower (S n) f b x).
    Proof.
      intros.
      induction x as [X h Hind].
      rewrite bhtower_unroll.
      destruct (complete_zeroDec b Hcomplete_b).
      - apply lub_complete1.
        + apply sup_least. intro.
          destruct (ord_le_subord b 0 H1 a) as [[] _].
        + apply normal_complete; auto.
        + assert (forall (P:Prop) (a:b), P).
          { intros. destruct (ord_le_subord b 0 H1 a) as [[] _]. }
          apply sup_complete; auto.
          * intros; apply (H2 _ a).
          * hnf; intros. apply (H2 _ a1).
          * right; intros; auto.
            apply (H2 _ a).
      - apply lub_complete2.
        + rewrite ord_lt_unfold in H1.
          destruct H1 as [a ?].
          rewrite <- (sup_le _ _ a).
          rewrite <- nextCritical_fix; auto.
          rewrite bhtower_unroll.
          rewrite <- lub_le1.
          apply normal_monotone; auto.
          rewrite <- nextCritical_above; auto with ord.
          rewrite ord_le_unfold; intro q.
          rewrite ord_lt_unfold; exists q; simpl.
          rewrite bhtower_unroll.
          rewrite <- lub_le1.
          apply normal_inflationary; auto.
          apply H0.
          rewrite <- addOrd_le1; auto with ord.
          apply bhtower_normal; auto with ord.
          { apply lim_complete; auto.
            intros. apply Hind; auto.
            apply H0.
            apply directed_monotone; auto.
            intros; apply bhtower_monotone; auto with ord.
            apply H0.
          }
          rewrite <- addOrd_le1; auto with ord.
        + apply normal_complete; auto.
        + apply sup_complete.
          * intros.
            apply nextCritical_complete; auto.
            apply bhtower_normal; auto with ord.
            apply lim_complete.
            ** intros. apply Hind; auto.
               apply H0.
            ** apply directed_monotone; auto.
               intros; apply bhtower_monotone; auto with ord.
            ** apply H0.
          * apply directed_monotone; auto.
            intros.
            apply nextCritical_monotone; auto with ord.
          * left.
            rewrite ord_lt_unfold in H1.
            destruct H1 as [b0 ?].
            exists b0.
            rewrite <- nextCritical_fix; auto.
            apply bhtower_nonzero; auto.
            apply bhtower_normal; auto with ord.
            { apply lim_complete; auto.
              intros. apply Hind; auto.
              apply H0.
              apply directed_monotone; auto.
              intros; apply bhtower_monotone; auto with ord.
              apply H0.
            }
            rewrite <- addOrd_le1; auto with ord.
    Qed.

    Lemma bhtower_complete_lemma1 :
      forall f x,
        normal_function f ->
        complete x ->
        complete (limOrd (fun i : x => bhtower (S n) f b (x i))).
    Proof.
      intros.
      apply lim_complete.
      intros. apply bhtower_complete; auto.
      apply directed_monotone; auto.
      intros. apply bhtower_monotone; auto with ord.
      destruct x; apply H0.
    Qed.

    Lemma bhtower_complete_lemma2 :
      forall f x (a:b),
        normal_function f ->
        complete x ->
        complete
          (nextCritical n (bhtower (S n) f a) (1+x) (limOrd (fun i:x => bhtower (S n) f b (x i)))).
    Proof.
      intros.
      apply nextCritical_complete; auto.
      apply bhtower_normal; auto with ord.
      apply bhtower_complete_lemma1; auto.
    Qed.

    Lemma bhtower_nextCritical_directed :
      forall f x,
        normal_function f ->
        complete x ->
        directed b
                 (fun a : b =>
                    (nextCritical n (bhtower (S n) f a) (1+x) (limOrd (fun i:x => bhtower (S n) f b (x i))))).
    Proof.
      intros.
      apply directed_monotone; auto.
      intros. apply nextCritical_monotone; auto with ord.
    Qed.

    Lemma bhtower_complete_lemma3 :
      forall f x,
        normal_function f ->
        complete x ->
        complete
          (supOrd (fun a:b =>
                     (nextCritical n (bhtower (S n) f a) (1+x) (limOrd (fun i:x => bhtower (S n) f b (x i)))))).
    Proof.
      intros.
      apply sup_complete.
      - intro. apply bhtower_complete_lemma2; auto.
      - apply bhtower_nextCritical_directed; auto.
      - destruct (complete_zeroDec b Hcomplete_b).
        + right. intro.
          destruct (ord_le_subord b 0 H1 a) as [[] _].
        + rewrite ord_lt_unfold in H1.
          destruct H1 as [a ?].
          left. exists a.
          rewrite <- nextCritical_fix; auto.
          apply bhtower_nonzero; auto.
          apply bhtower_normal; auto with ord.
          apply bhtower_complete_lemma1; auto.
          rewrite <- addOrd_le1.
          auto with ord.
    Qed.

    Local Hint Resolve
          bhtower_complete
          bhtower_complete_lemma1
          bhtower_complete_lemma2
          bhtower_complete_lemma3
          bhtower_nextCritical_directed : core.

    Lemma bhtower_inc : forall f x y,
        normal_function f ->
        complete y ->
        x < y ->
        bhtower (S n) f b x < bhtower (S n) f b y.
    Proof.
      intros f x y. revert x.
      induction y as [Y h Hy]. intros x Hf; intros.
      rewrite (bhtower_unroll n f b (ord Y h)).
      destruct (complete_zeroDec b Hcomplete_b).
      - assert (b ≈ 0).
        { split; auto with ord. }
        rewrite <- lub_le1.
        apply ord_le_lt_trans with (f x); auto.
        rewrite (bhtower_unroll n f b x).
        apply lub_least; auto with ord.
        apply sup_least; intro.
        destruct (ord_le_subord b 0 H1 a) as [[] _].
        apply normal_increasing; auto.
      - rewrite ord_lt_unfold in H1.
        destruct H1 as [q _].
        rewrite <- lub_le2.
        rewrite <- (sup_le _ _ q).
        rewrite <- nextCritical_above.
        rewrite ord_lt_unfold. simpl.
        rewrite ord_lt_unfold in H0.
        destruct H0 as [i ?].
        exists i.
        apply bhtower_monotone; auto with ord.
        rewrite <- addOrd_le1.
        auto with ord.
    Qed.

    Lemma bhtower_inflate :
      forall f x,
        normal_function f ->
        complete x ->
        x <= bhtower (S n) f b x.
    Proof.
      intros.
      rewrite bhtower_unroll.
      rewrite <- lub_le1.
      apply normal_inflationary; auto.
    Qed.

    Lemma nextCritical_inflate_lemma : forall f x (a0:b),
        normal_function f ->
        complete x ->
        bhtower (S n) f b x <= supOrd (fun a:b => nextCritical n (bhtower (S n) f a) (1+x) (limOrd (fun i => bhtower (S n) f b (x i)))).
    Proof.
      intros.
      rewrite (bhtower_unroll n f b x).
      apply lub_least; auto with ord.
      rewrite <- (sup_le _ _ a0).
      rewrite <- nextCritical_fix; auto.
      rewrite bhtower_unroll.
      rewrite <- lub_le1.
      apply normal_monotone; auto.
      rewrite <- nextCritical_above.
      rewrite ord_le_unfold. intro i.
      rewrite ord_lt_unfold. exists i. simpl.
      apply bhtower_inflate; auto.
      rewrite <- addOrd_le1.
      auto with ord.
      apply bhtower_normal; auto with ord.
      rewrite <- addOrd_le1.
      auto with ord.
    Qed.

    Lemma bhtower_fixpoint' : forall f a x,
      normal_function f ->
      complete a ->
      complete x ->
      a < b ->
      bhtower (S n) f a (bhtower (S n) f b x) <= bhtower (S n) f b x.
    Proof.
      intro f.
      induction a as [A g Hinda].
      intros x Hf Hca Hcx H.
      rewrite (bhtower_unroll n f (ord A g)).
      apply lub_least.
      { rewrite ord_lt_unfold in H. destruct H as [b0 ?].
        etransitivity.
        { apply normal_monotone; auto.
          apply (nextCritical_inflate_lemma f x b0); auto.
        }
        etransitivity.
        { apply normal_continuous; auto. }
        apply sup_least; intro i.
        rewrite (bhtower_unroll n f b x).
        rewrite <- lub_le2.
        rewrite <- (sup_le _ _ i).
        rewrite <- (nextCritical_fix
                      (bhtower (S n) f (sz i)) (1 + x)
                      (limOrd (fun x0 : x => bhtower (S n) f b (sz x0)))); auto.
        rewrite bhtower_unroll.
        apply lub_le1.
        apply bhtower_normal; auto with ord.
        rewrite <- addOrd_le1.
        auto with ord. }

      apply sup_least; intro q.
      apply nextCritical_least; auto.
      + apply bhtower_normal; auto with ord.
        transitivity (ord A g); auto with ord.
      + rewrite ord_le_unfold. simpl.
        intros.
        rewrite (bhtower_unroll n f b).
        rewrite <- lub_le2.
        rewrite ord_lt_unfold in H.
        destruct H as [m ?].
        apply ord_le_lt_trans with (bhtower (S n) f (b m) (bhtower (S n) f b x a)).
        apply bhtower_monotone; auto with ord.
        apply ord_lt_le_trans with
            (bhtower (S n) f (b m)
            (supOrd
               (fun a1 : b =>
                  nextCritical n (bhtower (S n) f (sz a1)) (1 + x) (limOrd (fun x0 : x => bhtower (S n) f b (x x0)))))).
        apply normal_increasing; auto.
        apply bhtower_normal; auto with ord.
        apply ord_lt_le_trans with (bhtower (S n) f b x); auto with ord.
        apply nextCritical_inflate_lemma; auto with ord.
        etransitivity.
        { apply normal_continuous; auto.
          apply bhtower_normal; auto with ord.
        }
        apply sup_least; intros i.
        destruct (complete_directed b Hcomplete_b m i) as [k [??]].
        rewrite <- (sup_le _ _ k).
        rewrite <- (nextCritical_fix (bhtower (S n) f (sz k))); auto.
        apply bhtower_monotone; auto with ord.
        apply bhtower_normal; auto with ord.
        rewrite <- addOrd_le1.
        apply succ_lt.

      + induction y' as [Y h Hindy].
        intros.
        assert (ord Y h < bhtower (S n) f b x).
        { eapply ord_lt_le_trans; [ apply H1 | ].
          transitivity (bhtower (S n) f (g q) (bhtower (S n) f b x)).
          apply onePlus_least_normal; auto with ord.
          apply bhtower_normal; auto.
          transitivity (ord A g); auto with ord.
          apply Hca.
          apply Hinda; auto.
          apply Hca.
          transitivity (ord A g); auto with ord. }
        assert (ord Y h < supOrd (fun a:b => nextCritical n (bhtower (S n) f a) (1+x) (limOrd (fun i => bhtower (S n) f b (x i))))).
        { rewrite ord_lt_unfold in H. destruct H.
          rewrite <- nextCritical_inflate_lemma; auto. }
        apply sup_lt in H3.
        destruct H3 as [b1 H3].
        unfold nextCritical in H3.
        apply sup_lt in H3.
        destruct H3 as [z1 H3].
        transitivity (bhtower n (bhtower (S n) f (sz q)) (ord Y h)
                              (supOrd (fun a:b => nextCritical n (bhtower (S n) f a) (1+x) (limOrd (fun i => bhtower (S n) f b (x i)))))).
        { apply bhtower_monotone; auto with ord.
          apply nextCritical_inflate_lemma; auto. }
        transitivity (supOrd (fun a:b =>
                                bhtower n (bhtower (S n) f (sz q)) (ord Y h)
                                        (nextCritical n (bhtower (S n) f (sz a)) (1 + x)
                                        (limOrd (fun i : x => bhtower (S n) f b (x i)))))).
        { apply normal_continuous; auto.
          apply bhtower_n_normal; auto.
          apply bhtower_normal; auto with ord.
          transitivity (ord A g); auto with ord. }
        apply sup_least; intro b2.
        unfold nextCritical.
        transitivity (supOrd (fun z:(1+x)%ord =>
                                bhtower n (bhtower (S n) f (sz q)) (ord Y h)
                                        (fixOrd (bhtower n (bhtower (S n) f (sz b2)) (sz z))
                                          (limOrd (fun i : x => bhtower (S n) f b (x i)))))).
        { apply normal_continuous; auto.
          apply bhtower_n_normal; auto.
          apply bhtower_normal; auto with ord.
          transitivity (ord A g); auto with ord.
          apply directed_monotone; auto with ord.
          intros. apply fixOrd_monotone_func; auto with ord.
          intros. apply normal_fix_complete; auto with ord.
          intros. apply normal_inflationary; auto with ord.
          intros. apply normal_complete; auto with ord. }

        apply sup_least. intro z2.
        assert (Hx1 : complete (1+x)).
        { auto with ord. }
        destruct (complete_directed b Hcomplete_b b1 b2) as [b' [??]].
        rewrite ord_lt_unfold in H. destruct H as [b3 H].
        destruct (complete_directed b Hcomplete_b b' b3) as [b'' [??]].
        destruct (complete_directed (1+x) Hx1 z1 z2) as [z' [??]].
        rewrite (bhtower_unroll n f b x).
        rewrite <- lub_le2.
        rewrite <- (sup_le _ _ b'').
        unfold nextCritical.
        rewrite <- (sup_le _ _ z').
        rewrite (normal_fixpoint (bhtower n (bhtower (S n) f (sz b'')) (sz z'))).
        rewrite <- (bhtower_above_f n (bhtower (S n) f b'')).
        assert (q < b'').
        { eapply ord_lt_le_trans with (ord A g); auto with ord.
          transitivity b3; auto. }
        rewrite (bhtower_unroll n f b'').
        rewrite <- lub_le2.
        rewrite ord_lt_unfold in H10.
        destruct H10 as [qb ?].
        rewrite <- (sup_le _ _ qb).
        assert (Hfixc : complete (fixOrd (bhtower n (bhtower (S n) f (sz b'')) (sz z'))
         (limOrd (fun x0 : x => bhtower (S n) f b (sz x0))))).
        { apply normal_fix_complete; auto with ord.
          intros; apply normal_inflationary; auto.
          apply bhtower_n_normal; auto.
          apply bhtower_normal; auto with ord. }

        rewrite <- (nextCritical_critical (bhtower (S n) f qb) _ _ (ord Y h)); auto with ord.
        apply bhtower_monotone; auto with ord.
        rewrite <- nextCritical_above.
        transitivity (fixOrd (bhtower n (bhtower (S n) f (sz b'')) (sz z'))
                (limOrd (fun x0 : x => bhtower (S n) f b (sz x0)))).
        { apply fixOrd_monotone_func; auto with ord.
          intros; apply bhtower_monotone; auto with ord.
          intros; apply bhtower_monotone; auto with ord.
          rewrite H5; auto. }
        rewrite ord_le_unfold. simpl; intro r.
        rewrite ord_lt_unfold. exists r. simpl.
        apply normal_inflationary.
        apply bhtower_normal; auto with ord.
        apply complete_subord; auto.
        rewrite <- addOrd_le1.
        auto with ord.
        apply bhtower_normal; auto with ord.
        transitivity b''; auto with ord.
        { apply lim_complete; auto with ord.
          apply directed_monotone; auto with ord.
          apply Hfixc. }
        eapply ord_lt_le_trans; [ apply H3 |].
        etransitivity; [ | apply addOrd_le2 ].
        { apply fixOrd_monotone_func; auto with ord.
          intros; apply bhtower_monotone; auto with ord.
          intros; apply bhtower_monotone; auto with ord.
          rewrite H4; auto. }
        apply bhtower_n_normal; auto.
        apply bhtower_normal; auto with ord.
        { apply lim_complete; auto.
          apply directed_monotone; auto with ord.
          destruct x; apply Hcx. }
    Qed.

    Lemma bhtower_continuous f :
      normal_function f ->
      scott_continuous (bhtower (S n) f b).
    Proof.
      intro Hf.
      hnf; simpl; intros.
      rewrite bhtower_unroll.
      apply lub_least.
      - etransitivity; [ apply normal_continuous | ]; auto.
        apply sup_least; intro i.
        rewrite <- (sup_le _ _ i).
        rewrite bhtower_unroll.
        apply lub_le1.
      - apply sup_least; simpl; intros.
        apply nextCritical_least; auto.
        + apply bhtower_normal; auto with ord.
        + rewrite addOrd_unfold.
          rewrite lub_unfold.
          rewrite sup_unfold. simpl.
          intuition.
          * hnf; intros.
            destruct a1; destruct a2; simpl in *.
            ** exists (inl _ tt); split; auto with ord.
            ** exists (inr _ s).
               split; auto with ord.
            ** exists (inr _ s).
               split; auto with ord.
            ** destruct s as [q1 []].
               destruct s0 as [q2 []]. simpl.
               revert q1 q2.
               rewrite sup_unfold. simpl.
               intros [a1 r1]. intros [a2 r2]. simpl.
               destruct (H a1 a2) as [a' [??]].
               destruct (ord_le_subord _ _ H1 r1) as [r1' ?].
               destruct (ord_le_subord _ _ H2 r2) as [r2' ?].
               destruct (complete_directed (f0 a') (H0 a') r1' r2') as [r' [??]].
               exists (inr _ (existT _ (existT _ a' r') tt)). simpl.
               split.
               apply addOrd_monotone; auto with ord.
               rewrite H3; auto.
               apply addOrd_monotone; auto with ord.
               rewrite H4; auto.

          * left. exact (inhabits (inl _ tt)).
          * destruct b0. simpl.
            apply addOrd_complete; auto.
            revert x. rewrite sup_unfold.
            simpl. intros [q r]. simpl.
            apply complete_subord.
            apply H0.

        + apply sup_complete; auto.
          hnf; intros.
          destruct (H a1 a2) as [a' [??]].
          exists a'; split; apply bhtower_monotone; auto with ord.
          left. exists a0.
          apply bhtower_nonzero.
          auto.

        + apply limit_least. rewrite sup_unfold.
          simpl. intros [i j]. simpl.
          rewrite <- (sup_le _ _ i).
          apply bhtower_inc; auto with ord.

        + intros.
          transitivity (supOrd (fun i => bhtower n (bhtower (S n) f (sz a)) y' (bhtower (S n) f b (f0 i)))).
          apply normal_continuous; auto with ord.
          apply (directed_monotone (ord A f0)); auto.
          intros; apply bhtower_monotone; auto with ord.
          simpl; intuition.

          apply sup_least; intro i.
          rewrite addOrd_unfold in H2.
          apply lub_lt in H2.
          destruct H2.
          * assert (y' ≈ 0).
            { split; auto with ord.
              rewrite ord_lt_unfold in H2. destruct H2; auto. }
            rewrite <- (sup_le _ _ i).
            transitivity (bhtower n (bhtower (S n) f (sz a)) 0 (bhtower (S n) f b (f0 i))).
            apply bhtower_monotone; auto with ord.
            apply H3.
            rewrite bhtower_zero.
            apply bhtower_fixpoint'; auto with ord.

          * apply sup_lt in H2.
            rewrite sup_unfold in H2. simpl in H2.
            destruct H2 as [[j q]?]. simpl in H2.
            assert (y' < 1 + f0 j).
            { eapply ord_lt_le_trans; [ apply H2 | ].
              apply succ_least.
              apply addOrd_increasing. auto with ord. }
            destruct (H i j) as [k [??]].
            rewrite <- (sup_le _ _ k).

            transitivity (bhtower n (bhtower (S n) f (sz a)) y' (bhtower (S n) f b (f0 k))).
            { apply bhtower_monotone; auto with ord. }

            rewrite addOrd_unfold in H3.
            apply lub_lt in H3.
            destruct H3.
            { transitivity (bhtower n (bhtower (S n) f (sz a)) 0 (bhtower (S n) f b (f0 k))).
              apply bhtower_monotone; auto with ord.
              rewrite ord_lt_unfold in H3.
              destruct H3; auto.
              rewrite bhtower_zero.
              apply bhtower_fixpoint'; auto with ord.
            }
            apply sup_lt in H3. destruct H3 as [r ?].
            rewrite ord_lt_unfold in H3.
            destruct H3; simpl in *.

            transitivity (bhtower n (bhtower (S n) f (sz a)) y' (supOrd
                                                     (fun a1 : b =>
                                                        nextCritical n (bhtower (S n) f (sz a1)) (1 + f0 k)
                                                              (limOrd (fun x : f0 k => bhtower (S n) f b (f0 k x)))))).
            apply bhtower_monotone; auto with ord.
            rewrite nextCritical_inflate_lemma; auto with ord.

            etransitivity; [ apply normal_continuous | ]; auto.
            apply bhtower_n_normal; auto.
            apply bhtower_normal; auto with ord.
            apply sup_least; intro a2.

            destruct (complete_directed b Hcomplete_b a a2) as [a'[??]].
            rewrite (bhtower_unroll n f b (f0 k)).
            rewrite <- lub_le2.
            rewrite <- (sup_le _ _ a').
            rewrite <- (nextCritical_critical (bhtower (S n) f (sz a')) (1 + f0 k) _ y'); auto.
            apply bhtower_monotone; auto with ord.
            apply bhtower_normal; auto with ord.
            rewrite <- H5.
            rewrite H3.
            apply addOrd_increasing; auto with ord.
    Qed.

  End bhtower_normal_inner.

  Lemma bhtower_S_normal :
    forall b f,
      normal_function f ->
      complete b ->
      normal_function (bhtower (S n) f b).
  Proof.
    induction b as [b Hb] using ordinal_induction.
    intros. constructor.
    + intros; apply bhtower_monotone; auto with ord.
    + intros. apply bhtower_inc; auto with ord.
    + apply bhtower_continuous; auto.
    + intros. apply bhtower_complete; auto.
    + intros. apply bhtower_nonzero; auto.
  Qed.

  Lemma bhtower_S_fixpoint :
    forall b f a x,
      normal_function f ->
      complete a ->
      complete b ->
      complete x ->
      a < b ->
      bhtower (S n) f a (bhtower (S n) f b x) ≤ bhtower (S n) f b x.
  Proof.
    intros.
    apply bhtower_fixpoint'; auto.
    intros. apply bhtower_S_normal; auto.
  Qed.

  Lemma bhtower_S_continuous :
    forall f,
      normal_function f ->
      scott_continuous (fun b => bhtower (S n) f b 0).
  Proof.
    intros. hnf; simpl; intros.
    rewrite bhtower_unroll.
    apply lub_least.
    { rewrite <- (sup_le _ _ a0).
      rewrite bhtower_unroll.
      auto with ord. }
    apply sup_least. rewrite sup_unfold. simpl; intros.
    destruct a as [a q]. simpl.
    rewrite <- (sup_le _ _ a).
    rewrite bhtower_unroll.
    rewrite <- lub_le2.
    rewrite <- (sup_le _ _ q).
    apply nextCritical_monotone; auto with ord.
    rewrite ord_le_unfold. simpl; intros [].
  Qed.

End bhtower_normal.

Lemma bhtower_normal_and_continuous :
  forall n,
    (forall f b, normal_function f -> complete b -> normal_function (bhtower n f b)) /\
    (forall f, normal_function f -> scott_continuous (fun b => bhtower n f b 0)).
Proof.
  induction n; split; intros.
  - constructor.
    * intros; repeat rewrite bhtower_index_zero.
      apply normal_monotone; auto.
    * intros; repeat rewrite bhtower_index_zero.
      apply normal_increasing; auto.
    * hnf; simpl; intros.
      rewrite bhtower_index_zero.
      transitivity (supOrd (fun (i:A) => f (f0 i))).
      apply normal_continuous; auto.
      apply sup_ord_le_morphism.
      intro i.
      rewrite bhtower_index_zero. auto with ord.
    * intros. rewrite bhtower_index_zero.
      apply normal_complete; auto.
    * intros. rewrite bhtower_index_zero.
      apply normal_nonzero; auto.
  - hnf; simpl; intros.
    rewrite bhtower_index_zero.
    rewrite <- (sup_le _ _ a0).
    rewrite bhtower_index_zero.
    auto with ord.
  - apply bhtower_S_normal; auto.
    intros. apply IHn; auto.
  - apply bhtower_S_continuous; auto.
Qed.

Theorem bhtower_normal :
  forall n f b,
    normal_function f ->
    complete b ->
    normal_function (bhtower n f b).
Proof.
  intros. apply bhtower_normal_and_continuous; auto.
Qed.

Theorem bhtower_first_normal :
  forall n f,
    normal_function f ->
    normal_function (fun b => bhtower (S n) f b 0).
Proof.
  intros. constructor.
  - intros. apply bhtower_monotone; auto with ord.
  - intros.
    rewrite (bhtower_unroll n f y).
    rewrite <- lub_le2.
    rewrite ord_lt_unfold in H1.
    destruct H1 as [q H1].
    rewrite <- (sup_le _ _ q).
    apply ord_lt_le_trans with
        (nextCritical n (bhtower (S n) f (sz q)) (1 + 0) 0).
    rewrite <- nextCritical_fix; auto with ord.
    apply ord_le_lt_trans with (bhtower (S n) f q 0).
    apply bhtower_monotone; auto with ord.
    apply normal_increasing; auto with ord.
    apply bhtower_normal; auto.
    apply nextCritical_complete; auto.
    apply bhtower_normal; auto.
    apply bhtower_normal; auto.
    rewrite <- nextCritical_fix; auto with ord.
    apply bhtower_nonzero; auto.
    apply bhtower_normal; auto.
    apply bhtower_normal; auto.
    rewrite <- addOrd_le1; auto with ord.
    apply bhtower_normal; auto.
    apply bhtower_normal; auto.
    rewrite <- addOrd_le1; auto with ord.
    apply nextCritical_monotone; auto with ord.
  - apply bhtower_normal_and_continuous; auto.
  - intros. apply normal_complete; auto.
    apply bhtower_normal; auto.
  - intros. apply bhtower_nonzero; auto.
Qed.

Theorem bhtower_fixpoint :
  forall n f a b x,
    (0 < n)%nat ->
    normal_function f ->
    complete a ->
    complete b ->
    complete x ->
    a < b ->
    bhtower n f a (bhtower n f b x) ≈ bhtower n f b x.
Proof.
  intros.
  destruct n. inversion H.
  split.
  apply bhtower_S_fixpoint; auto.
  apply bhtower_normal; auto.
  apply normal_inflationary; auto.
  apply bhtower_normal; auto.
  apply normal_complete; auto.
  apply bhtower_normal; auto.
Qed.

Theorem bhtower_succ :
  forall n f b x,
    (n > 0)%nat ->
    normal_function f ->
    complete b ->
    complete x ->
    bhtower (S n) f (succOrd b) x ≈ bhtower n (bhtower (S n) f b) (1+x) 0.
Proof.
  intros n f b.
  induction x as [x Hx] using ordinal_induction.
  intros. split.
  - rewrite bhtower_unroll.
    apply lub_least.
    + transitivity (bhtower n (bhtower (S n) f b) 0 (bhtower n (bhtower (S n) f b) (1+x) 0)).
      rewrite bhtower_zero.
      rewrite bhtower_unroll.
      rewrite <- lub_le1.
      apply normal_monotone; auto.
      transitivity (1+x); auto with ord.
      apply addOrd_le2.
      apply (normal_inflationary (fun i => bhtower n (bhtower (S n) f b) i 0)).
      destruct n. inversion H.
      apply bhtower_first_normal.
      apply bhtower_normal; auto.
      auto with ord.
      apply bhtower_fixpoint; auto with ord.
      apply bhtower_normal; auto.
      rewrite <- addOrd_le1.
      auto with ord.
    + apply sup_least; simpl; intro.

      apply nextCritical_least; auto with ord.
      * intros. apply bhtower_normal; auto.
      * apply bhtower_normal; auto.
      * apply normal_complete; auto with ord.
        apply bhtower_normal; auto with ord.
        apply bhtower_normal; auto with ord.
      * rewrite ord_le_unfold; simpl; intro i.
        rewrite Hx; auto with ord.
        apply (normal_increasing (fun i => bhtower n (bhtower (S n) f b) i 0)).
        destruct n. inversion H.
        apply bhtower_first_normal.
        apply bhtower_normal; auto.
        auto with ord.
        apply addOrd_increasing; auto with ord.
      * intros.
        apply bhtower_fixpoint; auto with ord.
        apply bhtower_normal; auto.

  - destruct n. inversion H.
    rewrite bhtower_unroll.
    apply lub_least.
    apply bhtower_monotone; auto with ord.
    apply sup_least; intro a.
    rewrite (bhtower_unroll (S n) f (succOrd b) x).
    rewrite <- lub_le2.
    simpl.
    rewrite <- (sup_le _ _ tt).
    transitivity (nextCritical n (bhtower (S n) (bhtower (S (S n)) f b) (sz a)) 1 0).
    { apply nextCritical_monotone; auto with ord.
      rewrite addOrd_zero_r; auto with ord.
      rewrite ord_le_unfold; intros []. }
    unfold nextCritical at 1.
    apply sup_least; intro.
    destruct a0. simpl.
    apply normal_fix_least; auto with ord.
    + apply bhtower_normal; auto.
      apply bhtower_normal; auto.
      apply bhtower_normal; auto.
    + apply nextCritical_complete; auto with ord.
      intros; apply bhtower_normal; auto.
      intros; apply bhtower_normal; auto.
      apply lim_complete; auto.
      intros. apply normal_complete; auto.
      apply bhtower_normal; auto.
      apply directed_monotone; auto with ord.
      destruct x; apply H2.
    + rewrite bhtower_zero.
      apply nextCritical_critical; auto with ord.
      intros; apply bhtower_normal; auto.
      intros; apply bhtower_normal; auto.
      apply lim_complete; auto.
      intros. apply normal_complete; auto.
      apply bhtower_normal; auto.
      apply directed_monotone; auto with ord.
      destruct x; apply H2.
Qed.

Theorem bhtower_limit :
  forall n f b x,
    normal_function f ->
    complete b ->
    complete x ->
    limitOrdinal b ->
    bhtower (S n) f b x ≈ supOrd (fun a:b => bhtower (S n) f a (limOrd (fun i => bhtower (S n) f b (x i)))).
Proof.
  induction n; intros f b x Hf Hcb Hcx H.
  - rewrite bhtower_index_one; auto.
    rewrite veblen_unroll.
    split; auto with ord.
    + apply lub_least.
      * rewrite ord_isLimit in H; destruct H as [H0 Hlim].
        rewrite ord_lt_unfold in H0. destruct H0 as [b0 ?].
        destruct b as [B g]. simpl in *.
        rewrite <- (sup_le _ _ b0).
        rewrite bhtower_index_one.
        rewrite veblen_unroll.
        rewrite <- lub_le1.
        apply normal_monotone; auto.
        rewrite ord_le_unfold. intro q.
        rewrite ord_lt_unfold. exists q. simpl.
        apply normal_inflationary; auto with ord.
        apply bhtower_normal; auto.
        auto.
      * destruct b as [B g]; simpl.
        apply sup_least; intro i.
        destruct H as [Hz Hlim].
        destruct (Hlim i) as [i' ?].
        rewrite <- (sup_le _ _ i').
        rewrite bhtower_index_one; auto.
        assert (Hlemma : complete (limOrd (fun i0 : x => bhtower 1 f (ord B g) (x i0)))).
        { apply lim_complete.
          - intros; apply normal_complete; auto with ord.
            apply bhtower_normal; auto.
          - apply directed_monotone; auto.
            intros; apply bhtower_monotone; auto with ord.
          - destruct x; hnf in Hcx; intuition.
        }
        apply normal_fix_least; auto with ord.
        ** apply veblen_normal; auto with ord.
           hnf in Hcb; intuition.
        ** apply veblen_complete; auto.
           hnf in Hcb; intuition.
        ** rewrite ord_le_unfold; simpl; intro q.
           apply ord_lt_le_trans with (limOrd (fun i0 : x => bhtower 1 f (ord B g) (x i0))).
           { rewrite ord_lt_unfold. simpl. exists q.
             rewrite bhtower_index_one. auto with ord. auto. }
           apply normal_inflationary; auto with ord.
           apply veblen_normal; auto with ord.
           hnf in Hcb; intuition.
        ** apply veblen_fixpoints; auto with ord.
           hnf in Hcb; intuition.
           hnf in Hcb; intuition.

    + apply sup_least; intro a.
      rewrite bhtower_index_one; auto.
      rewrite <- lub_le2.
      destruct b as [B g]; simpl in *.
      rewrite <- (sup_le _ _ a).
      rewrite normal_fixpoint; auto with ord.
      apply veblen_monotone; auto.
      rewrite <- fixOrd_above.
      rewrite ord_le_unfold; simpl; intro i.
      rewrite ord_lt_unfold; simpl; exists i.
      rewrite bhtower_index_one; auto with ord.
      apply veblen_normal; auto. intuition.
      { apply lim_complete.
        - intros; apply normal_complete; auto with ord.
          apply veblen_normal; auto.
        - apply directed_monotone; auto.
          intros; apply veblen_monotone; auto with ord.
        - destruct x; hnf in Hcx; intuition.
      }

  - split.
    + rewrite bhtower_unroll.
      apply lub_least.
      * rewrite ord_isLimit in H. destruct H as [Hz Hlim].
        rewrite ord_lt_unfold in Hz. destruct Hz as [b0 _].
        rewrite <- (sup_le _ _ b0).
        rewrite bhtower_unroll.
        rewrite <- lub_le1.
        apply normal_monotone; auto.
        rewrite ord_le_unfold; intro i.
        rewrite ord_lt_unfold; exists i. simpl.
        apply normal_inflationary; auto with ord.
        apply bhtower_normal; auto with ord.
      * apply sup_least; intro a.
        destruct b as [B g]; simpl in *.
        destruct H as [Hz Hlim].
        destruct (Hlim a) as [a' Ha']; auto.
        rewrite <- (sup_le _ _ a').
        rewrite bhtower_unroll.
        rewrite <- lub_le2.
        rewrite ord_lt_unfold in Ha'.
        destruct Ha' as [q Hq].
        rewrite <- (sup_le _ _ q).
        simpl.
        apply nextCritical_monotone; auto with ord.
        ** apply addOrd_monotone; auto with ord.
           rewrite ord_le_unfold; intro i.
           rewrite ord_lt_unfold; exists i; simpl.
           apply normal_inflationary; auto with ord.
           apply bhtower_normal; auto.
        ** rewrite ord_le_unfold; intro i.
           rewrite ord_lt_unfold; exists i; simpl.
           apply bhtower_fixpoint; auto with ord arith.
           intuition.
    + apply sup_least; intro a.
      rewrite (bhtower_unroll (S n) f b x).
      rewrite <- lub_le2.
      rewrite <- (sup_le _ _ a).
      rewrite <- (nextCritical_fix); auto with ord.
      * apply normal_monotone; auto with ord.
        apply bhtower_normal; auto.
        apply nextCritical_above.
        rewrite <- addOrd_le1.
        auto with ord.
      * intros; apply bhtower_normal; auto.
      * apply bhtower_normal; auto.
      * apply lim_complete; auto with ord.
        ** intros; apply normal_complete; auto with ord.
           apply bhtower_normal; auto.
        ** apply directed_monotone; auto.
           intros; apply bhtower_monotone; auto with ord.
        ** destruct x; hnf in Hcx; intuition.
      * rewrite <- addOrd_le1.
        auto with ord.
Qed.

Lemma bhtower_one :
  forall n f x,
    (n > 0)%nat ->
    normal_function f ->
    complete x ->
    bhtower (S n) f 1 x ≈ bhtower n f (1+x) 0.
Proof.
  intros.
  rewrite bhtower_succ; auto.
  split; apply bhtower_monotone; auto with ord.
  intros. rewrite bhtower_zero. auto with ord.
  intros. rewrite bhtower_zero. auto with ord.
Qed.

Lemma bhtower_one_zero_step :
  forall n f,
    (n > 0)%nat ->
    normal_function f ->
    bhtower (S n) f 1 0 ≈ bhtower n f 1 0.
Proof.
  intros.
  rewrite bhtower_one; auto.
  split; apply bhtower_monotone; auto with ord.
  rewrite addOrd_zero_r; auto with ord.
  rewrite addOrd_zero_r; auto with ord.
Qed.

Lemma bhtower_one_zero :
  forall n f,
    normal_function f ->
    bhtower (S n) f 1 0 ≈ fixOrd f 0.
Proof.
  intros. transitivity (veblen f 1 0).
  induction n.
  apply bhtower_index_one; auto.
  rewrite bhtower_one_zero_step; auto.
  lia.
  rewrite veblen_succ; auto with ord.
  rewrite enum_fixpoints_zero.
  split; apply fixOrd_monotone_func; auto with ord.
  intros. rewrite veblen_zero; auto with ord.
  intros. rewrite veblen_zero; auto with ord.
  intros; apply veblen_monotone; auto with ord.
  apply veblen_normal; auto with ord.
Qed.

Theorem bhtower_succ_zero :
  forall n f b,
    (n > 0)%nat ->
    normal_function f ->
    complete b ->
    bhtower (S n) f (succOrd b) 0 ≈ fixOrd (bhtower (S n) f b) 0.
Proof.
  intros.
  rewrite bhtower_succ; auto.
  transitivity (bhtower n (bhtower (S n) f b) 1 0).
  { split; apply bhtower_monotone; auto with ord;
      rewrite addOrd_zero_r; auto with ord. }
  destruct n. inversion H.
  apply bhtower_one_zero.
  apply bhtower_normal; auto.
Qed.

Lemma bhtower_index_two :
  forall f b x,
    normal_function f ->
    complete b ->
    complete x ->
    bhtower 2 f b x ≈ vtower f b x.
Proof.
  intro f.
  induction b using ordinal_induction.
  induction x using ordinal_induction.
  intros.

  rewrite bhtower_unroll.
  rewrite vtower_unroll.
  apply ord_lub_eq_mor; auto with ord.
  apply sup_ord_eq_morphism.
  hnf; intro i.
  unfold VTower.nextCritical.
  unfold nextCritical.
  apply sup_ord_eq_morphism.
  hnf; intro z.
  transitivity
    (fixOrd (bhtower 1 (bhtower 2 f (sz i)) (sz z))
      (limOrd (fun x0 : x => vtower f b (sz x0)))).
  split; apply fixOrd_monotone; auto with ord.
  apply lim_ord_le_morphism. intro j.
  apply H0; auto with ord.
  apply lim_ord_le_morphism. intro j.
  apply H0; auto with ord.

  unfold fixOrd.
  apply sup_ord_eq_morphism.
  intro m.
  induction m; simpl iter_f; auto with ord.
  rewrite bhtower_index_one; auto.
  transitivity
    (veblen (vtower f (sz i)) (sz z)
            (iter_f (bhtower 1 (bhtower 2 f (sz i)) (sz z))
                    (limOrd (fun x0 : x => vtower f b (sz x0))) m)).
  split; apply veblen_monotone_func; auto with ord.
  apply bhtower_normal; auto.
  apply vtower_normal; auto.
  intros. apply H; auto with ord.
  apply iter_f_complete; auto with ord.
  { apply lim_complete; auto.
    intro. apply normal_complete; auto.
    apply vtower_normal; auto.
    apply directed_monotone; auto with ord.
    intros; apply vtower_monotone; auto with ord.
    destruct x; apply H3. }
  intros. apply normal_complete; auto with ord.
  apply bhtower_normal; auto.
  apply bhtower_normal; auto.
  apply vtower_normal; auto.
  apply bhtower_normal; auto.
  intros.
  apply H; auto with ord.
  apply iter_f_complete; auto with ord.
  { apply lim_complete; auto.
    intro. apply normal_complete; auto.
    apply vtower_normal; auto.
    apply directed_monotone; auto with ord.
    intros; apply vtower_monotone; auto with ord.
    destruct x; apply H3. }
  intros. apply normal_complete; auto with ord.
  apply bhtower_normal; auto.
  apply bhtower_normal; auto.

  apply veblen_eq_mor; auto with ord.
  intros. apply vtower_monotone; auto with ord.
  apply bhtower_normal; auto.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e512m491x2e496m1_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


(*** Completeness proof for Diffie Hellma(DH)n Algorithm ***)
(*** To proof it we must first proof that ***)

Require Export Coq.Init.Nat.
Require Export Coq.Strings.String.
Require Export Coq.Strings.Ascii.

Require Export Coq.Numbers.Natural.Abstract.NDiv.

Require Export Coq.ZArith.Znat.
Require Export Coq.ZArith.ZArith_base.
Require Export Coq.ZArith.Zcomplements.
Require Export Coq.ZArith.Zdiv.
Require Export Coq.ZArith.ZArith.

Require Import Omega.

(***
    DH algorithm works basic as an Alice and Bob communication and they
    have some important numbers, they are:

    Alice's PublicKey (A)
    Bob's PublicKey (B)
    Alice's PrivateKey (a)
    Bob's PrivateKey (b)

    Also some other important numbers must exist to make it work:
    a Prime number (p)
    a Base (g)

    These numbers are not secret, and can be known by anyone in the network.
    P must be a prime number, and G is a Primitive root modulo.

    Those keys are used to compute other keys and then a shared secret:
    A = g^a mod p
    B = g^b mod p

    And then Alice sends it's public key to Bob, and vice versa, so they
    compute a shared secret (shared seed) in both sides of the network:

    SharedSeed = B^a mod p
    SharedSeed = A^b mod p

    In notation the prime number may be also called as sharedPrime.
***)

(*** Helper functions****)
Print String.eqb.

(** DH Functions **)
(** base ˆ exponent mod module **)
Fixpoint modExp (base : nat) (exponent : nat) (modulo : nat): nat :=
(pow base exponent) mod modulo.

Compute modExp 3 7 (10).

Fixpoint calculatePublicKey (private_key : nat) (sharedPrime : nat) (sharedBase : nat) : nat :=
  modExp sharedBase private_key sharedPrime.

Compute calculatePublicKey 3 7 (10).

Fixpoint calculateSharedSeed (private_key : nat) (public_key : nat)
         (sharedPrime : nat) : nat :=
modExp public_key private_key sharedPrime.

Compute length "abc".

Fixpoint caesarCrypt (seed : nat) (s : string) : string :=
  match s with
  | EmptyString => EmptyString
  | String c s' => append (String (ascii_of_nat (((nat_of_ascii c) + seed))) EmptyString) (caesarCrypt seed s')
  end
.

Compute caesarCrypt 257 "hello world".

Print Z.of_nat.

Fixpoint moduloDiff256 (asciiNumber:nat) (seed:nat) : nat :=
  if seed =? 0 then
    asciiNumber
  else
    if asciiNumber <? seed then
      if 256 <? (seed - asciiNumber) then
        seed + asciiNumber
      else
        256 - seed + asciiNumber
    else
      asciiNumber - seed
.

Compute moduloDiff256 10 1200.

Lemma diffZ0 : forall (a:Z), Z.sub a 0 = a.
Proof.
  intros. induction a.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Theorem moduleDiff256_of_0: forall (asciiNumber:nat), moduloDiff256 asciiNumber 0 = asciiNumber mod 256.
Proof.
  intros.
  induction asciiNumber.
  - simpl. reflexivity.
  - unfold moduloDiff256. Search (Z.of_nat 0).
Abort.

Definition getAscii (seed: nat) (c: ascii) : ascii :=
if seed <=? (nat_of_ascii c) then
  ascii_of_nat ((nat_of_ascii c) - seed)
else
  ascii_of_nat (256 - nat_of_ascii (ascii_of_nat (seed - (nat_of_ascii c))))
.

Fixpoint caesarDecrypt (seed : nat) (s: string) : string :=
  match s with
  | EmptyString => EmptyString
  | String c s' => append (String (getAscii seed c) EmptyString) (caesarDecrypt seed s')
  end
(** | String c s' => append (String (ascii_of_nat ((moduloDiff256 (nat_of_ascii c) seed))) EmptyString) (caesarDecrypt seed s') **)
.

Compute caesarDecrypt 257 "ifmmp!xpsme".

Compute caesarCrypt 513 "hello world".
Compute caesarDecrypt 513 "ifmmp!xpsme".

Theorem caesarCorrect:
    forall (message: string) (seed: nat),
    (caesarDecrypt seed (caesarCrypt seed message)) = message.
Proof.
  intros.
  induction seed.
  - destruct message.
    + simpl. reflexivity.
    + simpl. Search (_ + 0). rewrite Nat.add_0_r. Search (_ - 0).
    (**
      rewrite Nat.sub_0_r.
      rewrite ascii_nat_embedding. rewrite ascii_nat_embedding.
      rewrite decrypt0.
      assert(crypt0: caesarCrypt 0 message = message).
      {
          induction message.
              - simpl. reflexivity.
              - simpl. rewrite Nat.add_0_r. rewrite IHmessage.
                + rewrite ascii_nat_embedding. reflexivity.
      }
      rewrite crypt0. reflexivity.

  - induction message.
      + simpl. reflexivity.
      + simpl.
        assert(H1: (ascii_of_nat (nat_of_ascii (ascii_of_nat (nat_of_ascii a + S seed)) - S seed)) = a).
        {
          Search(ascii_of_nat _). rewrite nat_ascii_embedding.

          - rewrite Aux1. reflexivity.
          admit.
        }
        rewrite H1.
        assert(H2: (caesarDecrypt (S seed) (caesarCrypt (S seed) message)) = message). {
          simpl. rewrite IHmessage.
            - reflexivity.
            - admit.
        }
        rewrite H2. reflexivity.
    **)
Abort.

Print string_dec.
Compute String.eqb "abc" "abc".
Compute String.eqb "abc" "acb".

Lemma caesarCrypt0 :
  forall (message:string),
  caesarCrypt 0 message = message.
Proof.
  intros.
  induction message.
  - simpl. reflexivity.
  - inversion IHmessage.
    + simpl. rewrite H.
      Search (_ + 0). rewrite Nat.add_0_r.
      rewrite H. Search (ascii_of_nat (nat_of_ascii _)).
      rewrite ascii_nat_embedding. reflexivity.
Qed.

Lemma moduloDiff256_0_is_n :
  forall (n:nat),
  moduloDiff256 n 0 = n.
Proof.
  intros. induction n.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Lemma getAscii_0_is_n :
  forall (n:ascii),
  getAscii 0 n = n.
Proof.
  intros. unfold getAscii.
  simpl. Search(_ - 0). rewrite Nat.sub_0_r. rewrite ascii_nat_embedding. reflexivity.
Qed.

Lemma caesarDecrypt0 :
  forall (message:string),
  caesarDecrypt 0 message = message.
Proof.
  intros.
  induction message.
  - simpl. reflexivity.
  - simpl. rewrite getAscii_0_is_n. rewrite IHmessage. reflexivity.
Qed.

Theorem caesarBoolCorret:
  forall (message: string) (seed: nat),
  (String.eqb (caesarDecrypt seed (caesarCrypt seed message)) message) = true.
Proof.
intros.
induction seed.
  - rewrite caesarCrypt0. rewrite caesarDecrypt0. Search(String.eqb _ _).
    rewrite String.eqb_refl.
    reflexivity.
  -
Abort.

(*** Check proof for append in lists ***)
Lemma caesarCryptUnfold :
  forall (seed: nat) (m1: string) (m2:string),
  caesarCrypt seed (append m1 m2) =
  append (caesarCrypt seed m1) (caesarCrypt seed m2).
Proof.
  intros.
  induction m1.
  - simpl. reflexivity.
  - intros. simpl. rewrite <- IHm1. reflexivity.
Qed.

(*** Check proof for append in lists ***)
Lemma caesarDecryptUnfold :
  forall (seed: nat) (m1: string) (m2: string),
  caesarDecrypt seed (append m1 m2) =
  append (caesarDecrypt seed m1) (caesarDecrypt seed m2).
Proof.
  intros.
  induction m1.
  - simpl. reflexivity.
  - simpl. rewrite <- IHm1. reflexivity.
Qed.

Search (String _ _).
Lemma concatToAppend :
  forall (a:ascii) (s:string),
  String a s = append (String a EmptyString) s.
Proof.
  intros. simpl.
  reflexivity.
Qed.

Lemma getAsciiSimpl :
  forall (a: ascii) (seed: nat),
  getAscii seed (ascii_of_nat (nat_of_ascii a + seed)) = a.
Proof.
  intros. simpl.
  induction seed.
  - Search (_ + 0). rewrite Nat.add_0_r.
    Search (ascii_of_nat (nat_of_ascii _)). rewrite ascii_nat_embedding.
    unfold getAscii. simpl. Search (_ - 0). rewrite Nat.sub_0_r.
    rewrite ascii_nat_embedding. reflexivity.
  - Search (_ + S _). rewrite <- Nat.add_1_r. Search (_ + (_ + _)).
    rewrite Nat.add_assoc. unfold getAscii.
    destruct (seed + 1 <=? nat_of_ascii (ascii_of_nat (nat_of_ascii a + seed + 1))) eqn:H.
    + simpl.
Admitted.

Theorem caesarCorrect:
  forall (message: string) (seed: nat),
  (caesarDecrypt seed (caesarCrypt seed message)) = message.
Proof.
  intros.

  (** Caminho sobre seed **)
  induction seed.
  - rewrite caesarCrypt0. rewrite caesarDecrypt0. reflexivity.
  -

  (** Caminho sobre message **)
  induction message.
  - simpl. reflexivity.
  - rewrite concatToAppend. rewrite caesarCryptUnfold.
    rewrite caesarDecryptUnfold. rewrite IHmessage.
    Check IHmessage. Compute (String a EmptyString).
    simpl in IHmessage.
    (** remember (String a "") as message1.
    subst. **)
    assert(caesarDecrypt seed (caesarCrypt seed (String a "")) = String a ""). {
      unfold caesarCrypt. simpl. rewrite getAsciiSimpl. reflexivity.
    }
    rewrite H. reflexivity.
Qed.

(*** Extra: Proof for any symmetric encryption ***)
Fixpoint symmetricCrypt (seed : nat) (msg_toSend: string) : string.
Proof. Admitted.

Fixpoint symmetricDecript (seed : nat) (msg_received: string) : string.
Proof. Admitted.

(*** Extra: Proof for any symmetric encryption ***)

Theorem equalKeys :
    forall (private_k1:nat) (private_k2:nat) (gen:nat) (base:nat),
    (calculateSharedSeed private_k1
      (calculatePublicKey private_k2 base gen) base gen) =
    (calculateSharedSeed private_k2
      (calculatePublicKey private_k1 base gen) base gen).
Proof. Admitted.

Theorem DHCorrect:
    forall (message: string) (seed: nat),
    (symmetricDecript seed (symmetricCrypt seed message)) = message.
Proof. Admitted.

Theorem Encrypt_Complete:
    forall (message: string) (seed: nat), caesarCrypt seed message <> message.
Proof. Admitted.

(*** https://github.com/coq-contribs/rsa/blob/master/Rsa.v ***)

(*** Extras: Rationalize over DiffieHellman protocol implementations using
Protocol Composition Logic, as defined in this paper from stanford university:
http://seclab.stanford.edu/pcl/papers/rdm-tgc07.pdf ***)

Theorem decrypt0: forall (message:string), caesarDecrypt 0 message = message.
Proof.
intros.
induction message.
  - simpl. reflexivity.
  - simpl. unfold moduloDiff256.
rewrite Nat.sub_0_r. rewrite IHmessage. rewrite ascii_nat_embedding. reflexivity.
Qed.

Theorem Aux1: forall (a:ascii) (seed:nat), ascii_of_nat (nat_of_ascii a + S seed - S seed) = a. Admitted.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e444m17_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Util CSet Infra.PartialOrder Terminating Infra.Lattice SigR.

Remove Hints trans_eq_bool.

Set Implicit Arguments.

Instance PartialOrder_Subset_Equal X `{OrderedType X} : PartialOrder (set X) :=
{
  poLe := Subset;
  poLe_dec := @Subset_computable _ _;
  poEq := Equal;
  poEq_dec := @Equal_computable _ _
}.
Proof.
  - intros. rewrite H0; eauto.
  - hnf; intros. split; eauto.
Defined.

Instance set_var_semilattice X `{OrderedType X} : JoinSemiLattice (set X) := {
  join := union
}.
Proof.
  - hnf; intros. rewrite H0. rewrite union_idem. reflexivity.
  - hnf; intros. eapply union_comm.
  - hnf; intros. eapply union_assoc.
  - hnf; intros. eapply incl_left.
Defined.

Instance PartialOrder_Subset_Equal_Bounded X `{OrderedType X} U : PartialOrder ({ s : set X | s ⊆ U}) :=
{
  poLe := sig_R Subset;
  poLe_dec x y := _;
  poEq := sig_R Equal;
  poEq_dec x y := _;
}.
Proof.
  - intros [a ?] [b ?]; simpl. intros EQ. rewrite EQ. reflexivity.
  - hnf; intros [a ?] [b ?]; simpl; intros. split; eauto.
Defined.

Instance set_var_semilattice_bound X `{OrderedType X} U : JoinSemiLattice ({ s : set X | s ⊆ U}) := {
  join x y := exist _ (union (proj1_sig x) (proj1_sig y)) _
}.
Proof.
  - destruct x,y; simpl. cset_tac.
  - hnf; intros [a ?] [b ?]. simpl.
    unfold poLe; simpl. intros. rewrite H0, union_idem. reflexivity.
  - hnf; intros [a ?] [b ?]. eapply union_comm.
  - hnf; intros [a ?] [b ?] [c ?]. eapply union_assoc.
  - hnf; intros [a ?] [b ?]; simpl. eapply incl_left.
  - simpl. unfold Proper, respectful; intros.
    destruct x,y,x0,y0; unfold poEq in *; simpl in * |- *.
    rewrite H0, H1. reflexivity.
  - simpl. unfold Proper, respectful; intros.
    destruct x,y,x0,y0; unfold poLe in *; simpl in * |- *.
    rewrite H0, H1. reflexivity.
Defined.

Instance set_var_lower_bounded X `{OrderedType X} U : LowerBounded { s : set X | s ⊆ U} :=
  {
    bottom := exist _ ∅ _
  }.
Proof.
  - cset_tac.
  - simpl; intros []. hnf. cset_tac.
Defined.

Lemma bunded_set_terminating X `{OrderedType X} U
  : Terminating {s : ⦃X⦄ | s ⊆ U} poLt.
Proof.
  hnf; intros [s Incl].
  remember (cardinal (U \ s)). assert (cardinal (U \ s) <= n) as Le by omega.
  clear Heqn. revert s Incl Le. induction n; intros.
  - econstructor. intros [y ?] [A B]; simpl in *.
    exfalso. eapply B. assert (cardinal (U \ s) = 0) by omega.
    rewrite <- cardinal_Empty in H0.
    eapply empty_is_empty_1 in H0. eapply diff_subset_equal' in H0.
    unfold poLe in *; simpl in *.
    cset_tac.
  - intros. econstructor. intros [y ?] [A B]; simpl in *.
    eapply IHn. unfold poLe in *; simpl in *.
    edestruct not_incl_element; eauto; dcr.
    rewrite cardinal_difference'; eauto.
    rewrite cardinal_difference' in Le; eauto.
    erewrite (@cardinal_2 _ _ _ _ (y \ singleton x) y); eauto;
      [|cset_tac| rewrite Add_Equal; cset_tac; decide (x === a); eauto].
    assert (s ⊆ y \ singleton x) by cset_tac.
    eapply cardinal_morph in H0. omega.
Qed.


Require Import HoTT.
Require Import Auxiliary.Family.
Require Import Auxiliary.General.
Require Import Auxiliary.Coproduct.
Require Import Syntax.ScopeSystem.
Require Import Syntax.SyntacticClass.
Require Import Syntax.Arity.
Require Import Syntax.Signature.

Section Syntax.

  Context {σ : scope_system}.
  Context {Σ : signature σ}.

  (* A raw syntactic expression of a syntactic class, relative to a scope *)
  (** \cref{def:raw-syntax} *)
  Inductive raw_expression
    : syntactic_class -> σ -> Type
    :=
    (* a variable is a position in the context *)
    | raw_variable (γ : σ) (i : γ)
        : raw_expression class_term γ
    (* relative to a context [γ], given a symbol [S], if for each of its
       arguments we have a raw syntactic expression relative to [γ] extended by
       the argument's arity, [S args] is a raw syntactic expression over [γ] *)
    | raw_symbol (γ : σ) (S : Σ)
                 (args : forall (i : symbol_arity S),
                   raw_expression (argument_class i)
                                  (scope_sum γ (argument_scope i)))
      : raw_expression (symbol_class S) γ.

  Global Arguments raw_variable [_] _.
  Global Arguments raw_symbol [_] _ _.

  (** Convenient abbreviations, to improve readability of code. *)
  Definition raw_type := raw_expression class_type.
  Definition raw_term := raw_expression class_term.

  (* Supose [S] is a symbol whose arity is [a] and we would like to use [S]
     to form a raw expresssion. Then we have to provide arguments so that
     we can apply [S] to them. The following type describes these arguments. *)
  Definition arguments (a : arity σ) γ : Type
  := forall (i : a),
      raw_expression (argument_class i) (scope_sum γ (argument_scope i)).

  (* Useful, with [idpath] as the equality argument, when want wants to
     construct the smybol argument interactively — this is difficult with
     original [symb_raw] due to [class S] appearing in the conclusion. *)
  Definition raw_symbol'
      {γ} {cl} (S : Σ) (e : symbol_class S = cl)
      (args : arguments (symbol_arity S) γ)
    : raw_expression cl γ.
  Proof.
    refine (transport (fun cl => raw_expression cl _) e _).
    now apply raw_symbol.
  Defined.

End Syntax.

Global Arguments raw_expression {_} _ _ _.
Global Arguments raw_type {_} _ _.
Global Arguments raw_term {_} _ _.
Global Arguments arguments {_} _ _ _.

Section Renaming.

  Context {σ : scope_system} {Σ : signature σ}.

  (* General substitution will be defined in [Syntax.Substitution] below.
     Here we define the special case of substituting variables for variables.
     This already subsumes weakening, contraction, and exchange, and gives
     will be used to move under binders in general substitution.

     This can be seen as the functoriality of syntax in the scope argument. *)
  (** \cref{renaming-action} *)
  Fixpoint rename {γ γ' : σ} (f : γ -> γ')
      {cl : syntactic_class} (e : raw_expression Σ cl γ)
    : raw_expression Σ cl γ'.
  Proof.
    destruct e as [ γ i | γ S args ].
  - exact (raw_variable (f i)).
  - refine (raw_symbol S _). intros i.
    refine (rename _ _ _ _ (args i)).
    simple refine (coproduct_rect (scope_is_sum) _ _ _); cbn.
    + intros x. apply (coproduct_inj1 (scope_is_sum)). exact (f x).
    + intros x. apply (coproduct_inj2 (scope_is_sum)). exact x.
  Defined.

  (* Interaction between renaming and transport *)
  Definition transport_rename {γ γ' : σ} (g : γ -> γ')
      {cl cl' : syntactic_class} (p : cl = cl') (e : raw_expression Σ cl γ)
    : transport (fun cl => raw_expression Σ cl γ') p (rename g e)
      = rename g (transport (fun cl => raw_expression Σ cl γ) p e).
  Proof.
    destruct p. apply idpath.
  Defined.

  (* Functoriality properties of renaming variables *)
  Context `{H_Funext : Funext}.

  Lemma rename_idmap {γ} {cl} (e : raw_expression Σ cl γ)
    : rename idmap e = e.
  Proof.
    induction e as [ γ i | γ s es IH_es ].
    - apply idpath.
    - cbn. apply ap.
      apply path_forall; intros i.
      eapply concat.
      2: { apply IH_es. }
      apply (ap_2back rename), path_forall.
      refine (coproduct_rect scope_is_sum _ _ _).
      + intros j. refine (coproduct_comp_inj1 _).
      + intros j. refine (coproduct_comp_inj2 _).
  Defined.

  Fixpoint rename_rename {γ γ' γ'' : σ} (f : γ -> γ') (f' : γ' -> γ'')
      {cl : syntactic_class} (e : raw_expression Σ cl γ)
    : rename f' (rename f e) = rename (f' o f) e.
  Proof.
    destruct e as [ γ i | γ S args ].
  - reflexivity.
  - cbn. apply ap. apply path_forall; intros i.
    eapply concat. { apply rename_rename. }
    + apply (ap_2back rename), path_forall.
      refine (coproduct_rect _ _ _ _); intros x.
      * refine (_ @ _^). 2: { refine (coproduct_comp_inj1 _). }
        eapply concat. { apply ap. refine (coproduct_comp_inj1 _). }
        refine (coproduct_comp_inj1 _).
      * refine (_ @ _^). 2: { refine (coproduct_comp_inj2 _). }
        eapply concat. { apply ap. refine (coproduct_comp_inj2 _). }
        refine (coproduct_comp_inj2 _).
  Defined.

  (* [rename_rename] should be used as primitive for computing on expressions; this is a skin to show it as a functoriality property. *)
  Definition rename_comp {γ γ' γ'' : σ} (f : γ -> γ') (f' : γ' -> γ'')
      {cl : syntactic_class} (e : raw_expression Σ cl γ)
    : rename (f' o f) e = rename f' (rename f e).
  Proof.
    apply inverse, rename_rename.
  Defined.

End Renaming.

Global Arguments rename {_ _ _ _} _ {_} _.

(* Functoriality of expressions in signature maps *)
Section Signature_Maps.

  Context {σ : scope_system}.

  Local Definition fmap {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      {cl} {γ}
    : raw_expression Σ cl γ -> raw_expression Σ' cl γ.
  Proof.
    intros t. induction t as [ γ i | γ S ts fts].
    - exact (raw_variable i).
    - refine
        (transport (fun cl => raw_expression _ cl _) _ (raw_symbol (f S) _)).
      + exact (ap fst (Family.map_commutes _ _)).
      + refine (transport
          (fun a : arity σ => forall i : a,
            raw_expression _ (argument_class i) (_ (argument_scope i)))
          _ fts).
        exact ((ap snd (Family.map_commutes _ _))^).
  Defined.

  Global Arguments fmap : simpl nomatch.

  Context `{Funext}.

  Local Definition fmap_idmap {Σ} {cl} {γ} (e : raw_expression Σ cl γ)
    : fmap (Signature.idmap Σ) e = e.
  Proof.
    induction e as [ γ i | γ S e_args IH_e_args ].
     - apply idpath.
    - simpl. apply ap.
      apply path_forall; intros i.
      apply IH_e_args.
  Defined.

  Local Lemma fmap_transport
      {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      {cl cl'} (p : cl = cl') {γ} (e : raw_expression Σ cl γ)
    : fmap f (transport (fun cl => raw_expression _ cl _) p e)
      = transport (fun cl => raw_expression _ cl _) p (fmap f e).
  Proof.
    destruct p; apply idpath.
  Defined.

  Local Definition fmap_fmap
      {Σ Σ' Σ''} (f' : Signature.map Σ' Σ'') (f : Signature.map Σ Σ')
      {cl} {γ} (e : raw_expression Σ cl γ)
    : fmap f' (fmap f e) = fmap (Signature.compose f' f) e.
  Proof.
    induction e as [ γ i | γ S e_args IH ]; simpl.
    - apply idpath.
    - eapply concat. { apply fmap_transport. }
      simpl. eapply concat. { refine (transport_pp _ _ _ _)^. }
      eapply concat. { rapply @ap_1back.
                       refine (ap_pp fst _ _)^. }
      eapply concat.
      2: { rapply @ap_1back.
           apply ap, ap, inverse, ap_idmap. }
      apply ap, ap.
      (* Now that we are under the [raw_symbol], we can abstract and destruct
      the [map_commutes] equalities, and so eliminate the transports. *)
      set (ΣS := Σ S); set (ΣfS := Σ' (f S)); set (ΣffS := Σ'' (f' (f S))).
      change (Family.map_over_commutes f') with (Family.map_commutes f').
      change (Family.map_over_commutes f) with (Family.map_commutes f).
      set (p' := Family.map_commutes f' (f S) : ΣffS = ΣfS).
      set (p := Family.map_commutes f S : ΣfS = ΣS).
      (* unfold some functions that occur within implicit subterms,
      blocking folding: *)
      unfold Family.map_over_of_map, symbol_arity in *.
      fold p p' ΣffS ΣfS ΣS. fold ΣS in e_args, IH.
      clearbody p' p ΣS ΣfS ΣffS.
      destruct p, p'; simpl.
      apply path_forall; intros i. apply IH.
  Defined.

  Local Definition fmap_compose
      {Σ Σ' Σ''} (f' : Signature.map Σ' Σ'') (f : Signature.map Σ Σ')
      {cl} {γ} (e : raw_expression Σ cl γ)
    : fmap (Signature.compose f' f) e = fmap f' (fmap f e).
  Proof.
    apply inverse, fmap_fmap.
  Defined.

  (* Naturality of renaming variables w.r.t. functoriality in signature maps *)
  Fixpoint fmap_rename
      {Σ Σ' : signature σ} (f : Signature.map Σ Σ')
      {γ γ' : σ} (g : γ -> γ')
      {cl : syntactic_class} (e : raw_expression Σ cl γ)
    : fmap f (rename g e)
      = rename g (fmap f e).
  Proof.
    destruct e as [ γ i | γ S args ].
  - apply idpath.
  - simpl.
    eapply concat.
    { apply ap, ap, ap. apply path_forall; intros i. apply fmap_rename. }
    eapply concat.
    2: { apply transport_rename. }
    + apply ap. cbn. apply ap.
      set (ΣfS := Σ' (f S)). change (symbol_arity (f S)) with (snd ΣfS).
      set (p := Family.map_commutes f S : ΣfS = _). clearbody p ΣfS.
      revert p; apply inverse_sufficient; intros q.
      destruct q; apply idpath.
  Defined.
  (* NOTE: this proof was surprisingly difficult to write; it shows the kind of headaches caused by the appearance of equality in maps of signatures. *)

End Signature_Maps.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable pl_ : Universe -> Universe -> Prop.
Variable neq_ : Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable ep_ : Universe -> Universe -> Prop.
Variable el_ : Universe -> Universe -> Prop.
Variable dom_ : Universe -> Prop.

Variable d_ : Universe.
Variable c_ : Universe.
Variable b_ : Universe.
Variable a_ : Universe.

Variable initial_model_1 : (dom_ a_ /\ (dom_ b_ /\ (dom_ c_ /\ (dom_ d_ /\ (ep_ a_ a_ /\ (ep_ b_ b_ /\ (ep_ c_ c_ /\ (ep_ d_ d_ /\ (neq_ a_ b_ /\ (neq_ a_ c_ /\ (neq_ a_ d_ /\ (neq_ b_ c_ /\ (neq_ b_ d_ /\ neq_ c_ d_))))))))))))).
Variable goal_ax_2 : (forall L X Y Z : Universe, ((el_ L L /\ (neq_ X Y /\ (neq_ Y Z /\ (neq_ X Z /\ (pl_ X L /\ (pl_ Y L /\ pl_ Z L)))))) -> goal_)).
Variable pref_3 : (forall P L : Universe, (pl_ P L -> ep_ P P)).
Variable psym_4 : (forall P Q : Universe, (ep_ P Q -> ep_ Q P)).
Variable ptra_5 : (forall P Q R : Universe, ((ep_ P Q /\ ep_ Q R) -> ep_ P R)).
Variable pneq_6 : (forall P Q : Universe, ((ep_ P Q /\ neq_ P Q) -> goal_)).
Variable sneq_7 : (forall P Q : Universe, (neq_ P Q -> neq_ Q P)).
Variable pdec_8 : (forall P Q : Universe, ((ep_ P P /\ ep_ Q Q) -> (ep_ P Q \/ neq_ P Q))).
Variable lref_9 : (forall P L : Universe, (pl_ P L -> el_ L L)).
Variable lsym_10 : (forall L M : Universe, (el_ L M -> el_ M L)).
Variable ltra_11 : (forall L M N : Universe, ((el_ L M /\ el_ M N) -> el_ L N)).
Variable pcon_12 : (forall P Q L : Universe, ((ep_ P Q /\ pl_ Q L) -> pl_ P L)).
Variable lcon_13 : (forall P L M : Universe, ((pl_ P L /\ el_ L M) -> pl_ P M)).
Variable unique_14 : (forall P L M Q : Universe, ((pl_ P L /\ (pl_ P M /\ (pl_ Q L /\ pl_ Q M))) -> (ep_ P Q \/ el_ L M))).
Variable line_15 : (forall P Q : Universe, ((ep_ P P /\ ep_ Q Q) -> (exists L : Universe, (dom_ L /\ (pl_ P L /\ pl_ Q L))))).
Variable point_16 : (forall L M : Universe, ((el_ L L /\ el_ M M) -> (exists P : Universe, (dom_ P /\ (pl_ P L /\ pl_ P M))))).

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

End FOFProblem.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrbool ssrfun eqtype ssrnat fintype bigop finset.
From mathcomp
Require Import fingroup morphism automorphism quotient gproduct.

(******************************************************************************)
(*   This file provides basic interfaces for the notion of "generic"          *)
(* characteristic subgroups; these amount to subfunctors of the identity      *)
(* functor in some category of groups.                                        *)
(* See "Generic Proof Tools And Finite Group Theory",                         *)
(* Francois Garillot, PhD, 2011, Chapter 3.                                   *)
(* The implementation proposed here is fairly basic, relying on first order   *)
(* function matching and on structure telescopes, both of which are somewhat  *)
(* limited and fragile. It should switch in the future to more general and    *)
(* more robust quotation matching.                                            *)
(*   The definitions in this file (types, properties and structures) are all  *)
(* packaged under the GFunctor submodule, i.e., client code should refer to   *)
(* GFunctor.continuous, GFunctor.map, etc. Notations, Coercions and Lemmas    *)
(* are exported and thus directly available, however.                         *)
(*   We provide the following:                                                *)
(*      object_map == the type of the (polymorphic) object map of a group     *)
(*                    functor; the %gF scope is bound to object_map.          *)
(*                 := forall gT : finGroupType, {set gT} -> {set gT}.         *)
(*  We define two operations on object_map (with notations in the %gF scope): *)
(*        F1 \o F2 == the composite map; (F1 \o F2) G expands to F1 (F2 G).   *)
(*        F1 %% F2 == F1 computed modulo F2; we have                          *)
(*                    (F1 %% F2) G / F2 G = F1 (G / F2 G)                     *)
(* We define the following (type-polymorphic) properties of an object_map F:  *)
(*     group_valued F <-> F G is a group when G is a group                    *)
(*           closed F <-> F G is a subgroup o fG when G is a group            *)
(*       continuous F <-> F is continuous with respect to morphism image:     *)
(*                        for any f : {morphism G >-> ..}, f @* (F G) is a    *)
(*                        a subgroup of F (f @* G); equivalently, F is        *)
(*                        functorial in the category Grp of groups.           *)
(*                        Most common "characteristic subgroup" are produced  *)
(*                        continuous object maps.                             *)
(*   iso_continuous F <-> F is continuous with respect to isomorphism image;  *)
(*                        equivalently, F is functorial in the Grp groupoid.  *)
(*                        The Puig and the Thompson J subgroups are examples  *)
(*                        of iso_continuous maps that are not continuous.     *)
(*      pcontinuous F <-> F is continuous with respect to partial morphism    *)
(*                        image, i.e., functorial in the category of groups   *)
(*                        and partial morphisms. The center and p-core are    *)
(*                        examples of pcontinuous maps.                       *)
(*       hereditary F <-> inclusion in the image of F is hereditary, i.e.,    *)
(*                        for any subgroup H of G, the intersection of H with *)
(*                        F G is included in H. Note that F is pcontinuous    *)
(*                        iff it is continuous and hereditary; indeed proofs  *)
(*                        of pcontinuous F coerce to proofs of hereditary F   *)
(*                        and continuous F.                                   *)
(*        monotonic F <-> F is monotonic with respect to inclusion: for any   *)
(*                        subgroup H of G, F H is a subgroup of F G. The      *)
(*                        derived and lower central series are examples of    *)
(*                        monotonic maps.                                     *)
(* Four structures provide interfaces to these properties:                    *)
(*    GFunctor.iso_map == structure for object maps that are group_valued,    *)
(*                        closed, and iso_continuous.                         *)
(*  [igFun by Fsub & !Fcont] == the iso_map structure for an object map F     *)
(*                        such that F G is canonically a group when G is, and *)
(*                        given Fsub : closed F and Fcont : iso_continuous F. *)
(*  [igFun by Fsub & Fcont] == as above, but expecting Fcont : continuous F.  *)
(*        [igFun of F] == clone an existing GFunctor.iso_map structure for F. *)
(*        GFunctor.map == structure for continuous object maps, inheriting    *)
(*                        from the GFunctor.iso_map structure.                *)
(*     [gFun by Fcont] == the map structure for an F with a canonical iso_map *)
(*                        structure, given Fcont : continuous F.              *)
(*         [gFun of F] == clone an existing GFunctor.map structure for F.     *)
(*       GFunctor.pmap == structure for pcontinuous object maps, inheriting   *)
(*                        from the GFunctor.map structure.                    *)
(*    [pgFun by Fher] == the pmap structure for an F with a canonical map     *)
(*                        structure, given Fher : hereditary F.               *)
(*        [pgFun of F] == clone an existing GFunctor.pmap structure for F.    *)
(*   GFunctor.mono_map == structure for monotonic, continuous object maps     *)
(*                        inheriting from the GFunctor.map structure.         *)
(*     [mgFun by Fmon] == the mono_map structure for an F with a canonical    *)
(*                        map structure, given Fmon : monotonic F.            *)
(*        [mgFun of F] == clone an existing GFunctor.mono_map structure for F *)
(* Lemmas for these group functors use either a 'gF' prefix or an 'F' suffix. *)
(* The (F1 \o F2) and (F1 %% F2) operations have canonical GFunctor.map       *)
(* structures when F1 is monotonic or hereditary, respectively.               *)
(******************************************************************************)

Import GroupScope.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Delimit Scope gFun_scope with gF.

Module GFunctor.

Definition object_map := forall gT : finGroupType, {set gT} -> {set gT}.

Bind Scope gFun_scope with object_map.

Section Definitions.

Implicit Types gT hT : finGroupType.

Variable F : object_map.

(* Group closure. *)
Definition group_valued := forall gT (G : {group gT}), group_set (F G).

(* Subgroup closure. *)
Definition closed := forall gT (G : {group gT}), F G \subset G.

(* General functoriality, i.e., continuity of the object map *)
Definition continuous :=
  forall gT hT (G : {group gT}) (phi : {morphism G >-> hT}),
    phi @* F G \subset F (phi @* G).

(* Functoriality on the Grp groupoid (arrows are restricted to isos). *)
Definition iso_continuous :=
  forall gT hT (G : {group gT}) (phi : {morphism G >-> hT}),
   'injm phi -> phi @* F G \subset F (phi @* G).

Lemma continuous_is_iso_continuous : continuous -> iso_continuous.
Proof. by move=> Fcont gT hT G phi inj_phi; apply: Fcont. Qed.

(* Functoriality on Grp with partial morphisms. *)
Definition pcontinuous :=
  forall gT hT (G D : {group gT}) (phi : {morphism D >-> hT}),
    phi @* F G \subset F (phi @* G).

Lemma pcontinuous_is_continuous : pcontinuous -> continuous.
Proof. by move=> Fcont gT hT G; apply: Fcont. Qed.

(* Heredity with respect to inclusion *)
Definition hereditary :=
  forall gT (H G : {group gT}), H \subset G -> F G :&: H \subset F H.

Lemma pcontinuous_is_hereditary : pcontinuous -> hereditary.
Proof.
move=> Fcont gT H G sHG; rewrite -{2}(setIidPl sHG) setIC.
by do 2!rewrite -(morphim_idm (subsetIl H _)) morphimIdom ?Fcont.
Qed.

(* Monotonicity with respect to inclusion *)
Definition monotonic :=
  forall gT (H G : {group gT}), H \subset G -> F H \subset F G.

(* Self-expanding composition, and modulo *)

Variables (k : unit) (F1 F2 : object_map).

Definition comp_head : object_map := fun gT A => let: tt := k in F1 (F2 A).

Definition modulo : object_map :=
  fun gT A => coset (F2 A) @*^-1 (F1 (A / (F2 A))).

End Definitions.

Section ClassDefinitions.

Structure iso_map := IsoMap {
  apply : object_map;
  _ : group_valued apply;
  _ : closed apply;
  _ : iso_continuous apply
}.
Local Coercion apply : iso_map >-> object_map.

Structure map := Map { iso_of_map : iso_map; _ : continuous iso_of_map }.
Local Coercion iso_of_map : map >-> iso_map.

Structure pmap := Pmap { map_of_pmap : map; _ : hereditary map_of_pmap }.
Local Coercion map_of_pmap : pmap >-> map.

Structure mono_map := MonoMap { map_of_mono : map; _ : monotonic map_of_mono }.
Local Coercion map_of_mono : mono_map >-> map.

Definition pack_iso F Fcont Fgrp Fsub := @IsoMap F Fgrp Fsub Fcont.

Definition clone_iso (F : object_map) :=
  fun Fgrp Fsub Fcont (isoF := @IsoMap F Fgrp Fsub Fcont) =>
  fun isoF0 & phant_id (apply isoF0) F & phant_id isoF isoF0 => isoF.

Definition clone (F : object_map) :=
  fun isoF & phant_id (apply isoF) F =>
  fun (funF0 : map) & phant_id (apply funF0) F =>
  fun Fcont (funF := @Map isoF Fcont) & phant_id funF0 funF => funF.

Definition clone_pmap (F : object_map) :=
  fun (funF : map) & phant_id (apply funF) F =>
  fun (pfunF0 : pmap) & phant_id (apply pfunF0) F =>
  fun Fher (pfunF := @Pmap funF Fher) & phant_id pfunF0 pfunF => pfunF.

Definition clone_mono (F : object_map) :=
  fun (funF : map) & phant_id (apply funF) F =>
  fun (mfunF0 : mono_map) & phant_id (apply mfunF0) F =>
  fun Fmon (mfunF := @MonoMap funF Fmon) & phant_id mfunF0 mfunF => mfunF.

End ClassDefinitions.

Module Exports.

Identity Coercion fun_of_object_map : object_map >-> Funclass.
Coercion apply : iso_map >-> object_map.
Coercion iso_of_map : map >-> iso_map.
Coercion map_of_pmap : pmap >-> map.
Coercion map_of_mono : mono_map >-> map.
Coercion continuous_is_iso_continuous : continuous >-> iso_continuous.
Coercion pcontinuous_is_continuous : pcontinuous >-> continuous.
Coercion pcontinuous_is_hereditary : pcontinuous >-> hereditary.

Notation "[ 'igFun' 'by' Fsub & Fcont ]" :=
    (pack_iso (continuous_is_iso_continuous Fcont) (fun gT G => groupP _) Fsub)
  (at level 0, format "[ 'igFun'  'by'  Fsub  &  Fcont ]") : form_scope.

Notation "[ 'igFun' 'by' Fsub & ! Fcont ]" :=
    (pack_iso Fcont (fun gT G => groupP _) Fsub)
  (at level 0, format "[ 'igFun'  'by'  Fsub  &  ! Fcont ]") : form_scope.

Notation "[ 'igFun' 'of' F ]" := (@clone_iso F _ _ _ _ id id)
  (at level 0, format "[ 'igFun'  'of'  F ]") : form_scope.

Notation "[ 'gFun' 'by' Fcont ]" := (Map Fcont)
  (at level 0, format "[ 'gFun'  'by'  Fcont ]") : form_scope.

Notation "[ 'gFun' 'of' F ]" := (@clone F _ id _ id _ id)
  (at level 0, format "[ 'gFun'  'of'  F ]") : form_scope.

Notation "[ 'pgFun' 'by' Fher ]" := (Pmap Fher)
  (at level 0, format "[ 'pgFun'  'by'  Fher ]") : form_scope.

Notation "[ 'pgFun' 'of' F ]" := (@clone_pmap F _ id _ id _ id)
  (at level 0, format "[ 'pgFun' 'of'  F ]") : form_scope.

Notation "[ 'mgFun' 'by' Fmon ]" := (MonoMap Fmon)
  (at level 0, format "[ 'mgFun'  'by'  Fmon ]") : form_scope.

Notation "[ 'mgFun' 'of' F ]" := (@clone_mono F _ id _ id _ id)
  (at level 0, format "[ 'mgFun' 'of'  F ]") : form_scope.

End Exports.

End GFunctor.
Export GFunctor.Exports.

Bind Scope gFun_scope with GFunctor.object_map.

Notation "F1 \o F2" := (GFunctor.comp_head tt F1 F2) : gFun_scope.
Notation "F1 %% F2" := (GFunctor.modulo F1 F2) : gFun_scope.

Section FunctorGroup.

Variables (F : GFunctor.iso_map) (gT : finGroupType) (G : {group gT}).
Lemma gFgroupset : group_set (F gT G). Proof. by case: F. Qed.
Canonical gFgroup := Group gFgroupset.

End FunctorGroup.

Canonical gFmod_group
    (F1 : GFunctor.iso_map) (F2 : GFunctor.object_map)
    (gT : finGroupType) (G : {group gT}) :=
  [group of (F1 %% F2)%gF gT G].

Section IsoFunctorTheory.

Implicit Types gT rT : finGroupType.
Variable F : GFunctor.iso_map.

Lemma gFsub gT (G : {group gT}) : F gT G \subset G.
Proof. by case: F gT G. Qed.

Lemma gFsub_trans gT (G : {group gT}) (A : pred_class) :
  G \subset A -> F gT G \subset A.
Proof. exact/subset_trans/gFsub. Qed.

Lemma gF1 gT : F gT 1 = 1. Proof. exact/trivgP/gFsub. Qed.

Lemma gFiso_cont : GFunctor.iso_continuous F.
Proof. by case F. Qed.

Lemma gFchar gT (G : {group gT}) : F gT G \char G.
Proof.
apply/andP; split => //; first by apply: gFsub.
apply/forall_inP=> f Af; rewrite -{2}(im_autm Af) -(autmE Af).
by rewrite -morphimEsub ?gFsub ?gFiso_cont ?injm_autm.
Qed.

Lemma gFnorm gT (G : {group gT}) : G \subset 'N(F gT G).
Proof. exact/char_norm/gFchar. Qed.

Lemma gFnorms gT (G : {group gT}) : 'N(G) \subset 'N(F gT G).
Proof. exact/char_norms/gFchar. Qed.

Lemma gFnormal gT (G : {group gT}) : F gT G <| G.
Proof. exact/char_normal/gFchar. Qed.

Lemma gFchar_trans gT (G H : {group gT}) : H \char G -> F gT H \char G.
Proof. exact/char_trans/gFchar. Qed.

Lemma gFnormal_trans gT (G H : {group gT}) : H <| G -> F gT H <| G.
Proof. exact/char_normal_trans/gFchar. Qed.

Lemma gFnorm_trans gT (A : pred_class) (G : {group gT}) :
  A \subset 'N(G) -> A \subset 'N(F gT G).
Proof. by move/subset_trans/(_ (gFnorms G)). Qed.

Lemma injmF_sub gT rT (G D : {group gT}) (f : {morphism D >-> rT}) :
  'injm f -> G \subset D -> f @* (F gT G) \subset F rT (f @* G).
Proof.
move=> injf sGD; have:= gFiso_cont (injm_restrm sGD injf).
by rewrite im_restrm morphim_restrm (setIidPr _) ?gFsub.
Qed.

Lemma injmF gT rT (G D : {group gT}) (f : {morphism D >-> rT}) :
  'injm f -> G \subset D -> f @* (F gT G) = F rT (f @* G).
Proof.
move=> injf sGD; have [sfGD injf'] := (morphimS f sGD, injm_invm injf).
apply/esym/eqP; rewrite eqEsubset -(injmSK injf') ?gFsub_trans //.
by rewrite !(subset_trans (injmF_sub _ _)) ?morphim_invm // gFsub_trans.
Qed.

Lemma gFisom gT rT (G D : {group gT}) R (f : {morphism D >-> rT}) :
  G \subset D -> isom G (gval R) f -> isom (F gT G) (F rT R) f.
Proof.
case/(restrmP f)=> g [gf _ _ _]; rewrite -{f}gf => /isomP[injg <-].
by rewrite sub_isom ?gFsub ?injmF.
Qed.

Lemma gFisog gT rT (G : {group gT}) (R : {group rT}) :
  G \isog R -> F gT G \isog F rT R.
Proof. by case/isogP=> f injf <-; rewrite -injmF // sub_isog ?gFsub. Qed.

End IsoFunctorTheory.

Section FunctorTheory.

Implicit Types gT rT : finGroupType.
Variable F : GFunctor.map.

Lemma gFcont : GFunctor.continuous F.
Proof. by case F. Qed.

Lemma morphimF gT rT (G D : {group gT}) (f : {morphism D >-> rT}) :
  G \subset D -> f @* (F gT G) \subset F rT (f @* G).
Proof.
move=> sGD; rewrite -(setIidPr (gFsub F G)).
by rewrite -{3}(setIid G) -!(morphim_restrm sGD) gFcont.
Qed.

End FunctorTheory.

Section PartialFunctorTheory.

Implicit Types gT rT : finGroupType.

Section BasicTheory.

Variable F : GFunctor.pmap.

Lemma gFhereditary : GFunctor.hereditary F.
Proof. by case F. Qed.

Lemma gFunctorI gT (G H : {group gT}) :
  F gT G :&: H = F gT G :&: F gT (G :&: H).
Proof.
rewrite -{1}(setIidPr (gFsub F G)) [G :&: _]setIC -setIA.
rewrite -(setIidPr (gFhereditary (subsetIl G H))).
by rewrite setIC -setIA (setIidPr (gFsub F (G :&: H))).
Qed.

Lemma pmorphimF : GFunctor.pcontinuous F.
Proof.
move=> gT rT G D f; rewrite -morphimIdom -(setIidPl (gFsub F G)) setICA.
apply: (subset_trans (morphimS f (gFhereditary (subsetIr D G)))).
by rewrite (subset_trans (morphimF F _ _ )) ?morphimIdom ?subsetIl.
Qed.

Lemma gFid gT (G : {group gT}) : F gT (F gT G)  = F gT G.
Proof.
apply/eqP; rewrite eqEsubset gFsub.
by move/gFhereditary: (gFsub F G); rewrite setIid /=.
Qed.

End BasicTheory.

Section Modulo.

Variables (F1 : GFunctor.pmap) (F2 : GFunctor.map).

Lemma gFmod_closed : GFunctor.closed (F1 %% F2).
Proof. by move=> gT G; rewrite sub_cosetpre_quo ?gFsub ?gFnormal. Qed.

Lemma gFmod_cont : GFunctor.continuous (F1 %% F2).
Proof.
move=> gT rT G f; have nF2 := gFnorm F2.
have sDF: G \subset 'dom (coset (F2 _ G)) by rewrite nF2.
have sDFf: G \subset 'dom (coset (F2 _ (f @* G)) \o f).
  by rewrite -sub_morphim_pre ?subsetIl // nF2.
pose K := 'ker (restrm sDFf (coset (F2 _ (f @* G)) \o f)).
have sFK: 'ker (restrm sDF (coset (F2 _ G))) \subset K.
  rewrite {}/K !ker_restrm ker_comp /= subsetI subsetIl !ker_coset /=.
  by rewrite -sub_morphim_pre ?subsetIl // morphimIdom ?morphimF.
have sOF := gFsub F1 (G / F2 _ G); have sGG: G \subset G by [].
rewrite -sub_quotient_pre; last first.
  by apply: subset_trans (nF2 _ _); rewrite morphimS ?gFmod_closed.
suffices im_fact H : F2 _ G \subset gval H -> H \subset G ->
  factm sFK sGG @* (H / F2 _ G) = f @* H / F2 _ (f @* G).
- rewrite -2?im_fact ?gFmod_closed ?gFsub //.
    by rewrite cosetpreK morphimF /= ?morphim_restrm ?setIid.
  by rewrite -sub_quotient_pre ?normG //= trivg_quotient sub1G.
move=> sFH sHG; rewrite -(morphimIdom _ (H / _)) /= {2}morphim_restrm setIid.
rewrite -morphimIG ?ker_coset // -(morphim_restrm sDF) morphim_factm.
by rewrite morphim_restrm morphim_comp -quotientE morphimIdom.
Qed.

Canonical gFmod_igFun := [igFun by gFmod_closed & gFmod_cont].
Canonical gFmod_gFun := [gFun by gFmod_cont].

End Modulo.

Variables F1 F2 : GFunctor.pmap.

Lemma gFmod_hereditary : GFunctor.hereditary (F1 %% F2).
Proof.
move=> gT H G sHG; set FGH := _ :&: H; have nF2H := gFnorm F2 H.
rewrite -sub_quotient_pre; last exact: subset_trans (subsetIr _ _) _.
pose rH := restrm nF2H (coset (F2 _ H)); pose rHM := [morphism of rH].
have rnorm_simpl: rHM @* H = H / F2 _ H by rewrite morphim_restrm setIid.
have nF2G := subset_trans sHG (gFnorm F2 G).
pose rG := restrm nF2G (coset (F2 _ G)); pose rGM := [morphism of rG].
have sqKfK: 'ker rGM \subset 'ker rHM.
  rewrite !ker_restrm !ker_coset (setIidPr (gFsub F2 _)) setIC /=.
  exact: gFhereditary.
have sHH := subxx H; rewrite -rnorm_simpl /= -(morphim_factm sqKfK sHH) /=.
apply: subset_trans (gFcont F1 _); rewrite /= {2}morphim_restrm setIid /=.
apply: subset_trans (morphimS _ (gFhereditary _ (quotientS _ sHG))) => /=.
have ->: FGH / _ = restrm nF2H (coset _) @* FGH.
  by rewrite morphim_restrm setICA setIid.
rewrite -(morphim_factm sqKfK sHH) morphimS //= morphim_restrm -quotientE.
by rewrite setICA setIid (subset_trans (quotientI _ _ _)) // cosetpreK.
Qed.

Canonical gFmod_pgFun := [pgFun by gFmod_hereditary].

End PartialFunctorTheory.

Section MonotonicFunctorTheory.

Implicit Types gT rT : finGroupType.

Lemma gFunctorS (F : GFunctor.mono_map) : GFunctor.monotonic F.
Proof. by case: F. Qed.

Section Composition.

Variables (F1 : GFunctor.mono_map) (F2 : GFunctor.map).

Lemma gFcomp_closed : GFunctor.closed (F1 \o F2).
Proof. by move=> gT G; rewrite !gFsub_trans. Qed.

Lemma gFcomp_cont : GFunctor.continuous (F1 \o F2).
Proof.
move=> gT rT G phi; rewrite (subset_trans (morphimF _ _ (gFsub _ _))) //.
by rewrite (subset_trans (gFunctorS F1 (gFcont F2 phi))).
Qed.

Canonical gFcomp_igFun := [igFun by gFcomp_closed & gFcomp_cont].
Canonical gFcomp_gFun :=[gFun by gFcomp_cont].

End Composition.

Variables F1 F2 : GFunctor.mono_map.

Lemma gFcompS : GFunctor.monotonic (F1 \o F2).
Proof. by move=> gT H G sHG; rewrite !gFunctorS. Qed.

Canonical gFcomp_mgFun := [mgFun by gFcompS].

End MonotonicFunctorTheory.

Section GFunctorExamples.

Implicit Types gT : finGroupType.

Definition idGfun gT := @id {set gT}.

Lemma idGfun_closed : GFunctor.closed idGfun. Proof. by []. Qed.
Lemma idGfun_cont : GFunctor.continuous idGfun. Proof. by []. Qed.
Lemma idGfun_monotonic : GFunctor.monotonic idGfun. Proof. by []. Qed.

Canonical bgFunc_id := [igFun by idGfun_closed & idGfun_cont].
Canonical gFunc_id := [gFun by idGfun_cont].
Canonical mgFunc_id := [mgFun by idGfun_monotonic].

Definition trivGfun gT of {set gT} := [1 gT].

Lemma trivGfun_cont : GFunctor.pcontinuous trivGfun.
Proof. by move=> gT rT D G f; rewrite morphim1. Qed.

Canonical trivGfun_igFun := [igFun by sub1G & trivGfun_cont].
Canonical trivGfun_gFun := [gFun by trivGfun_cont].
Canonical trivGfun_pgFun := [pgFun by trivGfun_cont].

End GFunctorExamples.