Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.job prosa.classic.model.priority prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.model.schedule.uni.schedule.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module Platform.

  Import Job SporadicTaskset UniprocessorSchedule Priority.

  (* In this section, we define properties of the processor platform. *)
  Section Properties.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Consider any job arrival sequence ...*)
    Variable arr_seq: arrival_sequence Job.

    (* ...and any uniprocessor schedule of these jobs. *)
    Variable sched: schedule Job.

    (* First, we define properties related to execution. *)
    Section Execution.

      (* We say that a scheduler is work-conserving iff whenever a job j
         is backlogged, the processor is always busy with another job. *)
      Definition work_conserving :=
        forall j t,
          arrives_in arr_seq j ->
          backlogged job_arrival job_cost sched j t ->
          exists j_other, scheduled_at sched j_other t.

    End Execution.

    (* Next, we define properties related to FP scheduling. *)
    Section FP.

      (* We say that an FP policy...*)
      Variable higher_eq_priority: FP_policy sporadic_task.

      (* ...is respected by the schedule iff a scheduled task has
         higher (or same) priority than (as) any backlogged task. *)
      Definition respects_FP_policy :=
        forall j j_hp t,
          arrives_in arr_seq j ->
          backlogged job_arrival job_cost sched j t ->
          scheduled_at sched j_hp t ->
          higher_eq_priority (job_task j_hp) (job_task j).

    End FP.

    (* Next, we define properties related to JLFP policies. *)
    Section JLFP.

      (* We say that a JLFP policy ...*)
      Variable higher_eq_priority: JLFP_policy Job.

      (* ... is respected by the scheduler iff a scheduled job has
         higher (or same) priority than (as) any backlogged job. *)
      Definition respects_JLFP_policy :=
        forall j j_hp t,
          arrives_in arr_seq j ->
          backlogged job_arrival job_cost sched j t ->
          scheduled_at sched j_hp t ->
          higher_eq_priority j_hp j.

    End JLFP.

    (* Next, we define properties related to JLDP policies. *)
    Section JLDP.

      (* We say that a JLFP/JLDP policy ...*)
      Variable higher_eq_priority: JLDP_policy Job.

      (* ... is respected by the scheduler iff at any time t, a scheduled job
         has higher (or same) priority than (as) any backlogged job. *)
      Definition respects_JLDP_policy :=
        forall j j_hp t,
          arrives_in arr_seq j ->
          backlogged job_arrival job_cost sched j t ->
          scheduled_at sched j_hp t ->
          higher_eq_priority t j_hp j.

    End JLDP.

  End Properties.

  (* In this section, we prove some lemmas about the processor platform. *)
  Section Lemmas.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Consider any job arrival sequence ...*)
    Variable arr_seq: arrival_sequence Job.

    (* ...and any uniprocessor schedule of these jobs. *)
    Variable sched: schedule Job.

    (* For simplicity, let's define some local names. *)
    Let job_backlogged_at := backlogged job_arrival job_cost sched.
    Let job_pending_at := pending job_arrival job_cost sched.
    Let job_completed_by := completed_by job_cost sched.

    (* First we prove that if a job is never backlogged, then it doesn't take longer
       than its actual cost to complete. *)
    Section JobNeverBacklogged.

      (* Assume that jobs only execute after they arrive and no longer
         than their execution costs. *)
      Hypothesis H_jobs_must_arrive_to_execute:
        jobs_must_arrive_to_execute job_arrival sched.
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.

      (* Assume that the schedule is work-conserving. *)
      Hypothesis H_work_conserving: work_conserving job_arrival job_cost arr_seq sched.

      (* Let j be any job... *)
      Variable j: Job.

      (* ...that j is never backlogged during its execution. *)
      Hypothesis H_j_is_never_backlogged:
        forall t,
          job_arrival j <= t < job_arrival j + job_cost j ->
          ~ job_backlogged_at j t.

      (* Then, any response-time bound no smaller than the job cost is safe. *)
      Lemma job_never_backlogged_response_time_holds:
        forall R,
          R >= job_cost j ->
          job_completed_by j (job_arrival j + R).
      Proof.
        rename H_j_is_never_backlogged into NEVER,
               H_work_conserving into WORK.
        intros R GECOST.
        rewrite /job_completed_by /completed_by /service /service_during.
        rewrite (ignore_service_before_arrival job_arrival);
          [ | by done | by done | by apply leq_addr].
        apply leq_trans with (n := \sum_(job_arrival j <= t < job_arrival j + job_cost j) 1);
          first by simpl_sum_const; rewrite addKn leqnn.
        apply leq_trans with (n := \sum_(job_arrival j <= t < job_arrival j + job_cost j)
                                      service_at sched j t);
          last by apply extend_sum; rewrite // leq_add2l.
        apply leq_sum_nat; move => t /andP [GEt LTt] _.
        rewrite lt0n eqb0; apply/negP; intro NOTSCHED.
        have BACK := NEVER t; feed BACK.
        {
          apply/andP; split; first by done.
          by apply leq_trans with (n := job_arrival j + job_cost j);
            [by done | by rewrite leq_add2l].
        }
        apply BACK; apply/andP; split; last by done.
        apply/andP; split; first by done.
        rewrite -ltnNge.
        rewrite /service /service_during.
        rewrite -> big_cat_nat with (n := job_arrival j);
          [simpl | by done | by done].
        rewrite (cumulative_service_before_job_arrival_zero job_arrival);
          [rewrite add0n | by done | by apply leqnn].
        apply leq_ltn_trans with (n := \sum_(job_arrival j <= i < t) 1);
          first by apply leq_sum; ins; apply leq_b1.
        simpl_sum_const; rewrite -(ltn_add2r 1).
        rewrite [job_cost j + 1]addn1 ltnS.
        by rewrite subh1 // leq_subLR addn1.
      Qed.

    End JobNeverBacklogged.

  End Lemmas.

End Platform.


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

The category of elements of a functor "F : C ⟶ HSET"

Contents:

- Category of elements ([cat_of_elems])
- Functoriality of the constructon of the category of elements
  ([cat_of_elems_on_nat_trans])
- The forgetful functor from the category of elements to C
  ([cat_of_elems_forgetful])

Originally written by: Dan Grayson
Ported to CT by: Anders Mörtberg

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

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Univalence.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Examples.

Local Open Scope cat.

Definition pointed_sets
  : category
  := total_category elements_universal.

Definition is_univalent_disp_elements_universal
  : is_univalent_disp elements_universal.
Proof.
  use is_univalent_disp_from_fibers.
  intros X x₁ x₂.
  use isweqimplimpl.
  - exact (λ p, pr1 p).
  - apply X.
  - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)).
    + apply X.
    + apply isaprop_is_z_iso_disp.
Qed.

Definition is_univalent_pointed_sets
  : is_univalent pointed_sets.
Proof.
  use is_univalent_total_category.
  - apply is_univalent_HSET.
  - exact is_univalent_disp_elements_universal.
Defined.

Definition pointed_sets_univalent
  : univalent_category.
Proof.
  use make_univalent_category.
  - exact pointed_sets.
  - exact is_univalent_pointed_sets.
Defined.

Definition set_of_pointed_set
  : pointed_sets_univalent ⟶ HSET_univalent_category
  := pr1_category elements_universal.

Definition is_z_iso_pointed_sets
           {X Y : pointed_sets}
           (f : X --> Y)
           (Hf : is_z_isomorphism (pr1 f))
  : is_z_isomorphism f.
Proof.
  use tpair.
  - simple refine (_ ,, _).
    + exact (inv_from_z_iso (make_z_iso' _ Hf)).
    + abstract
        (cbn ;
         pose (pr2 f) as p ;
         cbn in p ;
         rewrite <- p ;
         exact (eqtohomot (z_iso_inv_after_z_iso (make_z_iso' _ Hf)) (pr2 X))).
  - split.
    + abstract
        (use subtypePath ; [ intro ; apply (pr1 X) | ] ;
         exact (z_iso_inv_after_z_iso (make_z_iso' _ Hf))).
    + abstract
        (use subtypePath ; [ intro ; apply (pr1 Y) | ] ;
         exact (z_iso_after_z_iso_inv (make_z_iso' _ Hf))).
Defined.

Section CategoryOfElements.
  Context {C : category}
          (F : C ⟶ HSET).

  Definition disp_cat_of_elems_ob_mor
    : disp_cat_ob_mor C.
  Proof.
    simple refine (_ ,, _).
    - exact (λ c, (F c : hSet)).
    - exact (λ c₁ c₂ x y f, #F f x = y).
  Defined.

  Definition disp_cat_of_elems_id_comp
    : disp_cat_id_comp C disp_cat_of_elems_ob_mor.
  Proof.
    split.
    - exact (λ c x, eqtohomot (functor_id F c) x).
    - refine (λ c₁ c₂ c₃ f g x₁ x₂ x₃ p q, _) ; cbn in *.
      refine (eqtohomot (functor_comp F f g) x₁ @ _) ; cbn.
      exact (maponpaths (# F g) p @ q).
  Qed.

  Definition disp_cat_of_elems_data
    : disp_cat_data C.
  Proof.
    simple refine (_ ,, _).
    - exact disp_cat_of_elems_ob_mor.
    - exact disp_cat_of_elems_id_comp.
  Defined.

  Definition disp_mor_elems_isaprop
             {c₁ c₂ : C}
             (f : c₁ --> c₂)
             (x₁ : disp_cat_of_elems_data c₁)
             (x₂ : disp_cat_of_elems_data c₂)
    : isaprop (x₁ -->[ f ] x₂).
  Proof.
    use invproofirrelevance.
    intros φ₁ φ₂.
    cbn in *.
    apply (F c₂).
  Qed.

  Definition disp_cat_of_elems_axioms
    : disp_cat_axioms C disp_cat_of_elems_data.
  Proof.
    repeat split ; intros ; cbn.
    - apply disp_mor_elems_isaprop.
    - apply disp_mor_elems_isaprop.
    - apply disp_mor_elems_isaprop.
    - apply isasetaprop.
      apply disp_mor_elems_isaprop.
  Qed.

  Definition disp_cat_of_elems
    : disp_cat C.
  Proof.
    simple refine (_ ,, _).
    - exact disp_cat_of_elems_data.
    - exact disp_cat_of_elems_axioms.
  Defined.

  Definition is_univalent_disp_disp_cat_of_elems
    : is_univalent_disp disp_cat_of_elems.
  Proof.
    use is_univalent_disp_from_fibers.
    intros c x₁ x₂.
    use isweqimplimpl.
    - intro f.
      exact (!(eqtohomot (functor_id F c) x₁) @ pr1 f).
    - apply (F c).
    - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)).
      + apply disp_mor_elems_isaprop.
      + apply isaprop_is_z_iso_disp.
  Qed.

  Definition is_z_iso_disp_cat_of_elems
             {c₁ c₂ : C}
             {f : z_iso c₁ c₂}
             {x : disp_cat_of_elems c₁}
             {y : disp_cat_of_elems c₂}
             (p : x -->[ f ] y)
    : is_z_iso_disp f p.
  Proof.
    simple refine (_ ,, (_ ,, _)) ; cbn in *.
    - rewrite <- p.
      refine (!(eqtohomot (functor_comp F f (inv_from_z_iso f)) x) @ _).
      rewrite z_iso_inv_after_z_iso.
      apply (eqtohomot (functor_id F c₁) x).
    - apply disp_mor_elems_isaprop.
    - apply disp_mor_elems_isaprop.
  Qed.

  Definition disp_cat_of_elems_is_opcartesian
             {c₁ c₂ : C}
             {f : c₁ --> c₂}
             {x₁ : disp_cat_of_elems c₁}
             {x₂ : disp_cat_of_elems c₂}
             (p : x₁ -->[ f ] x₂)
    : is_opcartesian p.
  Proof.
    intros c₃ x₃ g hh.
    use iscontraprop1.
    - use (isaprop_total2 (_ ,, _) (λ _, _ ,, _)) ; cbn -[isaprop].
      + apply disp_mor_elems_isaprop.
      + apply disp_cat_of_elems.
    - simple refine (_ ,, _) ; cbn in *.
      + refine (_ @ hh).
        refine (maponpaths (#F g) (!p) @ _).
        exact (!(eqtohomot (functor_comp F f g) x₁)).
      + apply disp_mor_elems_isaprop.
  Qed.

  Definition disp_cat_of_elems_opcleaving
    : opcleaving disp_cat_of_elems.
  Proof.
    intros c₁ c₂ x₁ f ; cbn in *.
    simple refine (_ ,, _ ,, _) ; cbn.
    - exact (#F f x₁).
    - apply idpath.
    - apply disp_cat_of_elems_is_opcartesian.
  Defined.

  Definition cat_of_elems_path_lift
             {x₁ x₂ : C}
             (p : x₁ = x₂)
             (y : disp_cat_of_elems x₂)
    : disp_cat_of_elems x₁.
  Proof.
    induction p.
    exact y.
  Defined.

  Definition cat_of_elems_path_path
             {x₁ x₂ : C}
             (p : x₁ = x₂)
             (y : disp_cat_of_elems x₂)
    : #F (idtoiso p) (cat_of_elems_path_lift p y) = y.
  Proof.
    induction p.
    cbn.
    exact (eqtohomot (functor_id F x₁) y).
  Qed.

  Definition cat_of_elems_path_natural
             {x₁ x₂ x₁' x₂' : C}
             (f₁ : x₁ --> x₁')
             (f₂ : x₂ --> x₂')
             (p : x₁ = x₂)
             (p' : x₁' = x₂')
             (y : disp_cat_of_elems x₂)
             (y' : disp_cat_of_elems x₂')
             (q : f₁ · idtoiso p' = idtoiso p · f₂)
             (r : y' = # F f₂ y)
    : cat_of_elems_path_lift p' y'
      =
      #F f₁ (cat_of_elems_path_lift p y).
  Proof.
    induction p, p'.
    cbn ; cbn in *.
    rewrite id_left, id_right in q.
    rewrite q.
    exact r.
  Qed.

  Section CatOfElemsIsoCleaving.
    Context (HC : is_univalent C)
            {x₁ x₂ : C}
            (f : x₁ --> x₂)
            (Hf : is_z_isomorphism f)
            (y : disp_cat_of_elems x₂).

    Definition cat_of_elems_iso_lift
      : disp_cat_of_elems x₁
      := cat_of_elems_path_lift (isotoid _ HC (make_z_iso' _ Hf)) y.

    Definition cat_of_elems_iso_path
      : #F f cat_of_elems_iso_lift = y.
    Proof.
      refine (_ @ cat_of_elems_path_path (isotoid _ HC (make_z_iso' _ Hf)) y).
      apply maponpaths_2.
      rewrite idtoiso_isotoid.
      apply idpath.
    Qed.
  End CatOfElemsIsoCleaving.

  Definition cat_of_elems_z_iso_natural
             (HC : is_univalent C)
             {x₁ x₂ x₁' x₂' : C}
             (f₁ : x₁ --> x₁')
             (f₂ : x₂ --> x₂')
             (g₁ : x₁ --> x₂)
             (Hg₁ : is_z_isomorphism g₁)
             (g₂ : x₁' --> x₂')
             (Hg₂ : is_z_isomorphism g₂)
             (y : disp_cat_of_elems x₂)
             (y' : disp_cat_of_elems x₂')
             (q : f₁ · g₂ = g₁ · f₂)
             (r : y' = # F f₂ y)
    : cat_of_elems_iso_lift HC g₂ Hg₂ y'
      =
      #F f₁ (cat_of_elems_iso_lift HC g₁ Hg₁ y).
  Proof.
    use (cat_of_elems_path_natural f₁ f₂).
    rewrite !idtoiso_isotoid ; cbn.
    - exact q.
    - exact r.
  Qed.

  Definition cat_of_elems
    : category
    := total_category disp_cat_of_elems.

  Definition is_univalent_cat_of_elems
             (HC : is_univalent C)
    : is_univalent cat_of_elems.
  Proof.
    use is_univalent_total_category.
    - exact HC.
    - exact is_univalent_disp_disp_cat_of_elems.
  Defined.

  Definition is_z_iso_cat_of_elems
             {cx₁ cx₂ : cat_of_elems}
             (f : cx₁ --> cx₂)
             (Hf : is_z_isomorphism (pr1 f))
    : is_z_isomorphism f.
  Proof.
    use tpair.
    - simple refine (inv_from_z_iso (make_z_iso' _ Hf) ,, _).
      abstract
        (cbn ;
         pose (pr2 f) as p ;
         cbn in p ;
         rewrite <- p ;
         exact (eqtohomot
                  (z_iso_inv_after_z_iso
                     (functor_on_z_iso F (make_z_iso' _ Hf))) (pr2 cx₁))).
    - split.
      + abstract
          (use subtypePath ; [ intro ; apply (F _) | ] ;
           apply (z_iso_inv_after_z_iso (make_z_iso' _ Hf))).
      + abstract
          (use subtypePath ; [ intro ; apply (F _) | ] ;
           apply (z_iso_after_z_iso_inv (make_z_iso' _ Hf))).
  Defined.

  Definition cat_of_elems_forgetful
    : cat_of_elems ⟶ C
    := pr1_category disp_cat_of_elems.

  Definition cat_of_elems_to_pointed_data
    : functor_data cat_of_elems pointed_sets.
  Proof.
    use make_functor_data.
    - exact (λ cx, F (pr1 cx) ,, pr2 cx).
    - exact (λ cx₁ cx₂ fp, #F (pr1 fp) ,, pr2 fp).
  Defined.

  Definition cat_of_elems_to_pointed_is_functor
    : is_functor cat_of_elems_to_pointed_data.
  Proof.
    split.
    - intros cx ; cbn in *.
      use subtypePath.
      {
        intro.
        apply (F _).
      }
      cbn.
      use funextsec.
      intro x.
      exact (eqtohomot (functor_id F (pr1 cx)) x).
    - intros cx₁ cx₂ cx₃ fp₁ fp₂ ; cbn in *.
      use subtypePath.
      {
        intro.
        apply (F _).
      }
      cbn.
      use funextsec.
      intro x.
      exact (eqtohomot (functor_comp F _ _) x).
  Qed.

  Definition cat_of_elems_to_pointed
    : cat_of_elems ⟶ pointed_sets.
  Proof.
    use make_functor.
    - exact cat_of_elems_to_pointed_data.
    - exact cat_of_elems_to_pointed_is_functor.
  Defined.

  Definition cat_of_elems_commute
    : cat_of_elems_to_pointed ∙ set_of_pointed_set
      ⟹
      cat_of_elems_forgetful ∙ F.
  Proof.
    use make_nat_trans.
    - exact (λ _, identity _).
    - abstract
        (intros cx₁ cx₂ f ; cbn ;
         apply idpath).
  Defined.

  Definition cat_of_elems_commute_z_iso
    : nat_z_iso
        (cat_of_elems_to_pointed ∙ set_of_pointed_set)
        (cat_of_elems_forgetful ∙ F).
  Proof.
    use make_nat_z_iso.
    - exact cat_of_elems_commute.
    - intro.
      apply identity_is_z_iso.
  Defined.

  Section FunctorToCatOfElems.
    Context {C' : category}
            (G₁ : C' ⟶ pointed_sets)
            (G₂ : C' ⟶ C)
            (γ : nat_z_iso
                   (G₁ ∙ set_of_pointed_set)
                   (G₂ ∙ F)).

    Definition functor_to_cat_of_elems_data
      : functor_data C' cat_of_elems.
    Proof.
      use make_functor_data.
      - exact (λ c, G₂ c ,, γ c (pr2 (G₁ c))).
      - refine (λ c₁ c₂ f, # G₂ f ,, _).
        abstract
          (cbn ;
           refine (!(eqtohomot (nat_trans_ax γ _ _ f) (pr2 (G₁ c₁))) @ _) ; cbn ;
           apply maponpaths ;
           exact (pr2 (# G₁ f))).
    Defined.

    Definition functor_to_cat_of_elems_is_functor
      : is_functor functor_to_cat_of_elems_data.
    Proof.
      split.
      - intro x ; cbn.
        use subtypePath.
        {
          intro.
          apply (F _).
        }
        cbn.
        apply functor_id.
      - intros x y z f g ; cbn.
        use subtypePath.
        {
          intro.
          apply (F _).
        }
        cbn.
        apply functor_comp.
    Qed.

    Definition functor_to_cat_of_elems
      : C' ⟶ cat_of_elems.
    Proof.
      use make_functor.
      - exact functor_to_cat_of_elems_data.
      - exact functor_to_cat_of_elems_is_functor.
    Defined.

    Definition functor_to_cat_of_elems_pointed_nat_trans
      : functor_to_cat_of_elems ∙ cat_of_elems_to_pointed ⟹ G₁.
    Proof.
      use make_nat_trans.
      - refine (λ x, inv_from_z_iso (nat_z_iso_pointwise_z_iso γ x) ,, _) ; cbn.
        abstract
          (exact (eqtohomot
                    (z_iso_inv_after_z_iso
                       (nat_z_iso_pointwise_z_iso γ x))
                    (pr2 (G₁ x)))).
      - abstract
          (intros c₁ c₂ f ; cbn ;
           use subtypePath ;
             [ intro ;
               apply (pr1 (G₁ c₂))
             | ] ;
           cbn ;
           use funextsec ;
           intro x ;
           exact (eqtohomot (nat_trans_ax (nat_z_iso_to_trans_inv γ) _ _ f) x)).
    Defined.

    Definition functor_to_cat_of_elems_pointed
      : nat_z_iso
          (functor_to_cat_of_elems ∙ cat_of_elems_to_pointed)
          G₁.
    Proof.
      use make_nat_z_iso.
      - exact functor_to_cat_of_elems_pointed_nat_trans.
      - intro.
        use is_z_iso_pointed_sets.
        apply is_z_iso_inv_from_z_iso.
    Defined.

    Definition functor_to_cat_of_elems_forgetful_nat_trans
      : functor_to_cat_of_elems ∙ cat_of_elems_forgetful ⟹ G₂.
    Proof.
      use make_nat_trans.
      - exact (λ x, identity _).
      - abstract
          (intros x y f ; cbn ;
           rewrite id_left, id_right ;
           apply idpath).
    Defined.

    Definition functor_to_cat_of_elems_forgetful
      : nat_z_iso
          (functor_to_cat_of_elems ∙ cat_of_elems_forgetful)
          G₂.
    Proof.
      use make_nat_z_iso.
      - exact functor_to_cat_of_elems_forgetful_nat_trans.
      - intro.
        apply identity_is_z_iso.
    Defined.

    Definition functor_to_cat_of_elems_commute
               (c : C')
      : cat_of_elems_commute (functor_to_cat_of_elems c)
        =
        # set_of_pointed_set (functor_to_cat_of_elems_pointed_nat_trans c) · γ c.
    Proof.
      use funextsec.
      intro x ; cbn.
      exact (!(eqtohomot (z_iso_after_z_iso_inv (nat_z_iso_pointwise_z_iso γ c)) x)).
    Qed.
  End FunctorToCatOfElems.

  Section NatTransToCatOfElems.
    Context {C' : category}
            {G₁ G₂ : C' ⟶ cat_of_elems}
            (τ₁ : G₁ ∙ cat_of_elems_to_pointed
                  ⟹
                  G₂ ∙ cat_of_elems_to_pointed)
            (τ₂ : G₁ ∙ cat_of_elems_forgetful
                  ⟹
                  G₂ ∙ cat_of_elems_forgetful)
            (p : ∏ (x : C'),
                 # F (τ₂ x) (pr2 (G₁ x))
                 =
                 pr1 (τ₁ x) (pr2 (G₁ x))).

    Definition nat_trans_to_cat_of_elems
      : G₁ ⟹ G₂.
    Proof.
      use make_nat_trans.
      - simple refine (λ x, τ₂ x ,, _) ; cbn.
        abstract
          (exact (p x @ pr2 (τ₁ x))).
      - abstract
          (intros x y f ; cbn ;
           use subtypePath ; [ intro ; apply (F _) | ] ; cbn ;
           exact (nat_trans_ax τ₂ _ _ f)).
    Defined.
  End NatTransToCatOfElems.
End CategoryOfElements.

Definition univalent_cat_of_elems
           {C : univalent_category}
           (F : C ⟶ SET)
  : univalent_category.
Proof.
  use make_univalent_category.
  - exact (cat_of_elems F).
  - apply is_univalent_cat_of_elems.
    apply C.
Defined.

(*
Section cat_of_elems_def.

Context {C : precategory} (X : C ⟶ HSET).

Definition cat_of_elems_ob_mor : precategory_ob_mor.
Proof.
exists (∑ (c : C), X c : hSet).
intros a b.
apply (∑ (f : C⟦pr1 a,pr1 b⟧), # X f (pr2 a) = pr2 b).
Defined.

Definition cat_of_elems_data : precategory_data.
Proof.
exists cat_of_elems_ob_mor.
split.
+ intros a.
  exists (identity (pr1 a)).
  abstract (exact (eqtohomot ((functor_id X) (pr1 a)) (pr2 a))).
+ intros a b c f g.
  exists (pr1 f · pr1 g).
  abstract (exact ((eqtohomot ((functor_comp X) (pr1 f) (pr1 g)) (pr2 a))
                      @ (maponpaths (# X (pr1 g)) (pr2 f) @ (pr2 g)))).
Defined.

Definition get_mor {x y : cat_of_elems_data} (f : _⟦x,y⟧) := pr1 f.

Lemma cat_of_elems_mor_eq (x y : cat_of_elems_data) (f g : _⟦x,y⟧) :
  get_mor f = get_mor g → f = g.
Proof.
intros p.
apply subtypePath.
- intro r; apply setproperty.
- exact p.
Qed.

Lemma is_precategory_cat_of_elems_data : is_precategory cat_of_elems_data.
Proof.
split; [split|split]; intros; apply cat_of_elems_mor_eq.
+ apply id_left.
+ apply id_right.
+ apply assoc.
+ apply assoc'.
Defined.

Definition cat_of_elems : precategory :=
  (cat_of_elems_data,,is_precategory_cat_of_elems_data).

Lemma has_homsets_cat_of_elems (hsC : has_homsets C) : has_homsets cat_of_elems.
Proof.
intros a b.
apply isaset_total2.
- apply hsC.
- intro f. apply isasetaprop, setproperty.
Qed.

End cat_of_elems_def.

Arguments get_mor {_ _ _ _} _.

(** Type as \int in Agda mode *)
Notation "∫ X" := (cat_of_elems X) (at level 3) : cat.

Section cat_of_elems_theory.

Context {C : precategory} {X Y : C ⟶ HSET}.

Definition get_ob (x : ∫ X) : C := pr1 x.
Definition get_el (x : ∫ X) : X (get_ob x) : hSet := pr2 x.
Definition get_eqn {x y : ∫ X} (f : (∫ X)⟦x,y⟧) :
  # X (get_mor f) (get_el x) = get_el y := pr2 f.

Definition make_ob (c : C) (x : X c : hSet) : ∫ X := (c,,x).
Definition make_mor (r s : ∫ X) (f : C⟦get_ob r,get_ob s⟧)
  (i : # X f (get_el r) = get_el s) : (∫ X)⟦r,s⟧ := (f,,i).

(** Functoriality of the construction of the category of elements *)
Definition cat_of_elems_on_nat_trans_data (α : X ⟹ Y) :
  functor_data (∫ X) (∫ Y).
Proof.
exists (λ a, (get_ob a,,α (get_ob a) (get_el a))).
intros b c f.
exists (get_mor f).
abstract (exact (!eqtohomot (pr2 α (get_ob b) (get_ob c) (get_mor f)) (get_el b)
                @ maponpaths (α (get_ob c)) (get_eqn f))).
Defined.

Lemma cat_of_elems_on_nat_trans_is_functor (α : X ⟹ Y) :
  is_functor (cat_of_elems_on_nat_trans_data α).
Proof.
split.
- now intros a; apply cat_of_elems_mor_eq.
- now intros a b c f g; apply cat_of_elems_mor_eq.
Qed.

Definition cat_of_elems_on_nat_trans (α : X ⟹ Y) : ∫ X ⟶ ∫ Y :=
  (cat_of_elems_on_nat_trans_data α,,cat_of_elems_on_nat_trans_is_functor α).

(* maybe make a functor [C,SET] ⟶ [category of Precategories] *)

(** The forgetful functor from the category of elements to C *)
Definition cat_of_elems_forgetful : ∫ X ⟶ C.
Proof.
use make_functor.
- exists pr1.
  intros a b; apply pr1.
- now split.
Defined.

Lemma reflects_isos_cat_of_elems_forgetful : reflects_isos cat_of_elems_forgetful.
Proof.
intros [c x] [d y] f Hf.
apply is_iso_from_is_z_iso.
assert (H := is_z_iso_from_is_iso _ Hf); clear Hf.
destruct f as [f i]; destruct H as [f' j].
assert (i' : #X f' y = x).
{ intermediate_path (#X f' (#X f x)).
  - exact (maponpaths (#X f') (!i)).
  - intermediate_path (#X (f' ∘ f) x).
    + exact (eqtohomot (!functor_comp X f f') x).
    + intermediate_path (#X (identity c) x).
      * exact (eqtohomot (maponpaths #X (pr1 j)) x).
      * exact (eqtohomot (functor_id X c) x).
}
exists (f' ,, i').
split; apply cat_of_elems_mor_eq; [ exact (pr1 j) | exact (pr2 j) ].
Qed.

End cat_of_elems_theory.
*)


(* Copyright (c) 2022, choukh <choukyuhei@gmail.com> *)

Require Import GOO.Ordinal.Ord.
Require Import GOO.Ordinal.WellFormed.
Require Import GOO.Ordinal.Operation.
Require Import GOO.Ordinal.Recursion.
Require Import GOO.Ordinal.Arithmetic.
Require Import GOO.Ordinal.Tetration.

Local Open Scope 序数域.
Local Open Scope 序数算术域.

Fixpoint 迭代 {A : Type} (F : A → A) (a : A) (n : nat) : A :=
  match n with
  | O => a
  | S n => F (迭代 F a n)
  end.

Lemma 有穷迭代等于有限递归 : ∀ F α n, 迭代 F α n = 递归 F α [n].
Proof.
  intros. induction n.
  - reflexivity.
  - simpl. rewrite IHn. reflexivity.
Qed.

Definition 无穷迭代 F := λ α, lim (λ n, 迭代 F α n).
Notation Itω := 无穷迭代.

Lemma 无穷迭代弱等于无穷递归 : ∀ F α, Itω F α ≃ 递归 F α ω.
Proof.
  intros. unfold Itω. simpl. split; constructor; intros n;
  apply 弱序_极限_介入 with n; rewrite 有穷迭代等于有限递归; reflexivity.
Qed.

Lemma 无穷迭代_弱放大 : ∀ F, 弱放大 F → 弱放大 (Itω F).
Proof. intros. apply 弱序_极限_介入 with 1. apply H. Qed.

Lemma 无穷迭代_弱保序 : ∀ F, 弱放大 F → 弱保序 F → 弱保序 (Itω F).
Proof.
  intros F Asc OP * H. constructor. intros n.
  apply 弱序_极限_介入 with (S n). simpl.
  apply 弱序_传递 with (迭代 F β n).
  - induction n; simpl. apply H. apply OP. apply IHn.
  - apply Asc.
Qed.

Section Veblen不动点.
Variable F : 序数 → 序数.
Variable F嵌入 : 序数嵌入 F.

Local Lemma F连续 : 极限处连续 F.
Proof. apply F嵌入. Qed.

Local Lemma F弱放大 : 弱放大 F.
Proof. apply 序数嵌入弱放大. apply F嵌入. Qed.

(* 序数嵌入的无穷迭代为不动点 *)
Lemma 不动点为之 : ∀ α, F (Itω F α) ≃ Itω F α.
Proof.
  intros. unfold Itω.
  rewrite F连续. split; constructor; intros n.
  - apply 弱序_极限_介入 with (S n). simpl. reflexivity.
  - apply 弱序_极限_介入 with n. apply F弱放大.
Qed.

Lemma 不动点任意大 : ∀ α, α ≤ Itω F α.
Proof. intros. apply 弱序_极限_介入 with 0. simpl. reflexivity. Qed.

(* 序数嵌入存在任意大的不动点 *)
Theorem Veblen不动点定理 : ∀ α, ∃ β, F β ≃ β ∧ α ≤ β.
Proof. intros. exists (Itω F α). split. apply 不动点为之. apply 不动点任意大. Qed.

Definition 最小不动点 F := Itω F ∅.
Local Notation "F ⁰" := (最小不动点 F) (format "F ⁰", at level 6).

Theorem 最小不动点为之 : F F⁰ ≃ F⁰ ∧ ∀ α, F α ≃ α → F⁰ ≤ α.
Proof.
  split. apply 不动点为之. intros. constructor.
  induction n; simpl. constructor.
  rewrite <- H. apply F嵌入. apply IHn.
Qed.

Lemma 最小迭代序列递增 : 零处强放大 F → 递增序列 (迭代 F ∅).
Proof.
  intros Asc n m Hnm. induction m.
  - easy.
  - simpl. inversion_clear Hnm.
    + clear IHm. induction m. simpl. apply Asc. simpl. apply F嵌入. apply IHm.
    + eapply 强弱传递. apply IHm. apply H. apply F弱放大.
Qed.

Theorem 最小不动点良构 : 零处强放大 F → 保良构 F → 良构 F⁰.
Proof.
  intros Asc WF. split.
  - induction n. easy. simpl. apply WF. apply IHn.
  - apply 最小迭代序列递增. apply Asc.
Qed.

Definition 后继不动点 F α := Itω F α⁺.
Local Notation "F ¹" := (后继不动点 F) (format "F ¹", at level 6).

Theorem 后继不动点为之 : ∀ α, F (F¹ α) ≃ F¹ α ∧ α < F¹ α ∧ ∀ γ, F γ ≃ γ → α < γ → F¹ α ≤ γ.
Proof.
  split3. apply 不动点为之. apply 小于即后继小于等于. apply 不动点任意大.
  intros γ FP H. constructor. induction n; simpl.
  - apply 小于即后继小于等于. apply H.
  - rewrite <- FP. apply F嵌入. apply IHn.
Qed.

Lemma 后继不动点_弱放大 : 弱放大 F¹.
Proof. intros. apply 弱序_后继_除去. apply 无穷迭代_弱放大. apply F弱放大. Qed.

Lemma 后继不动点_弱保序 : 弱保序 F¹.
Proof. intros. apply 无穷迭代_弱保序. apply F弱放大. apply F嵌入. rewrite <- 后继_弱保序. easy. Qed.

Lemma 后继不动点_强放大 : 强放大 F¹.
Proof. intros. eapply 强序_极限_介入 with 0. simpl. easy. Qed.

Lemma 后继迭代序列递增 : ∀ α, 良构 α → 良构后继处强放大 F → 递增序列 (迭代 F α⁺).
Proof.
  intros α WF Asc n m Hnm. induction m.
  - easy.
  - simpl. inversion_clear Hnm.
    + clear IHm. induction m. simpl. apply Asc. apply WF.
      simpl. apply F嵌入. apply IHm.
    + eapply 强弱传递. apply IHm. apply H. apply F弱放大.
Qed.

Lemma 后继不动点_保良构 : 良构后继处强放大 F → 保良构 F → 保良构 F¹.
Proof.
  intros Asc WF α WFα. split.
  - induction n; simpl. apply WFα. apply WF. apply IHn.
  - apply 后继迭代序列递增. apply WFα. apply Asc.
Qed.

End Veblen不动点.

Notation "F ⁰" := (最小不动点 F) (format "F ⁰", at level 6) : 序数域.
Notation "F ¹" := (后继不动点 F) (format "F ¹", at level 6) : 序数域.

Definition 不动点枚举 F := 递归 F¹ F⁰.
Notation "F ′" := (不动点枚举 F) (format "F ′", at level 6) : 序数域.

Theorem 不动点枚举保函数外延 : ∀ f g, 序数嵌入 f → 序数嵌入 g →
  (∀ α, f α ≃ g α) → ∀ α, f′ α ≃ g′ α.
Proof with auto.
  intros * Ef Eg Heq. unfold 不动点枚举.
  induction α as [|α IH|h IH].
  - split; constructor; intros n; simpl.
    + induction n. constructor.
      simpl. unfold 最小不动点. rewrite Heq, <- 不动点为之... apply Eg...
    + induction n. constructor.
      simpl. unfold 最小不动点. rewrite <- Heq, <- 不动点为之... apply Ef...
  - simpl. split; constructor; intros n.
    + induction n; simpl.
      * apply 弱序_极限_介入 with 0. simpl. rewrite <- 后继_弱保序, IH. easy.
      * unfold 后继不动点 at 2. rewrite Heq, <- 不动点为之... apply Eg...
    + induction n; simpl.
      * apply 弱序_极限_介入 with 0. simpl. rewrite <- 后继_弱保序, IH. easy.
      * unfold 后继不动点 at 2. rewrite <- Heq, <- 不动点为之... apply Ef...
  - simpl. split; constructor; intros n; apply 弱序_极限_介入 with n; apply IH.
Qed.

Section 不动点枚举.
Variable F : 序数 → 序数.
Variable F嵌入 : 序数嵌入 F.
Variable Asc0 : 零处强放大 F.
Variable Asc1 : 良构后继处强放大 F.

Lemma 不动点枚举_零 : F′ ∅ = F⁰.
Proof. easy. Qed.

Lemma 不动点枚举_后继 : ∀ α, F′ α⁺ = Itω F (F′ α)⁺.
Proof. easy. Qed.

Lemma 不动点枚举_极限 : ∀ f, F′ (lim f) = lim (λ n, F′ (f n)).
Proof. easy. Qed.

Theorem 不动点枚举枚举之 : ∀ α, F (F′ α) ≃ F′ α.
Proof.
  induction α as [| |f IH].
  - rewrite 不动点枚举_零. apply 不动点为之. auto.
  - rewrite 不动点枚举_后继. apply 不动点为之. auto.
  - rewrite 不动点枚举_极限. destruct F嵌入 as [_ [_ Conti]]. rewrite Conti.
    split; constructor; intros n; eapply 弱序_极限_介入; rewrite IH; reflexivity.
Qed.

Theorem 不动点枚举为序数嵌入 : 序数嵌入 F′.
Proof.
  split3.
  - apply 递归_弱保序_右.
    + apply 后继不动点_弱放大. apply F嵌入.
    + apply 后继不动点_弱保序. apply F嵌入.
  - apply 递归_强保序_右.
    + apply 后继不动点_强放大.
    + apply 后继不动点_弱保序. apply F嵌入.
  - easy.
Qed.

Corollary 存在不动点的不动点 : ∀ α, ∃ β, F′ β ≃ β ∧ α ≤ β.
Proof. intros. apply Veblen不动点定理. apply 不动点枚举为序数嵌入. Qed.

Corollary 不动点枚举在后继处递增 : 后继处递增 F′.
Proof. apply 强保序在后继处递增. apply 不动点枚举为序数嵌入. Qed.

Theorem 不动点枚举保良构 : 保良构 F → 保良构 F′.
Proof.
  intros WF. apply 递归保良构.
  - apply 后继不动点_强放大.
  - apply 后继不动点_弱保序. apply F嵌入.
  - apply 后继不动点_保良构. apply F嵌入. apply Asc1. apply WF.
  - apply 最小不动点良构. apply F嵌入. apply Asc0. apply WF.
Qed.

Lemma 不动点枚举在零处强放大 : 零处强放大 F′.
Proof.
  unfold 不动点枚举. simpl. unfold 最小不动点.
  eapply 强序_极限_介入 with 1. simpl. apply Asc0.
Qed.

Lemma 不动点枚举在良构后继处强放大 : 良构后继处强放大 F′.
Proof.
  intros α WFα. unfold 不动点枚举. simpl. apply 强弱传递 with (F¹ α).
  - unfold 后继不动点. eapply 强序_极限_介入 with 1. simpl. apply Asc1. apply WFα.
  - apply 后继不动点_弱保序. apply F嵌入. apply 递归_弱放大_左.
    apply 后继不动点_强放大. apply 后继不动点_弱保序. apply F嵌入.
Qed.

Theorem 不动点枚举保良构_递进 : 保良构 F′ → 保良构 F′′.
Proof.
  intros WF. apply 递归保良构.
  - apply 后继不动点_强放大.
  - apply 后继不动点_弱保序. apply 不动点枚举为序数嵌入.
  - apply 后继不动点_保良构. apply 不动点枚举为序数嵌入.
    apply 不动点枚举在良构后继处强放大. apply WF.
  - apply 最小不动点良构. apply 不动点枚举为序数嵌入.
    apply 不动点枚举在零处强放大. apply WF.
Qed.

Lemma 不动点飞升 : ∀ n, F [n] < F′ ∅.
Proof.
  intros. unfold 不动点枚举, 递归, 最小不动点.
  apply 强弱传递 with (F [S n]). apply F嵌入. simpl. auto.
  apply 弱序_极限_介入 with (S (S n)). simpl. apply F嵌入.
  induction n; simpl.
  - apply 小于即后继小于等于. apply Asc0.
  - apply F嵌入 in IHn. eapply 弱序_传递. 2: apply IHn.
    apply 小于即后继小于等于. apply Asc1. apply 有限序数良构.
Qed.

End 不动点枚举.

Theorem 不动点枚举为序数嵌入_递进 : ∀ F, 序数嵌入 F′ → 序数嵌入 F′′.
Proof. intros F. apply 不动点枚举为序数嵌入. Qed.

Section 左加法不动点.
Variable ξ : 序数.

Definition σ := (加法 ξ)′.

Lemma σ数为左加法不动点 : ∀ α, ξ + (σ α) ≃ σ α.
Proof. apply 不动点枚举枚举之. apply 加法为序数嵌入. Qed.

Lemma σ_零 : σ [0] ≃ ξ * ω.
Proof.
  intros. unfold ω. rewrite 乘极限.
  split; constructor; intros n; apply 弱序_极限_介入 with n; (
    induction n; [reflexivity|
      simpl; rewrite 乘后继, <- 加法有限结合律; apply 加法_弱保序_右; apply IHn
  ]).
Qed.

Lemma σ_后继 : ∀ α, σ α⁺ ≃ (σ α)⁺.
Proof.
  intros. split.
  - unfold σ. rewrite 不动点枚举_后继. constructor. induction n.
    + simpl. easy.
    + simpl. apply 弱序_传递 with (ξ + (σ α)⁺). apply 加法_弱保序_右. apply IHn.
      rewrite 加后继, <- 后继_弱保序, σ数为左加法不动点. reflexivity.
  - apply 小于即后继小于等于. apply 不动点枚举在后继处递增. apply 加法为序数嵌入.
Qed.

Lemma σ_极限 : ∀ f, σ (lim f) ≃ lim (λ n, σ (f n)).
Proof. easy. Qed.

Theorem σ表达式 : ∀ α, σ α ≃ ξ * ω + α.
Proof.
  induction α as [| |f IH].
  - rewrite 加零. apply σ_零.
  - rewrite σ_后继, 加后继, <- 后继_改写. apply IHα.
  - rewrite σ_极限, 加极限. split; constructor; intros n;
    eapply 弱序_极限_介入; rewrite IH; reflexivity.
Qed.

End 左加法不动点.

Section 左乘法不动点.
Variable ξ : 序数.
Variable ξ大于一 : [1] < ξ.

Definition π := (乘法 ξ)′.

Lemma π数为左乘法不动点 : ∀ α, ξ * (π α) ≃ π α.
Proof.
  apply 不动点枚举枚举之. apply 乘法为序数嵌入.
  eapply 强序_传递. apply 后继大于自身. auto.
Qed.

Lemma π_零 : π [0] ≃ [0].
Proof.
  split; constructor. induction n; simpl. constructor.
  replace ∅ with (ξ * [0]) at 2. apply 乘法_弱保序_右. apply IHn. apply 乘零.
Qed.

Lemma π_一 : π [1] ≃ ξ ^ ω.
Proof.
  intros. unfold ω. rewrite 极限次幂. split.
  - apply 后继不动点为之.
    + apply 乘法为序数嵌入. eapply 强序_传递. apply 后继大于自身. auto.
    + rewrite 乘极限. split; constructor; intros n.
      * apply 弱序_极限_介入 with (S n). simpl. rewrite 后继次幂. apply 乘法有限结合律.
      * apply 弱序_极限_介入 with n. apply 乘法_弱放大_左. auto.
    + apply 强序_极限_介入 with 0. rewrite 零次幂. apply 小于等于即小于后继.
      rewrite π_零. reflexivity.
  - constructor. induction n.
    + rewrite 零次幂. apply 弱序_极限_介入 with 0. simpl.
      rewrite <- 后继_弱保序. rewrite π_零. reflexivity.
    + simpl. rewrite 后继次幂, <- π数为左乘法不动点, <- 乘法有限结合律.
      apply 乘法_弱保序_右. apply IHn.
Qed.

Lemma π_后继 : ∀ α, π α⁺ ≃ π α + π [1].
Proof.
  intros. split.
  - unfold π at 1. rewrite 不动点枚举_后继. apply 后继不动点为之.
    + apply 乘法为序数嵌入. eapply 强序_传递. apply 后继大于自身. auto.
    + rewrite 乘法分配律, (加法_改写_左 (π α)), (加法_改写_右 (π [1])). reflexivity. 1-2: apply π数为左乘法不动点.
    + apply 加法_强放大_右. apply 小于即后继小于等于. rewrite π_一.
      apply 弱序_极限_介入 with 0. reflexivity.
  - constructor. intros n. apply 弱序_传递 with (π α + ξ ^ [n]). apply 加法_弱保序_右.
    + induction n; simpl.
      * rewrite 零次幂. simpl. rewrite <- 后继_弱保序. rewrite π_零. reflexivity.
      * rewrite 后继次幂, <- 乘法有限结合律. apply 乘法_弱保序_右. apply IHn.
    + induction n; simpl.
      * rewrite 零次幂, 加一. apply 小于即后继小于等于.
        apply 不动点枚举在后继处递增. apply 乘法为序数嵌入.
        eapply 强序_传递. apply 后继大于自身. auto.
      * rewrite 后继次幂, <- (π数为左乘法不动点 α⁺), (加法_改写_左 (ξ * π α)), (加法_改写_右 (ξ * ξ ^ [n])).
        rewrite <- 乘法分配律. apply 乘法_弱保序_右. apply IHn.
        rewrite 乘法有限结合律. reflexivity. rewrite π数为左乘法不动点. reflexivity.
Qed.

Lemma π_极限 : ∀ f, π (lim f) ≃ lim (λ n, π (f n)).
Proof. easy. Qed.

Theorem π表达式 : ∀ α, π α ≃ ξ ^ ω * α.
Proof.
  induction α as [| |f IH].
  - rewrite 乘零. apply π_零.
  - rewrite π_后继, 乘后继, 加法_改写_左, 加法_改写_右. reflexivity. apply π_一. apply IHα.
  - rewrite π_极限, 乘极限. split; constructor; intros n;
    eapply 弱序_极限_介入; rewrite IH; reflexivity.
Qed.

End 左乘法不动点.


Require Export Term.
Require Import Equality.
Require Import Coq.Lists.List.

Import ListNotations.
Module Type TermEquality(G : GroundInfo)(GT : Term G).
  Import G. Import GT.

  Lemma UnifyFunTerms : forall {f f' : funSym} {l l' : list flafolTerm}, f = f' -> l = l' -> funTerm f l = funTerm f' l'.
  Proof.
    intros f f' l l' H H0; rewrite H; rewrite H0; reflexivity.
  Qed.

  Lemma UnifyCons : forall {A : Type} {a b : A} {l l' : list A},
      a = b -> l = l' -> (a :: l) = (b :: l').
  Proof.
    intros A a b l l' H H0; rewrite H; rewrite H0; reflexivity.
  Qed.

  Ltac FindArgsEquality := idtac.
  Ltac FindTermEquality' l :=
    match goal with
    | [ |- ?t = ?t ] => reflexivity
    | [ e : ?t = ?u |- ?t = ?u ] => exact e
    | [ e : ?u = ?t |- ?t = ?u ] => exact (eq_sym e)
    | [ e : ?x = ?z |- ?x = ?y ] =>
      NotInList z l; transitivity z; [exact e | FindTermEquality' constr:(z :: l)]
    | [ e : ?z = ?x |- ?x = ?y ] =>
      NotInList z l; transitivity z;
      [exact (eq_sym e) | FindTermEquality' constr:(z :: l)]
    | [ |- (funTerm ?f1 ?l1) = (funTerm ?f2 ?l2) ] =>
      apply UnifyFunTerms; [FindEquality | FindArgsEquality ]
    end.

  Ltac FindTermEquality := FindTermEquality' constr:(@nil flafolTerm).

  Ltac FindArgsEquality ::=
    match goal with
    | [ |- [] = [] ] => reflexivity
    | [ |- (?t :: ?l1) = (?u :: ?l2)] => apply UnifyCons;
                                       [FindTermEquality
                                       | FindArgsEquality]
    end.

  Module TermEqualityTests.
    Lemma TermEqualityTest1 : forall (t : flafolTerm), t = t.
    Proof.
      intros; FindTermEquality.
    Qed.

    Lemma TermEqualityTest2 : forall (t u : flafolTerm), t = u -> u = t.
    Proof.
      intros t u H; FindTermEquality.
    Qed.

    Lemma TermEqualityTest3 : forall (t u v : flafolTerm), t = u -> u = v -> t = v.
    Proof.
      intros t u v H H0; FindTermEquality.
    Qed.

    Lemma TermEqualityTest4 : forall (t u v w : flafolTerm), t = u -> t = v -> v = w -> t = w.
    Proof.
      intros; FindTermEquality.
    Qed.

    Lemma TermEqualityTest5 : forall (t u v w : flafolTerm), t = w -> t = u -> w = v -> t = v.
    Proof.
      intros; FindTermEquality.
    Qed.

    Lemma TermEqualityTest6 : forall (t u v w : flafolTerm), w = t -> t = u -> v = w -> t = v.
    Proof.
      intros; FindTermEquality.
    Qed.

    Lemma TermEqualityTest8 : forall (f1 f2 : funSym) (t1 t2 u1 u2 : flafolTerm),
        f1 = f2 -> t1 = t2 -> u1 = u2 -> funTerm f1 [t1; u1] = funTerm f2 [t2; u2].
    Proof.
      intros f1 f2 t1 t2 u1 u2 H H0 H1.
      Fail FindEquality.
      FindTermEquality.
    Qed.
  End TermEqualityTests.
End TermEquality.


Require Import HoTT.

(* Definition of polynomials. *)

Inductive polynomial :=
  | poly_var : polynomial
  | poly_const : Type -> polynomial
  | poly_times : polynomial -> polynomial -> polynomial
  | poly_plus : polynomial -> polynomial -> polynomial.

Notation "'[-]'" := (poly_var) : poly_scope.
Notation "P * Q" := (poly_times P Q) : poly_scope.
Notation "P + Q" := (poly_plus P Q) : poly_scope.
Notation "'const' C" := (poly_const C) (at level 20) : poly_scope.

Local Open Scope type_scope.

(* The action of a polynomial on a type. *)
Fixpoint poly_act (P : polynomial) (A : Type) :=
  match P with
  | poly_var => A
  | poly_const C => C
  | poly_times Q R => poly_act Q A * poly_act R A
  | poly_plus Q R => poly_act Q A + poly_act R A
  end.

(* The action of a polynomial on a map. *)
Fixpoint poly_map (P : polynomial) {A B : Type} (f : A -> B) :
  poly_act P A -> poly_act P B :=
  match P with
  | poly_var => f
  | poly_const C => (fun x => x)
  | poly_times Q R => (fun x => (poly_map Q f (fst x), poly_map R f (snd x)))
  | poly_plus Q R => (fun u => match u with
                           | inl x => inl (poly_map Q f x)
                           | inr y => inr (poly_map R f y)
                           end)
  end.

(* The action of a polynomial on a type family. *)
Fixpoint poly_fam (P : polynomial) {A : Type} (B : A -> Type) :
  poly_act P A -> Type :=
  match P with
  | poly_var => B
  | poly_const C => (fun _ => C)
  | poly_times Q R => (fun u => poly_fam Q B (fst u) * poly_fam R B (snd u))
  | poly_plus Q R => (fun u => match u with
                           | inl x => poly_fam Q B x
                           | inr y => poly_fam R B y
                           end)
  end.

(* The action of a polynomial on a dependent map. *)
Fixpoint poly_dmap (P : polynomial) {A : Type} {B : A -> Type} (f : forall x, B x) {struct P} :
  forall u : poly_act P A, poly_fam P B u :=
  match P with
  | poly_var => f
  | poly_const C => (fun x => x)
  | poly_times Q R => (fun u => (poly_dmap Q f (fst u), poly_dmap R f (snd u)))
  | poly_plus Q R => (fun u => match u with
                          | inl x => poly_dmap Q f x
                          | inr y => poly_dmap R f y
                          end)
  end.


Require Import
        SetoidClass
        Coq.Arith.Max
        Coq.Classes.Morphisms.
Require Export Fiat.Common.Coq__8_4__8_5__Compat.

Generalizable All Variables.

Definition prod_op {A B} (fA : A -> A -> Prop) (fB : B -> B -> Prop)
           (x y : A * B) := fA (fst x) (fst y) /\ fB (snd x) (snd y).

Definition map_op {A B} (f : A -> B) (P : B -> B -> Prop) (x y : A) : Prop :=
  P (f x) (f y).

Definition pointwise_op {A} {B : A -> Type} (P : forall a, B a -> B a -> Prop)
           (f g : forall a, B a) := forall a, P a (f a) (g a).

(** A tour of algebraic structures. Most of them are things related to
    orders or latices.
    Each definition follows a relatively rigid pattern.
    Each algebraic structure is defined in its own module.
    For instance, preorders are defined in the Module [PreO].
    The type which defines the algebraic structure for preorders
    is called [t], which outside the module looks like [PreO.t].

    Let's be concrete. The type [Qnn] of non-negative rational numbers
    has a relation [Qnnle : Qnn -> Qnn -> Prop] which represents a
    preorder. Therefore, we can make an instance
    [H : PO.t Qnn Qnnle] which gives evidence that [Qnnle] is in fact
    a preorder.

    Within the module [PreO] (and for most algebraic structures), we have a
    type [morph] which gives evidence that some function in fact is a morphism
    in that category of algebraic structure; that is, it preserves the structure
    for whatever algebraic structure we defined. We always prove that the identity
    function is a morphism [morph_id] and that morphisms are closed under
    composition [morph_compose].

    At the end we give examples or building blocks for the algebraic structure.
    There's usually trivial examples of these structures over base types which
    have only one or two elements. There is usually a way to form products,
    and often, given an algebraic structure on [B] and a function [f : A -> B],
    we can define the algebraic structure on [A] by asking whether it holds
    pointwise in [B].

    Just given a preorder, we can define what it means for something to be
    a top element or bottom, max or min, infimum or supremum, and so these
    definitions are given in the [PO] module. Many algebraic structures are
    then closed under these operations, in which case there will be functions
    that are defined that implement the given operation. For instance, for
    meet-semilattices, we have an operation for minimums.
 *)

(** Preorders: types which have a "<=" relation which is reflexitive and
    transitive *)
Module PreO.
  (** The relation [le] (read: Less than or Equal) is a preorder when
      it is reflexive [le_refl] and transitive [le_trans]. *)
  Class t {A : Type} {le : A -> A -> Prop} : Prop :=
    { le_refl : forall x, le x x
      ; le_trans : forall x y z, le x y -> le y z -> le x z
    }.

  Arguments t {A} le.

  Local Instance PreOrder_I `{tle : t A leA} : PreOrder leA.
  Proof.
    constructor.
    - unfold Reflexive. apply le_refl.
    - unfold Transitive. apply le_trans.
  Qed.

  (** A morphism of preorders is just a monotonic function. That is,
      it preserves ordering. *)
  Definition morph `(leA : A -> A -> Prop) `(leB : B -> B -> Prop) `(f : A -> B) : Prop :=
    forall a b, leA a b -> leB (f a) (f b).

  Section Facts.

    Context `{le : A -> A -> Prop}.
    Context (tA : t le).
    Infix "<=" := le.

    Lemma morph_id : morph le le (fun x => x).
    Proof.
      unfold morph; auto.
    Qed.

    Lemma morph_compose `(tB : t B leB) `(tC : t C leC)
      : forall (f : A -> B) (g : B -> C),
        morph le leB f -> morph leB leC g -> morph le leC (fun x => g (f x)).
    Proof.
      unfold morph; auto.
    Qed.

    (** [top t] holds if [t] is bigger than everything *)
    Definition top (t : A) : Prop := forall a, a <= t.

    (** [bottom b] holds if [b] is smaller than everything *)
    Definition bottom (b : A) : Prop := forall a, b <= a.

    (** [max l r m] holds if [m] is the maximum of [l] and [r]. *)
    Record max {l r m : A} : Prop :=
      { max_l     : l <= m
        ; max_r     : r <= m
        ; max_least : forall m', l <= m' -> r <= m' -> m <= m'
      }.

    Arguments max : clear implicits.

    (** [max] is commutative *)
    Lemma max_comm : forall l r m, max l r m -> max r l m.
    Proof.
      intros. constructor.
      - apply H.
      - apply H.
      - intros. apply H; assumption.
    Qed.

    (** [min l r m] holds if [m] is the minimum of [l] and [r] *)
    Record min {l r m : A} : Prop :=
      { min_l        : m <= l
        ; min_r        : m <= r
        ; min_greatest : forall m', m' <= l -> m' <= r -> m' <= m
      }.

    Global Arguments min : clear implicits.

    (** [min] is commutative *)
    Lemma min_comm : forall l r m, min l r m -> min r l m.
    Proof.
      intros. constructor.
      - apply H.
      - apply H.
      - intros. apply H; assumption.
    Qed.

    (** [min] is associative, phrased in a relational manner,
      i.e., minima are associative when they exist *)
    Lemma min_assoc : forall a b c,
        forall bc, min b c bc ->
                   forall ab, min a b ab ->
                              forall abc, min a bc abc <-> min ab c abc.
    Proof.
      intros a b c bc BC ab AB abc. split; intros ABC.
      - constructor.
        + apply (min_greatest AB).
          * apply (min_l ABC).
          * rewrite (min_r ABC). apply (min_l BC).
        + rewrite (min_r ABC). apply (min_r BC).
        + intros. apply (min_greatest ABC).
          * rewrite H. apply (min_l AB).
          * apply (min_greatest BC).  rewrite H. apply (min_r AB).
            assumption.
      - constructor.
        + rewrite (min_l ABC). apply (min_l AB).
        + apply (min_greatest BC).
          * rewrite (min_l ABC). apply (min_r AB).
          * apply (min_r ABC).
        + intros. apply (min_greatest ABC).
          * apply (min_greatest AB).
            assumption. rewrite H0. apply (min_l BC).
          * rewrite H0. apply (min_r BC).
    Qed.

    Lemma min_idempotent : forall a, min a a a.
    Proof.
      intros. constructor.
      - reflexivity.
      - reflexivity.
      - intros. assumption.
    Qed.

    (** [sup f m] holds when [m] is the supremum of all
      values indexed by [f]. *)
    Record sup {I : Type} (f : I -> A) (m : A) : Prop :=
      { sup_ge : forall i, f i <= m
        ; sup_least : forall m', (forall i, f i <= m') -> m <= m'
      }.

    (** [inf f m] holds when [m] is the infimum of all
      values indexed by [f]. *)
    Record inf {I : Type} (f : I -> A) (m : A) : Prop :=
      { inf_le : forall i, m <= f i
        ; inf_greatest : forall m', (forall i, m' <= f i) -> m' <= m
      }.

    (** A directed subset of [A] is one where every two
      elements have a common upper bound. *)
    Definition directed {I} (f : I -> A) :=
      forall i j : I, exists k, f i <= k /\ f j <= k.

  End Facts.

  Definition scott_cont `{tA : t A leA}
             `{tB : t B leB} (f : A -> B) :=
    forall I (g : I -> A), @directed _ leA _ g
                           -> forall m, @sup _ leA _ g m
                                        -> @sup _ leB _ (fun i => f (g i)) (f m).

  (** [True], the one-element type, has a trivial preorder *)
  Definition one : t (fun (_ : True) _ => True).
  Proof. constructor; auto.
  Qed.

  (** The preorder on booleans given by False < True *)
  Definition two : t (fun b1 b2 : bool => if b1 then b2 = true else True).
  Proof. constructor.
         - intros []; auto.
         - intros [] [] []; auto.
  Qed.

  Definition Nat : t le.
  Proof. constructor; [ apply Le.le_refl | apply Le.le_trans ].
  Qed.

  Definition discrete (A : Type) : t (@Logic.eq A).
  Proof. constructor; auto. intros; subst; auto. Qed.

  (** Product preorders *)
  Definition product `(tA : t A leA) `(tB : t B leB)
    : t (prod_op leA leB).
  Proof. constructor.
         - destruct x. split; apply le_refl.
         - unfold prod_op; intros.
           destruct x, y, z; simpl in *.
           destruct H, H0.
           split; eapply PreO.le_trans; eassumption.
  Qed.

  (** Given a preorder on [B] and a function [f : A -> B],
      we form a preorder on [A] by asking about their order
      when mapped into [B] by [f]. *)
  Definition map `(f : A -> B) `(tB : t B leB)
    : t (fun x y => leB (f x) (f y)).
  Proof. constructor; intros.
         - apply le_refl.
         - eapply le_trans; eauto.
  Qed.

  (** It's probably easiest to explain the simply-typed
      version of this: Given a preorder on [B], we can
      form a preorder on functions of type [A -> B] by saying
      [f <= g] (where [f, g : A -> B]) whenever
      the relation holds pointwise, i.e., for all [a : A],
      we have [f a <= g a]. *)
  Definition pointwise {A} {B : A -> Type}
             {leB : forall a, B a -> B a -> Prop}
             (tB : forall a, t (leB a))
    : @t (forall a, B a) (pointwise_op leB).
  Proof.
    unfold pointwise_op; constructor; intros.
    - apply le_refl.
    - eapply le_trans; eauto.
  Qed.

  Definition morph_pointwise {A B C} `{tC : t C leC} (f : B -> A)
    : morph (pointwise_op (fun _ => leC)) (pointwise_op (fun _ => leC))
            (fun g b => g (f b)).
  Proof.
    unfold morph, pointwise_op. intros; simpl in *; apply H.
  Qed.

  (** The type of propositions forms a preorder, where "<=" is
      implication. *)
  Local Instance prop : t (fun (P Q : Prop) => P -> Q).
  Proof.
    constructor; auto.
  Qed.

  (** Subsets, in type theory defined as propositional functions,
      i.e., subsets on [A] are functions of type [f : A -> Prop],
      form a preorder ordered by subset inclusion. This is actually just
      the preorder on propositions applied pointwise to functions. *)
  Local Instance subset (A : Type) : @t (A -> Prop) _ := pointwise (fun _ => prop).

End PreO.

Arguments PreO.max {A} {le} _ _ _.

(** Partial orders: We take a preorder, but also have an equality relation [eq]
    such that [eq x y] exactly when both [le x y] and [le y x]. *)
Module PO.
  Class t {A : Type} {le : A -> A -> Prop} {eq : A -> A -> Prop} : Prop :=
    { PreO :> PreO.t le
      ; le_proper : Proper (eq ==> eq ==> iff) le
      ; le_antisym : forall x y, le x y -> le y x -> eq x y
    }.

  Arguments t {A} le eq.

  Section Morph.
    Context `{tA : t A leA eqA} `{tB : t B leB eqB}.

    Record morph {f : A -> B} : Prop :=
      { f_PreO : PreO.morph leA leB f
        ; f_eq : Proper (eqA ==> eqB) f
      }.

    Arguments morph : clear implicits.

  End Morph.

  Arguments morph {_} leA eqA {_} leB eqB f.

  Section Facts.
    Context `{tA : t A leA eqA}.

    (** The equality relation of a partial order must form an
      equivalence relation. *)
    Definition eq_refl : Reflexive eqA.
    Proof. unfold Reflexive.
           intros. apply le_antisym; apply PreO.le_refl.
    Qed.

    Definition eq_sym : Symmetric eqA.
    Proof.
      unfold Symmetric. intros. apply le_antisym. eapply le_proper.
      apply eq_refl. apply H. apply PreO.le_refl. eapply le_proper.
      apply H. apply eq_refl. apply PreO.le_refl.
    Qed.

    Definition eq_trans : Transitive eqA.
    Proof.
      unfold Transitive.
      intros. apply le_antisym. eapply le_proper. apply H.
      apply eq_refl. eapply le_proper. apply H0. apply eq_refl.
      apply PreO.le_refl. eapply le_proper. apply eq_refl. apply H.
      eapply le_proper. apply eq_refl. apply H0. apply PreO.le_refl.
    Qed.

    Lemma max_unique : forall l r m m'
      , PreO.max (le := leA) l r m
        -> PreO.max (le := leA) l r m'
        -> eqA m m'.
    Proof.
      intros. apply PO.le_antisym.
      - apply H; apply H0.
      - apply H0; apply H.
    Qed.

    Lemma min_unique : forall l r m m'
      , PreO.min (le := leA) l r m
        -> PreO.min (le := leA) l r m'
        -> eqA m m'.
    Proof.
      intros. apply PO.le_antisym.
      - apply H0; apply H.
      - apply H; apply H0.
    Qed.

  End Facts.

  Local Instance t_equiv `{tA : t A leA eqA} : Equivalence eqA.
  Proof.
    split; [apply eq_refl | apply eq_sym | apply eq_trans ].
  Qed.

  Lemma morph_id `{tA : t A leA eqA} : morph leA eqA leA eqA (fun x : A => x).
  Proof. constructor.
         - apply PreO.morph_id.
         - solve_proper.
  Qed.

  Lemma morph_compose `{tA : t A leA eqA} `{tB : t B leB eqB} `{tC : t C leC eqC}
    : forall (f : A -> B) (g : B -> C), morph leA eqA leB eqB f
                                        -> morph leB eqB leC eqC g -> morph leA eqA leC eqC (fun x => g (f x)).
  Proof.
    intros. destruct H, H0. constructor; intros.
    - apply (PreO.morph_compose (leB := leB)); eauto using PreO. apply PreO.
    - solve_proper.
  Qed.

  Local Instance le_properI `(tA : t A leA eqA)
    : Proper (eqA ==> eqA ==> iff) leA.
  Proof. intros. apply le_proper. Qed.

  (** Morphisms must respect the equality relations on both their
      source (domain) and target (codomain). *)
  Local Instance morph_properI `(tA : t A leA eqA) `(tB : t B leB eqB) (f : A -> B)
    : morph leA eqA leB eqB f -> Proper (eqA ==> eqB) f.
  Proof.
    intros. destruct H. unfold Proper, respectful. apply f_eq0.
  Qed.

  (** Now we will extend the preorders we had to partial orders
      in the obvious ways. There's really nothing interesting
      here. *)

  Definition one : t (fun (_ : True) _ => True) (fun _ _ => True).
  Proof.
    constructor; intros; auto.
    - apply PreO.one.
    - unfold Proper, respectful. intuition.
  Qed.

  Definition two : t (fun b1 b2 : bool => if b1 then b2 = true else True) Logic.eq.
  Proof.
    constructor; intros.
    - apply PreO.two.
    - solve_proper.
    - destruct x, y; auto.
  Qed.

  Definition Nat : t le Logic.eq.
  Proof.
    constructor; intros.
    - apply PreO.Nat.
    - solve_proper.
    - apply Le.le_antisym; assumption.
  Qed.

  Definition discrete (A : Type) : t (@Logic.eq A) Logic.eq.
  Proof.
    constructor; intros.
    - apply PreO.discrete.
    - solve_proper.
    - assumption.
  Qed.

  Definition product `(tA : t A leA eqA) `(tB : t B leB eqB)
    : t (prod_op leA leB) (prod_op eqA eqB).
  Proof. constructor; intros.
         - apply PreO.product; apply PreO.
         - unfold prod_op, Proper, respectful. intros. intuition;
                                                         (eapply le_proper;
                                                          [ ((eapply eq_sym; eassumption) || eassumption)
                                                          | ((eapply eq_sym; eassumption) || eassumption)
                                                          | eassumption ]).
         - unfold prod_op. destruct H, H0. split; apply le_antisym; intuition.
  Qed.

  Definition map `(f : A -> B) `(tB : t B leB eqB) : t
                                                       (map_op f leB) (map_op f eqB).
  Proof. constructor; intros.
         - apply (PreO.map f PreO).
         - unfold map_op; split; simpl in *; intros.
           + rewrite <- H. rewrite <- H0.
             assumption.
           + rewrite H.  rewrite H0. apply H1.
         - unfold map_op; eapply le_antisym; eauto.
  Qed.

  Definition pointwise {A} {B : A -> Type}
             {leB eqB : forall a, B a -> B a -> Prop}
             (tB : forall a, t (leB a) (eqB a)) : @t (forall a, B a) (pointwise_op leB)
                                                     (pointwise_op eqB).
  Proof.
    constructor; intros.
    - apply (PreO.pointwise (fun _ => PreO)).
    - unfold pointwise_op. split; simpl in *; intros.
      rewrite <- H0. rewrite <- H. apply H1.
      rewrite H0. rewrite H. apply H1.
    - unfold pointwise_op. eauto using le_antisym.
  Qed.

  Definition morph_pointwise {A B C} `{tC : t C leC eqC} (f : B -> A)
    : morph (pointwise_op (fun _ => leC)) (pointwise_op (fun _ => eqC))
            (pointwise_op (fun _ => leC)) (pointwise_op (fun _ => eqC))
            (fun g b => g (f b)).
  Proof.
    constructor; intros; simpl in *; intros.
    - apply PreO.morph_pointwise.
    - unfold pointwise_op in *. solve_proper.
  Qed.

  Local Instance prop : t (fun (P Q : Prop) => P -> Q) (fun P Q => P <-> Q).
  Proof.
    constructor; unfold Proper, respectful;
      intuition; split; simpl in *; intros; intuition.
  Qed.

  Local Instance subset (A : Type) : @t (A -> Prop) _ _ := pointwise (fun _ => prop).

End PO.

(** Join semi-lattices, or directed sets. Here we take a partial order
    and add on a maximum operation. Natural numbers are
    one of many examples. We will often generalize sequences, which
    are functions of type (nat -> A), to nets, which are functions of
    type (I -> A), where I is a directed set. *)
Module JoinLat.

  Class Ops {A} : Type :=
    { le : A -> A -> Prop
      ; eq : A -> A -> Prop
      ; max : A -> A -> A
    }.

  Arguments Ops : clear implicits.

  (** When do the operations [le], [eq], and [max] actually represent
      a join semi-lattice? We need [le] and [eq] to be a partial order,
      and we need our [max] operation to actually implement a maximum. *)
  Class t {A : Type} {O : Ops A} : Prop :=
    { PO :> PO.t le eq
      ; max_proper : Proper (eq ==> eq ==> eq) max
      ; max_ok : forall l r, PreO.max (le := le) l r (max l r)
    }.

  Arguments t : clear implicits.

  Local Instance max_properI `(tA : t A)
    : Proper (eq ==> eq ==> eq) max.
  Proof. intros. apply max_proper. Qed.

  Record morph `{OA : Ops A} `{OB : Ops B}
         {f : A -> B} : Prop :=
    { f_PO : PO.morph le eq le eq f
      ; f_max : forall a b, eq (f (max a b)) (max (f a) (f b))
    }.

  Arguments morph {A} OA {B} OB f.

  (** A morphism on join semi-lattices respects the equality relation
      on its source and target. *)
  Lemma f_eq {A B OA OB} {tA : t A OA} {tB : t B OB} {f : A -> B} :
    morph OA OB f -> Proper (eq ==> eq) f.
  Proof.
    unfold Proper, respectful. intros. apply (PO.f_eq (f_PO H)).
    assumption.
  Qed.

  Lemma morph_id {A OA} (tA : t A OA)
    : morph OA OA (fun x => x).
  Proof.
    constructor; intros.
    - apply PO.morph_id.
    - apply PO.eq_refl.
  Qed.

  Local Existing Instance PO.t_equiv.

  Lemma morph_compose {A B C OA OB OC}
        (tA : t A OA) (tB : t B OB) (tC : t C OC)
    : forall f g, morph OA OB f
                  -> morph OB OC g
                  -> morph OA OC (fun x => g (f x)).
  Proof.
    intros. constructor; intros.
    - eapply PO.morph_compose; eapply f_PO; eassumption.
    - rewrite <- (f_max H0). rewrite (f_eq H0). reflexivity.
      apply (f_max H).
  Qed.

  (** Max is very boring for the one-point set *)
  Definition one_ops : Ops True :=
    {| le := fun _ _ => True
       ; eq := fun _ _ => True
       ; max := fun _ _ => I
    |}.

  Definition one : t True one_ops.
  Proof.
    constructor; intros; auto; unfold Proper, respectful; simpl; auto.
    - apply PO.one.
    - destruct l, r. constructor; tauto.
  Qed.

  (** Max for booleans is the boolean OR. *)
  Definition two_ops : Ops bool :=
    {| le := (fun b1 b2 : bool => if b1 then b2 = true else True)
       ; eq := Logic.eq
       ; max := orb
    |}.

  Definition two : t bool two_ops.
  Proof. constructor; intros; (
           apply PO.two || solve_proper
           ||
           (try constructor;
            repeat match goal with
                   | [ b : bool |- _ ] => destruct b
                   end; simpl; auto)).
  Qed.

  Local Instance Nat_ops : Ops nat :=
    {| le := Peano.le
       ; eq := Logic.eq
       ; max := Peano.max
    |}.

  Local Instance Nat : t nat Nat_ops.
  Proof. constructor; intros.
         - apply PO.Nat.
         - solve_proper.
         - constructor. simpl. apply Max.le_max_l. apply Max.le_max_r.
           apply Max.max_lub.
  Qed.

  (** Max for propositions is the propositional OR, i.e., disjunction *)
  Local Instance prop_ops : Ops Prop :=
    {| le := fun P Q : Prop => P -> Q
       ; eq := fun P Q : Prop => P <-> Q
       ; max := fun P Q : Prop => P \/ Q
    |}.

  Local Instance prop : t Prop prop_ops.
  Proof.
    constructor; simpl; intros; constructor; simpl; firstorder.
  Qed.

  Definition pointwise_ops {A B} (O : forall a : A, Ops (B a)) : Ops (forall a, B a) :=
    {| le := pointwise_op (fun a => @le _ (O a))
       ; eq := pointwise_op (fun a => @eq _ (O a))
       ; max :=  (fun f g a => @max _ (O a) (f a) (g a))
    |}.

  Definition pointwise
             `(tB : forall (a : A), t (B a) (OB a)) :
    t (forall a, B a) (pointwise_ops OB).
  Proof. constructor; simpl; intros.
         - apply PO.pointwise; intros. eapply @PO; apply tB.
         - unfold respectful, Proper, pointwise_op. intros.
           apply max_proper. apply H. apply H0.
         - constructor; unfold pointwise_op; simpl; intros; apply max_ok.
           apply H. apply H0.
  Qed.

  Definition morph_pointwise {C OC} {tC : t C OC} `(f : B -> A)
    : morph (pointwise_ops (fun _ => OC)) (pointwise_ops (fun _ => OC))
            (fun g b => g (f b)).
  Proof.
    constructor; intros; simpl in *; intros.
    - apply PO.morph_pointwise.
    - unfold pointwise_op. intros. apply PO.eq_refl.
  Qed.

  Local Instance subset (A : Type) : t (A -> Prop) (pointwise_ops (fun _ => prop_ops))
    := pointwise (fun _ => prop).

  Definition product_ops `(OA : Ops A) `(OB : Ops B) : Ops (A * B) :=
    {| le := prod_op le le
       ; eq := prod_op eq eq
       ; max := fun (x y : A * B) => (max (fst x) (fst y), max (snd x) (snd y))
    |}.

  Definition product {A OA B OB} (tA : t A OA) (tB : t B OB)
    : t (A * B) (product_ops OA OB).
  Proof. constructor;
           (apply PO.product; apply PO) ||
                                        (simpl; intros;
                                         constructor; unfold prod_op in *; simpl; intros;
                                         repeat match goal with
                                                | [ p : (A * B)%type |- _ ] => destruct p; simpl
                                                | [ p : _ /\ _ |- _ ] => destruct p; simpl
                                                | [  |- _ /\ _ ] => split
                                                | [ |- _ ] => eapply PreO.max_l; apply max_ok
                                                | [ |- _ ] => eapply PreO.max_r; apply max_ok
                                                | [ |- _ ] => apply max_proper; assumption
                                                end).
         eapply PreO.max_least. apply max_ok. assumption. assumption.
         eapply PreO.max_least. apply max_ok. assumption. assumption.
  Qed.

End JoinLat.

(** A meet semi-lattice is literally a join semi-lattice turned
    upside-down. Instead of having a [max] operation, it has a [min].
    The code is essentially copied from [JoinLat]. *)
Module MeetLat.

  Class Ops {A} : Type :=
    { le : A -> A -> Prop
      ; eq : A -> A -> Prop
      ; min : A -> A -> A
    }.

  Arguments Ops : clear implicits.

  Class t {A : Type} {O : Ops A} : Prop :=
    { PO :> PO.t le eq
      ; min_proper : Proper (eq ==> eq ==> eq) min
      ; min_ok : forall l r, PreO.min (le := le) l r (min l r)
    }.

  Arguments t : clear implicits.

  Local Instance min_properI `(tA : t A)
    : Proper (eq ==> eq ==> eq) min.
  Proof. intros. apply min_proper. Qed.

  Record morph `{OA : Ops A} `{OB : Ops B}
         {f : A -> B} : Prop :=
    { f_PO : PO.morph le eq le eq f
      ; f_min : forall a b, eq (f (min a b)) (min (f a) (f b))
    }.

  Arguments morph {A} OA {B} OB f.

  Lemma f_eq {A B OA OB} {tA : t A OA} {tB : t B OB} {f : A -> B} :
    morph OA OB f -> Proper (eq ==> eq) f.
  Proof.
    unfold Proper, respectful. intros. apply (PO.f_eq (f_PO H)).
    assumption.
  Qed.

  Lemma morph_id {A OA} (tA : t A OA)
    : morph OA OA (fun x => x).
  Proof.
    constructor; intros.
    - apply PO.morph_id.
    - apply PO.eq_refl.
  Qed.

  Local Existing Instance PO.t_equiv.

  Lemma morph_compose {A B C OA OB OC}
        (tA : t A OA) (tB : t B OB) (tC : t C OC)
    : forall f g, morph OA OB f
                  -> morph OB OC g
                  -> morph OA OC (fun x => g (f x)).
  Proof.
    intros. constructor; intros.
    - eapply PO.morph_compose; eapply f_PO; eassumption.
    - rewrite <- (f_min H0). rewrite (f_eq H0). reflexivity.
      apply (f_min H).
  Qed.

  Section Props.
    Context `{tA : t A}.

    Lemma min_l : forall l r, le (min l r) l.
    Proof.
      intros. eapply PreO.min_l. apply min_ok.
    Qed.

    Lemma min_r : forall l r, le (min l r) r.
    Proof.
      intros. eapply PreO.min_r. apply min_ok.
    Qed.

    Lemma min_comm : forall l r, eq (min l r) (min r l).
    Proof.
      intros.
      apply PO.min_unique with l r.
      - apply min_ok.
      - apply PreO.min_comm. apply min_ok.
    Qed.

    Lemma min_assoc : forall a b c,
        eq (min a (min b c)) (min (min a b) c).
    Proof.
      intros.
      apply PO.min_unique with a (min b c).
      - apply min_ok.
      - apply <- (PreO.min_assoc _ a b c); apply min_ok.
    Qed.

    Lemma min_idempotent : forall a, eq (min a a) a.
    Proof.
      intros. apply PO.min_unique with a a.
      apply min_ok. apply PreO.min_idempotent. apply PO.PreO.
    Qed.

  End Props.

  Definition one_ops : Ops True :=
    {| le := fun _ _ => True
       ; eq := fun _ _ => True
       ; min := fun _ _ => I
    |}.

  Definition one : t True one_ops.
  Proof.
    constructor; intros; auto; unfold Proper, respectful; simpl; auto.
    - apply PO.one.
    - destruct l, r. constructor; tauto.
  Qed.

  Definition two_ops : Ops bool :=
    {| le := (fun b1 b2 : bool => if b1 then b2 = true else True)
       ; eq := Logic.eq
       ; min := andb
    |}.

  Definition two : t bool two_ops.
  Proof. constructor; intros; (
           apply PO.two || solve_proper
           ||
           (try constructor;
            repeat match goal with
                   | [ b : bool |- _ ] => destruct b
                   end; simpl; auto)).
  Qed.

  Local Instance prop_ops : Ops Prop :=
    {| le := fun P Q : Prop => P -> Q
       ; eq := fun P Q : Prop => P <-> Q
       ; min := fun P Q : Prop => P /\ Q
    |}.

  Local Instance prop : t Prop prop_ops.
  Proof.
    constructor; simpl; intros; constructor; simpl; firstorder.
  Qed.

  Definition pointwise_ops {A B} (O : forall a : A, Ops (B a)) : Ops (forall a, B a) :=
    {| le := pointwise_op (fun a => @le _ (O a))
       ; eq := pointwise_op (fun a => @eq _ (O a))
       ; min :=  (fun f g a => @min _ (O a) (f a) (g a))
    |}.

  Definition pointwise
             `(tB : forall (a : A), t (B a) (OB a)) :
    t (forall a, B a) (pointwise_ops OB).
  Proof. constructor; simpl; intros.
         - apply PO.pointwise; intros. eapply @PO; apply tB.
         - unfold respectful, Proper, pointwise_op. intros.
           apply min_proper. apply H. apply H0.
         - constructor; unfold pointwise_op; simpl; intros; apply min_ok.
           apply H. apply H0.
  Qed.

  Definition morph_pointwise {C OC} {tC : t C OC} `(f : B -> A)
    : morph (pointwise_ops (fun _ => OC)) (pointwise_ops (fun _ => OC))
            (fun g b => g (f b)).
  Proof.
    constructor; intros; simpl in *; intros.
    - apply PO.morph_pointwise.
    - unfold pointwise_op. intros. apply PO.eq_refl.
  Qed.

  Local Instance subset (A : Type) : t (A -> Prop) (pointwise_ops (fun _ => prop_ops))
    := pointwise (fun _ => prop).

  Definition product_ops `(OA : Ops A) `(OB : Ops B) : Ops (A * B) :=
    {| le := prod_op le le
       ; eq := prod_op eq eq
       ; min := fun (x y : A * B) => (min (fst x) (fst y), min (snd x) (snd y))
    |}.

  Definition product {A OA B OB} (tA : t A OA) (tB : t B OB)
    : t (A * B) (product_ops OA OB).
  Proof. constructor;
           (apply PO.product; apply PO) ||
                                        (simpl; intros;
                                         constructor; unfold prod_op in *; simpl; intros;
                                         repeat match goal with
                                                | [ p : (A * B)%type |- _ ] => destruct p; simpl
                                                | [ p : _ /\ _ |- _ ] => destruct p; simpl
                                                | [  |- _ /\ _ ] => split
                                                | [ |- _ ] => eapply PreO.min_l; apply min_ok
                                                | [ |- _ ] => eapply PreO.min_r; apply min_ok
                                                | [ |- _ ] => apply min_proper; assumption
                                                end).
         eapply PreO.min_greatest. apply min_ok. assumption. assumption.
         eapply PreO.min_greatest. apply min_ok. assumption. assumption.
  Qed.

End MeetLat.

(** A lattice is both a join semi-lattice and a meet semi-lattice;
    it has both a [max] operation and a [min] operation. Again,
    this is basically just copied from the two modules above. *)
Module Lattice.

  Class Ops {A} : Type :=
    { le : A -> A -> Prop
      ; eq : A -> A -> Prop
      ; max : A -> A -> A
      ; min : A -> A -> A
    }.

  Arguments Ops : clear implicits.

  Class t {A : Type} {O : Ops A} : Prop :=
    { PO :> PO.t le eq
      ; max_proper : Proper (eq ==> eq ==> eq) max
      ; max_ok : forall l r, PreO.max (le := le) l r (max l r)
      ; min_proper : Proper (eq ==> eq ==> eq) min
      ; min_ok : forall l r, PreO.min (le := le) l r (min l r)
    }.

  Arguments t : clear implicits.

  Definition toMeetLatOps' {A} (ops : Ops A) : MeetLat.Ops A :=
    {| MeetLat.le := le
       ; MeetLat.eq := eq
       ; MeetLat.min := min
    |}.

  Local Instance toMeetLatOps {A} : Ops A -> MeetLat.Ops A
    := toMeetLatOps'.

  Local Instance toMeetLat {A ops} : t A ops -> MeetLat.t A (toMeetLatOps ops).
  Proof.
    intros. constructor.
    - apply PO.
    - apply min_proper.
    - apply min_ok.
  Qed.

  Definition toJoinLatOps' {A} (ops : Ops A) : JoinLat.Ops A :=
    {| JoinLat.le := le
       ; JoinLat.eq := eq
       ; JoinLat.max := max
    |}.

  Local Instance toJoinLatOps {A} : Ops A -> JoinLat.Ops A
    := toJoinLatOps'.

  Local Instance toJoinLat {A ops} : t A ops -> JoinLat.t A (toJoinLatOps ops).
  Proof.
    intros. constructor.
    - apply PO.
    - apply max_proper.
    - apply max_ok.
  Qed.

  Local Instance max_properI `(tA : t A)
    : Proper (eq ==> eq ==> eq) max.
  Proof. intros. apply max_proper. Qed.

  Local Instance min_properI `(tA : t A)
    : Proper (eq ==> eq ==> eq) min.
  Proof. intros. apply min_proper. Qed.

  Record morph `{OA : Ops A} `{OB : Ops B}
         {f : A -> B} : Prop :=
    { f_PO : PO.morph le eq le eq f
      ; f_max : forall a b, eq (f (max a b)) (max (f a) (f b))
      ; f_min : forall a b, eq (f (min a b)) (min (f a) (f b))
    }.

  Arguments morph {A} OA {B} OB f.

  Lemma f_eq {A B OA OB} {tA : t A OA} {tB : t B OB} {f : A -> B} :
    morph OA OB f -> Proper (eq ==> eq) f.
  Proof.
    unfold Proper, respectful. intros. apply (PO.f_eq (f_PO H)).
    assumption.
  Qed.

  Lemma morph_id {A OA} (tA : t A OA)
    : morph OA OA (fun x => x).
  Proof.
    constructor; intros.
    - apply PO.morph_id.
    - apply PO.eq_refl.
    - apply PO.eq_refl.
  Qed.

  Local Existing Instance PO.t_equiv.

  Lemma morph_compose {A B C OA OB OC}
        (tA : t A OA) (tB : t B OB) (tC : t C OC)
    : forall f g, morph OA OB f
                  -> morph OB OC g
                  -> morph OA OC (fun x => g (f x)).
  Proof.
    intros. constructor; intros.
    - eapply PO.morph_compose; eapply f_PO; eassumption.
    - rewrite <- (f_max H0). rewrite (f_eq H0). reflexivity.
      apply (f_max H).
    - rewrite <- (f_min H0). rewrite (f_eq H0). reflexivity.
      apply (f_min H).
  Qed.

  Definition one_ops : Ops True :=
    {| le := fun _ _ => True
       ; eq := fun _ _ => True
       ; max := fun _ _ => I
       ; min := fun _ _ => I
    |}.

  Definition one : t True one_ops.
  Proof.
    constructor; intros; auto; unfold Proper, respectful; simpl; auto.
    - apply PO.one.
    - destruct l, r. constructor; tauto.
    - destruct l, r. constructor; tauto.
  Qed.

  Definition two_ops : Ops bool :=
    {| le := (fun b1 b2 : bool => if b1 then b2 = true else True)
       ; eq := Logic.eq
       ; max := orb
       ; min := andb
    |}.

  Definition two : t bool two_ops.
  Proof. constructor; intros; (
           apply PO.two || solve_proper
           ||
           (try constructor;
            repeat match goal with
                   | [ b : bool |- _ ] => destruct b
                   end; simpl; auto)).
  Qed.

  Local Instance prop_ops : Ops Prop :=
    {| le := fun P Q : Prop => P -> Q
       ; eq := fun P Q : Prop => P <-> Q
       ; max := fun P Q : Prop => P \/ Q
       ; min := fun P Q : Prop => P /\ Q
    |}.

  Local Instance prop : t Prop prop_ops.
  Proof.
    constructor; simpl; intros; constructor; simpl; firstorder.
  Qed.

  Definition pointwise_ops {A B} (O : forall a : A, Ops (B a)) : Ops (forall a, B a) :=
    {| le := pointwise_op (fun a => @le _ (O a))
       ; eq := pointwise_op (fun a => @eq _ (O a))
       ; max :=  (fun f g a => @max _ (O a) (f a) (g a))
       ; min :=  (fun f g a => @min _ (O a) (f a) (g a))
    |}.

  Definition pointwise
             `(tB : forall (a : A), t (B a) (OB a)) :
    t (forall a, B a) (pointwise_ops OB).
  Proof. constructor; simpl; intros.
         - apply PO.pointwise; intros. eapply @PO; apply tB.
         - unfold respectful, Proper, pointwise_op. intros.
           apply max_proper. apply H. apply H0.
         - constructor; unfold pointwise_op; simpl; intros; apply max_ok.
           apply H. apply H0.
         - unfold respectful, Proper, pointwise_op. intros.
           apply min_proper. apply H. apply H0.
         - constructor; unfold pointwise_op; simpl; intros; apply min_ok.
           apply H. apply H0.
  Qed.

  Definition morph_pointwise {C OC} {tC : t C OC} `(f : B -> A)
    : morph (pointwise_ops (fun _ => OC)) (pointwise_ops (fun _ => OC))
            (fun g b => g (f b)).
  Proof.
    constructor; intros; simpl in *; intros.
    - apply PO.morph_pointwise.
    - unfold pointwise_op. intros. apply PO.eq_refl.
    - unfold pointwise_op. intros. apply PO.eq_refl.
  Qed.

  Local Instance subset (A : Type) : t (A -> Prop) (pointwise_ops (fun _ => prop_ops))
    := pointwise (fun _ => prop).

  Definition product_ops `(OA : Ops A) `(OB : Ops B) : Ops (A * B) :=
    {| le := prod_op le le
       ; eq := prod_op eq eq
       ; max := fun (x y : A * B) => (max (fst x) (fst y), max (snd x) (snd y))
       ; min := fun (x y : A * B) => (min (fst x) (fst y), min (snd x) (snd y))
    |}.

  Definition product {A OA B OB} (tA : t A OA) (tB : t B OB)
    : t (A * B) (product_ops OA OB).
  Proof. constructor;
           (apply PO.product; apply PO) ||
                                        (simpl; intros;
                                         constructor; unfold prod_op in *; simpl; intros;
                                         repeat match goal with
                                                | [ p : (A * B)%type |- _ ] => destruct p; simpl
                                                | [ p : _ /\ _ |- _ ] => destruct p; simpl
                                                | [  |- _ /\ _ ] => split
                                                | [ |- _ ] => eapply PreO.max_l; apply max_ok
                                                | [ |- _ ] => eapply PreO.max_r; apply max_ok
                                                | [ |- _ ] => eapply PreO.min_l; apply min_ok
                                                | [ |- _ ] => eapply PreO.min_r; apply min_ok
                                                | [ |- _ ] => apply max_proper; assumption
                                                | [ |- _ ] => apply min_proper; assumption
                                                end).
         eapply PreO.max_least. apply max_ok. assumption. assumption.
         eapply PreO.max_least. apply max_ok. assumption. assumption.
         eapply PreO.min_greatest. apply min_ok. assumption. assumption.
         eapply PreO.min_greatest. apply min_ok. assumption. assumption.
  Qed.

End Lattice.

Module L := Lattice.

Section CompleteLattice.
  Import Lattice.

  Context {A : Type}.
  Context {O : Ops A}.
  Context {l : Lattice.t A O}.

  Definition glb (f : A -> Prop) (a : A)
    := (forall a', f a' -> le a a')
       /\ forall a'', (forall a', f a' -> le a'' a') -> le a'' a.

  Definition lub (f : A -> Prop) (a : A)
    :=
      (forall a', f a' -> le a' a)
      /\ forall a'', (forall a', f a' -> le a' a'') -> le a a''.

  Class CompleteLattice
    : Type :=
    { cl_inf : forall (f : A -> Prop), A;
      inf_glb : forall (f : A -> Prop), glb f (cl_inf f);
      cl_sup : forall (f : A -> Prop), A;
      sup_lub : forall (f : A -> Prop), lub f (cl_sup f) }.

  Context {cl : CompleteLattice}.

  Definition monotonic_function (f : A -> A) :=
    forall a a', le a a' -> le (f a) (f a').

  Variable (f : A -> A).
  Definition prefixed_point (a : A) := le (f a) a.
  Definition postfixed_point (a : A) := le a (f a).
  Definition fixed_point (a : A) := eq (f a) a.

  Lemma cl_inf_superset
    : forall (P P' : A -> Prop),
      (forall a, P' a -> P a)
      -> le (cl_inf P) (cl_inf P').
  Proof.
    intros.
    eapply (proj2 (inf_glb P')); intros.
    eapply (proj1 (inf_glb P)); eauto.
  Qed.

  Lemma cl_inf_same_set
    : forall (f f' : A -> Prop),
      (forall a, f a <-> f' a)
      -> eq (cl_inf f) (cl_inf f').
  Proof.
    intros.
    apply PO.le_antisym; eapply cl_inf_superset;
      intuition; eapply H; eauto.
  Qed.

  Lemma cl_sup_subset
    : forall (P P' : A -> Prop),
      (forall a, P a -> P' a)
      -> le (cl_sup P) (cl_sup P').
  Proof.
    intros.
    eapply (proj2 (sup_lub P)); intros.
    eapply (proj1 (sup_lub P')); eauto.
  Qed.

  Lemma cl_sup_same_set
    : forall (f f' : A -> Prop),
      (forall a, f a <-> f' a)
      -> eq (cl_sup f) (cl_sup f').
  Proof.
    intros.
    apply PO.le_antisym; eapply cl_sup_subset;
      intuition; eapply H; eauto.
  Qed.

  Lemma fixed_point_is_prefixed
    : forall a, fixed_point a -> prefixed_point a.
  Proof.
    unfold fixed_point, prefixed_point; intros.
    eapply PO.le_proper; eauto.
    apply PO.eq_refl.
    apply PreO.le_refl.
  Qed.

  Lemma fixed_point_is_postfixed
    : forall a, fixed_point a -> postfixed_point a.
  Proof.
    unfold fixed_point, postfixed_point; intros.
    eapply PO.le_proper; eauto.
    apply PO.eq_refl.
    apply PreO.le_refl.
  Qed.

  Lemma Is_PrefixedPoint
        (f_monotonic : monotonic_function f)
    : prefixed_point (cl_inf prefixed_point).
  Proof.
    unfold prefixed_point at 1.
    destruct (inf_glb prefixed_point).
    apply H0.
    intros.
    unfold prefixed_point in H1.
    eapply PreO.le_trans; eauto.
  Qed.

  Lemma Is_LeastFixedPoint
        (f_monotonic : monotonic_function f)
    : fixed_point (cl_inf prefixed_point).
  Proof.
    pose proof Is_PrefixedPoint.
    apply f_monotonic in H.
    destruct (inf_glb prefixed_point).
    apply H0 in H.
    apply PO.le_antisym; eauto.
    apply Is_PrefixedPoint; eauto.
    eauto.
  Qed.

  Lemma Is_PostfixedPoint
        (f_monotonic : monotonic_function f)
    : postfixed_point (cl_sup postfixed_point).
  Proof.
    unfold postfixed_point at 1.
    destruct (sup_lub postfixed_point).
    apply H0.
    intros.
    unfold postfixed_point in H1.
    eapply PreO.le_trans; eauto.
  Qed.

  Lemma Is_GreatestFixedPoint
        (f_monotonic : monotonic_function f)
    : fixed_point (cl_sup postfixed_point).
  Proof.
    pose proof Is_PostfixedPoint.
    apply f_monotonic in H.
    destruct (sup_lub postfixed_point).
    apply H0 in H.
    apply PO.le_antisym; eauto.
    apply Is_PostfixedPoint; eauto.
    eauto.
  Qed.

  Lemma LeastFixedPoint_ind
        (Inv : A)
    : (le (f Inv) Inv)
      -> le (cl_inf prefixed_point) Inv.
  Proof.
    intros; destruct (inf_glb prefixed_point) as [? ?].
    eapply H0; simpl; intros.
    unfold prefixed_point; eauto.
  Qed.

  Lemma GreatestFixedPoint_ind
        (Inv : A)
    : (le Inv (f Inv))
      -> le Inv (cl_sup postfixed_point).
  Proof.
    intros; destruct (sup_lub postfixed_point) as [? ?].
    eapply H0; simpl; intros.
    unfold prefixed_point; eauto.
  Qed.

End CompleteLattice.

(** A frame represents the essence of the algebraic structure of topologies,
    without the requirement that this algebraic structure be formed by
    subsets of an underlying space. The frame is just the algebra itself.
    A frame has a supremum operation, which corresponds to the fact that
    topologies are closed under arbitrary union.
    We call elements of a frame "opens" to indicate that they are reminiscent
    of open sets.

    Frames are also often referred to as locales. They're the same things, but
    are used to indicate opposite categories. The category of frames is the
    opposite of the category of locales. We do this because continuous functions
    are, in a sense, "backwards". A continuous function in topology
    [f : A -> B] is defined by its inverse image which takes open sets in
    [B] to open sets in [A]. So a continuous function from [A] to [B] corresponds
    to a frame homomorphism from the frame representing the topology of [B] to the
    frame representing the topology of [A]. A frame homomorphism is a morphism
    in the category of frames. The morphisms of the category of locales are called
    continuous maps, and since it's the opposite category, a continuous
    function from [A] to [B] corresponds to a continuous map from the locale
    for [A] to the locale for [B].
 *)
Module Frame.
  Class Ops {A} :=
    { LOps :> L.Ops A
      ; sup : forall {Ix : Type}, (Ix -> A) -> A
    }.

  Arguments Ops : clear implicits.

  Class t {A} {OA : Ops A}: Type :=
    { L :> L.t A LOps
      ; sup_proper : forall {Ix : Type},
          Proper (pointwise_relation _ L.eq ==> L.eq) (@sup _ _ Ix)
      ; sup_ok :  forall {Ix : Type} (f : Ix -> A), PreO.sup (le := L.le) f (sup f)
      ; sup_distr : forall x {Ix : Type} (f : Ix -> A)
        , L.eq (L.min x (sup f)) (sup (fun i => L.min x (f i)))
    }.

  Arguments t : clear implicits.
  Section Facts.
    Context {A OA} {tA : t A OA}.

    Definition sup_proper_u : forall {Ix : Type} (f g : Ix -> A),
        (forall (i : Ix), L.eq (f i) (g i)) -> L.eq (sup f) (sup g).
    Proof.
      intros. apply sup_proper. unfold pointwise_relation.
      assumption.
    Qed.

    (** Every frame must have a top and bottom element. *)

    Definition top : A := sup (fun a => a).

    Definition top_ok : PreO.top (le := L.le) top.
    Proof.
      unfold PreO.top. simpl. pose proof (sup_ok (fun a => a)).
      destruct H. apply sup_ge.
    Qed.

    Definition bottom : A := sup (fun contra : False => False_rect _ contra).

    Definition bottom_ok : PreO.bottom (le := L.le) bottom.
    Proof.
      unfold PreO.bottom. intros.
      apply (PreO.sup_least (fun contra : False => False_rect _ contra)).
      apply sup_ok. intros; contradiction.
    Qed.

  End Facts.
  Section Morph.
    Context {A OA} {tA : t A OA}.
    Context {B OB} {tB : t B OB}.

    Record morph {f : A -> B} : Prop :=
      { f_L : L.morph LOps LOps f
        ; f_sup : forall {Ix : Type} (g : Ix -> A), L.eq (f (sup g)) (sup (fun i => f (g i)))
        ; f_top : L.eq (f top) top
      }.

    Arguments morph : clear implicits.

    Lemma f_eq {f : A -> B} :
      morph f -> Proper (L.eq ==> L.eq) f.
    Proof.
      intros. apply (L.f_eq (f_L H)).
    Qed.

    Local Existing Instance PO.t_equiv.

    Lemma f_bottom {f : A -> B} : morph f -> L.eq (f bottom) bottom.
    Proof.
      intros MF. unfold bottom.
      rewrite (f_sup MF). apply sup_proper.
      unfold pointwise_relation. intros. contradiction.
    Qed.

  End Morph.

  Arguments morph {A} OA {B} OB f.

  Section MorphProps.
    Context {A OA} {tA : t A OA}.

    Local Existing Instance PO.t_equiv.

    Lemma morph_id : morph OA OA (fun x => x).
    Proof.
      intros. constructor. apply L.morph_id. apply L.
      intros; eapply reflexivity.
      eapply reflexivity.
    Qed.

    Lemma morph_compose {B OB} {tB : t B OB}
          {C OC} {tC : t C OC}
          (f : A -> B) (g : B -> C)
      : morph OA OB f
        -> morph OB OC g
        -> morph OA OC (fun x => g (f x)).
    Proof. intros. constructor.
           - eapply L.morph_compose; (apply L || (eapply f_L; eassumption)).
           - intros. rewrite <- (f_sup H0). rewrite (f_eq H0).
             reflexivity. rewrite (f_sup H). reflexivity.
           - rewrite <- (f_top H0). rewrite (f_eq H0).
             reflexivity. rewrite (f_top H). reflexivity.
    Qed.

  End MorphProps.

  Definition one_ops : Ops True :=
    {| LOps := L.one_ops
       ; sup := fun _ _ => I
    |}.

  Definition one : t True one_ops.
  Proof. constructor; intros; auto.
         - apply L.one.
         - unfold Proper, respectful. intros. reflexivity.
         - constructor; trivial.
  Qed.

  (** Propositions form a frame, where supremum is given by the
      existential quantifier. *)
  Local Instance prop_ops : Ops Prop :=
    {| LOps := L.prop_ops
       ; sup := (fun _ f => exists i, f i)
    |}.

  Local Instance prop : t Prop prop_ops.
  Proof. constructor; simpl; intros.
         - apply L.prop.
         - constructor; unfold pointwise_relation in H; simpl in H;
             intros [??]; eexists; apply H; eassumption.
         - constructor; simpl; intros.
           + exists i. assumption.
           + destruct H0. apply (H x). assumption.
         - split; intros.
           + destruct H as (xa & i & fia). exists i. intuition.
           + destruct H as (i & xa & fia). split. assumption.
             exists i. assumption.
  Qed.

  Definition pointwise_ops `(OB : forall a : A, Ops (B a))
    : Ops (forall a, B a) :=
    {| LOps := L.pointwise_ops (fun _ => LOps)
       ; sup := fun _ f => fun x => sup (fun i => f i x)
    |}.

  Definition pointwise `(forall a : A, t (B a) (OB a))
    : t (forall a, B a) (pointwise_ops OB).
  Proof. constructor.
         - apply L.pointwise. intros. apply L.
         - simpl. unfold Proper, respectful, pointwise_relation, pointwise_op.
           intros. apply sup_proper. unfold pointwise_relation.
           intros a'. apply H0.
         - constructor; simpl; unfold pointwise_op; intros.
           pose proof (@sup_ok _ _ (H a) Ix (fun i => f i a)).
           apply H0.
           pose proof (@sup_ok _ _ (H a) Ix (fun i => f i a)).
           apply H1. intros. apply H0.
         - simpl. unfold pointwise_op. intros.
           apply (sup_distr (t := H a)).
  Qed.

  Lemma sup_pointwise {A} {OA} {X : t A OA} {Ix Ix'} (f : Ix -> A) (g : Ix' -> A)
    : (forall (i : Ix), exists (j : Ix'), L.le (f i) (g j))
      -> L.le (sup f) (sup g).
  Proof.
    intros. eapply PreO.sup_least. apply sup_ok. intros.
    destruct (H i). eapply PreO.le_trans. eassumption.
    apply PreO.sup_ge. apply sup_ok.
  Qed.

  Definition morph_pointwise {A B C OC} {tC : t C OC} (f : B -> A)
    : morph (pointwise_ops (fun _ : A => OC)) (pointwise_ops (fun _ : B => OC))
            (fun g b => g (f b)).
  Proof.
    constructor; intros; simpl in *; intros.
    - apply L.morph_pointwise.
    - unfold pointwise_op. intros. apply PO.eq_refl.
    - unfold pointwise_op. intros. apply PO.le_antisym.
      + apply sup_pointwise. intros. exists (fun b => i (f b)).
        apply PreO.le_refl.
      + apply sup_pointwise. intros. exists (fun _ => i a). apply PreO.le_refl.
  Qed.

  Definition subset_ops A : Ops (A -> Prop) := pointwise_ops (fun _ => prop_ops).

  Definition subset (A : Type) : t (A -> Prop) (subset_ops A):=
    pointwise (fun _ : A => prop).

  (** [cmap] represents a continuous map on locales. It is just a
      package for a frame homomorphism running in the opposite direction. *)
  Record cmap {A OA} {B OB} :=
    { finv :> B -> A
      ; cont : morph OB OA finv
    }.

  Arguments cmap {A} OA {B} OB.

  (** A point in [A] is a continuous map from the frame representing
      a space with one point ([Prop]) to [A]. *)
  Definition point {A} (OA : Ops A) := cmap prop_ops OA.

  (** Every function [f : A -> B] is continuous on the topology
      which includes all subsets. *)
  Definition subset_map {A B} (f : A -> B) : cmap (subset_ops A) (subset_ops B).
  Proof.
    refine ( {| finv P x := P (f x) |}).
    apply morph_pointwise.
  Defined.

  Definition cmap_compose {A B C OA OB OC}
             {tA : t A OA} {tB : t B OB} {tC : t C OC}
             (f : cmap OA OB) (g : cmap OB OC) : cmap OA OC.
  Proof. refine (
             {| finv x := finv f (finv g x) |}
           ). eapply morph_compose; eapply cont.
  Defined.

End Frame.

(** A definition of commutative and idempotent semigroups.
    This is effectively a semi-lattice (it can be a join semi-lattice
    or a meet semi-lattice depending on your attitude) defined
    solely in terms of its min or max operation.
 *)

Module CommIdemSG.

  Generalizable All Variables.

  (** [dot] is a binary operation which is commutative, idempotent, and
    associative. It is effectively a max or min. *)
  Class t {A} {eq : A -> A -> Prop} {dot : A -> A -> A} :=
    { eq_equiv :> Equivalence eq
      ; dot_proper :> Proper (eq ==> eq ==> eq) dot
      ; dot_idempotent : forall a, eq (dot a a) a
      ; dot_comm : forall a b, eq (dot a b) (dot b a)
      ; dot_assoc : forall a b c, eq (dot a (dot b c)) (dot (dot a b) c)
    }.

  Arguments t : clear implicits.

  Section Facts.
    Context `{tA : t A eql dot}.

    (** Here we define a "<=" relation which makes the [dot] a
    [min] operation for a meet semi-lattice *)
    Definition ops : MeetLat.Ops A :=
      {| MeetLat.le := fun x y => eql (dot x y) x
         ; MeetLat.eq := eql
         ; MeetLat.min := dot
      |}.

    Local Instance ops' : MeetLat.Ops A := ops.

    (** Next, we prove successively, that these definitions using
    the [dot] operator indeed define a preorder, a partial order,
    and finally a meet semi-lattice. *)
    Theorem asPreO : PreO.t MeetLat.le.
    Proof.
      constructor; simpl; intros.
      - apply dot_idempotent.
      - rewrite <- H. rewrite <- H0 at 2.
        rewrite dot_assoc. reflexivity.
    Qed.

    Theorem asPO : PO.t MeetLat.le eql.
    Proof.
      constructor.
      - apply asPreO.
      - repeat intro; simpl; split; intros.
        rewrite <- H, <- H0. assumption.
        rewrite H, H0. assumption.
      - simpl. intros. rewrite <- H. rewrite <- H0 at 2.
        rewrite dot_comm. reflexivity.
    Qed.

    Local Instance asMeetLat : MeetLat.t A ops.
    Proof.
      constructor.
      - apply asPO.
      - solve_proper.
      - intros. constructor; simpl; intros.
        + rewrite dot_comm. rewrite dot_assoc.
          rewrite dot_idempotent. reflexivity.
        + rewrite <- dot_assoc. rewrite dot_idempotent.
          reflexivity.
        + rewrite <- H at 2. rewrite <- H0 at 2.
          rewrite (dot_comm l r). rewrite dot_assoc.
          reflexivity.
    Qed.

  End Facts.
End CommIdemSG.