Require Import Unicode.Utf8 Program.Tactics Program.Equality Program.Basics Logic.FunctionalExtensionality.

Require Import ssreflect.
Set Bullet Behavior "Strict Subproofs".

From ctt Require Import Notation Var OrderTheory Axioms Program OpSem Closure Tower Sequent TypeSystem.
From ctt Require Tactic.

Module T := Tactic.

Require Import Coq.omega.Omega.
Open Scope program_scope.

Module Tac.

  Ltac prove_pick_eq :=
    match goal with
    | |- ?τ @ ?A = ?R => by [eapply TS.Pick_lemma; eauto]
    | |- ?R = ?τ @ ?A => by [symmetry; eapply TS.Pick_lemma; eauto]
    end.

  Ltac tower_intro :=
    rewrite /Tower.t -Clo.roll.

  Ltac connective_eq_type :=
    apply: Sig.conn; eauto; constructor.

  Local Ltac accum_lvl_aux x n :=
    match goal with
    | H : τ[?n'] _ |- _ => move: H; accum_lvl_aux x (n + n'); move=> H
    | |- _ => pose x := n
    end.

  Ltac accum_lvl x :=
    accum_lvl_aux x 0.

  Ltac tower_mono :=
    apply: Tower.monotonicity; last by [eassumption];
    cbn; omega.

  Ltac prove_eval :=
    match goal with
    | |- ?A ⇓ ?Av => eauto
    end.

  (* When you need to show 'τ[n] (A, R)' but R is not of the right
   shape.  This tactic will replace R with a unification variable,
   which allows you to make progress in your proof; then, you have to
   prove hat R was is the same as whatever the unification variable
   got instantiated to. *)

  Ltac ts_choose_rel myrel :=
    match goal with
    | |- τ[_] (_, ?R) =>
      (suff: R = myrel); first T.rewrite_
    end.

  Ltac ts_flex_rel :=
    match goal with
    | |- τ[_] (_, ?R) =>
      let R' := fresh in
      evar (R' : rel);
      (suff: R = R'); first T.rewrite_; rewrite /R'; clear R'
    end.

  Ltac prove_step :=
    try by [eassumption];
    match goal with
    | |- _ ⊧ _ ∼ _ => esplit; split
    | |- _ ⊧ _ ∋ _ ∼ _ => esplit; split
    | |- τ[_] _ => tower_intro
    | |- Sig.t _ _ (Prog.univ _, _) => apply: Sig.init
    | |- Sig.t _ _ (_, _) => apply: Sig.conn
    | |- Spine.t _ (Prog.univ _, _) => Spine.simplify; repeat T.split; [idtac | eauto | reflexivity] ; eauto
    | |- Connective.cext _ _ => repeat econstructor
    | |- Connective.has _ _ _ => econstructor
    | |- _ ⇓ _ => prove_eval
    | |- _ ≤ _ => omega
    | |- ∃ _ : nat, _ => esplit
    | |- τω _ => rewrite /τω
    | |- (_ ⊧ _ ∼ _) → _ => case => [?]
    | |- (_ ⊧ _ ∋ _ ∼ _) → _ => move=> [?]
    | |- (_ ∧ _) → _ => case
    | |- τ[?n] _ -> _ => move=> ?
    | |- τω _ → _ => move=> [?]
    | |- _ → _ => move=> ?
    end.

  (* TODO: get rid of this, since it only really works in the easy cases. *)
  Ltac prove := repeat prove_step.
End Tac.

Module Level.
  Theorem eq_ty_from_level n {A B} :
    τ[n] ⊧ A ∼ B
    → τω ⊧ A ∼ B.
  Proof.
    move=> [R [TA TB]].
    eexists.
    split.
    + eexists; eauto.
    + eexists; eauto.
  Qed.

  Theorem eq_ty_to_level {A B} :
    τω ⊧ A ∼ B
    → ∃ n, τ[n] ⊧ A ∼ B.
  Proof.
    move=> [R [[n𝒟 𝒟] [nℰ ℰ]]].
    exists (n𝒟 + nℰ), R.
    T.split;
    (apply: Tower.monotonicity; last by [eauto]); omega.
  Qed.

  Theorem eq_mem_from_level n {A M1 M2} :
    τ[n] ⊧ A ∋ M1 ∼ M2
    → τω ⊧ A ∋ M1 ∼ M2.
  Proof.
    move=> [R [TA M1M2]].
    eexists.
    split.
    + eexists; eauto.
    + eauto.
  Qed.

  Theorem eq_mem_to_level {A M1 M2} :
    τω ⊧ A ∋ M1 ∼ M2
    → ∃ n, τ[n] ⊧ A ∋ M1 ∼ M2.
  Proof.
    move=> [R [[n𝒟 𝒟] M1M2]].
    exists n𝒟, R.
    T.split.
    - Tac.tower_mono.
    - auto.
  Qed.

  Lemma eq_env_from_level {Ψ} {Γ : Prectx Ψ} i {γ0 γ1} :
    τ[i] ⊧ Γ ∋⋆ γ0 ∼ γ1
    → τω ⊧ Γ ∋⋆ γ0 ∼ γ1.
  Proof.
    move=> 𝒟.
    induction Γ; simpl; repeat split.
    - apply: IHΓ.
      by case: 𝒟.
    - apply: eq_mem_from_level.
      case: 𝒟 => _ //= ?.
      eauto.
  Qed.

  Lemma mem_eq_at_lvl_of_typehood {m n A B M0 M1} :
    τ[n] ⊧ A ∋ M0 ∼ M1
    → τ[m] ⊧ A ∼ B
    → τ[m] ⊧ A ∋ M0 ∼ M1.
  Proof.
    move=> [R [𝒟0 𝒟1]] [S [ℰ0 ℰ1]].
    exists S; split; first by assumption.
    replace S with R; first by assumption.
    apply: TS.is_extensional;
    eexists; eassumption.
  Qed.
End Level.

Module General.
  Theorem replace_ty_in_mem_eq {τ A0 A1 M1 M2} `{TS.extensional τ} :
    τ ⊧ A0 ∋ M1 ∼ M2
    → τ ⊧ A0 ∼ A1
    → τ ⊧ A1 ∋ M1 ∼ M2.
  Proof.
    move=> [R1 [? ?]] [R2 [? ?]].
    exists R2; split; auto.
    replace R2 with R1; auto.
    apply: TS.is_extensional; eauto.
  Qed.

  Theorem ty_eq_refl_left {τ A B} :
    τ ⊧ A ∼ B
    → τ ⊧ A ∼ A.
  Proof.
    move=> [? [? ?]].
    eexists; eauto.
  Qed.

  Theorem ty_eq_symm {τ A B} :
    τ ⊧ A ∼ B
    → τ ⊧ B ∼ A.
  Proof.
    move=> [? [? ?]].
    eexists; eauto.
  Qed.

  Theorem ty_eq_conv {τ A0 A1 B} `{TS.type_computational τ} :
    A0 ≼₀ A1
    → τ ⊧ A0 ∼ B
    → τ ⊧ A1 ∼ B.
  Proof.
    move=> A01 [R [𝒟A0 𝒟B]].
    exists R; split; auto.
    apply: TS.is_type_computational.
    - exact 𝒟A0.
    - auto.
  Qed.

  Theorem mem_eq_conv_ty {τ A0 A1 M0 M1} `{TS.type_computational τ} :
    A0 ≼₀ A1
    → τ ⊧ A0 ∋ M0 ∼ M1
    → τ ⊧ A1 ∋ M0 ∼ M1.
  Proof.
    move=> A01 [R [𝒟 M01]].
    exists R; split; auto.
    apply: TS.is_type_computational; eauto.
  Qed.

  Theorem mem_eq_symm {τ A M0 M1} `{TS.cper_valued τ} :
    τ ⊧ A ∋ M0 ∼ M1
    → τ ⊧ A ∋ M1 ∼ M0.
  Proof.
    move=> [R [𝒟 ℰ]].
    exists R; split; auto.
    apply: symmetric; auto.
    apply: per.
    apply: TS.is_cper_valued.
    eauto.
  Qed.

  Theorem mem_eq_conv {τ A M00 M01 M1} `{TS.cper_valued τ} :
    M00 ≼₀ M01
    → τ ⊧ A ∋ M00 ∼ M1
    → τ ⊧ A ∋ M01 ∼ M1.
  Proof.
    move=> M00M01 [R [ℰ M00M1]].
    exists R; split; auto.
    apply: crel; eauto.
    apply: TS.is_cper_valued; eauto.
  Qed.

  Theorem mem_eq_conv_both {τ A M00 M01 M10 M11} `{TS.cper_valued τ} :
    M00 ≼₀ M01
    → M10 ≼₀ M11
    → τ ⊧ A ∋ M00 ∼ M10
    → τ ⊧ A ∋ M01 ∼ M11.
  Proof.
    move=> ? ? ?.
    apply: mem_eq_conv; eauto.
    apply: mem_eq_symm; eauto.
    apply: mem_eq_conv; eauto.
    by apply: mem_eq_symm.
  Qed.

  Theorem ty_eq_trans {τ A B C} `{TS.cper_valued τ} `{TS.extensional τ}:
    τ ⊧ B ∼ C
    → τ ⊧ A ∼ B
    → τ ⊧ A ∼ C.
  Proof.
    move=> [R1 [? ?]] [R2 [? ?]].
    exists R2; T.split.
    - eauto.
    - replace R2 with R1; auto.
      symmetry; apply: TS.is_extensional; eauto.
  Qed.

  Theorem mem_eq_trans {τ A M0 M1 M2} `{TS.cper_valued τ} `{TS.extensional τ} :
    τ ⊧ A ∋ M1 ∼ M2
    → τ ⊧ A ∋ M0 ∼ M1
    → τ ⊧ A ∋ M0 ∼ M2.
  Proof.
    move=> [R1 [𝒟0 𝒟1]] [R2 [ℰ1 ℰ2]].
    exists R2; T.split; auto.
    apply: transitive; eauto.
    - apply: per.
      apply: TS.is_cper_valued; eauto.
    - replace R2 with R1; eauto.
      apply: TS.is_extensional; eauto.
  Qed.

  Theorem mem_eq_refl_left {τ A M0 M1} `{TS.cper_valued τ} `{TS.extensional τ} :
    τ ⊧ A ∋ M0 ∼ M1
    → τ ⊧ A ∋ M0 ∼ M0.
  Proof.
    move=> 𝒟.
    apply: mem_eq_trans; eauto.
    apply: mem_eq_symm; eauto.
  Qed.

  Theorem env_eq_symm {Ψ} {Γ : Prectx Ψ} {τ γ0 γ1} `{TS.cper_valued τ} `{TS.extensional τ} :
    τ ⊧ Γ ctx
    → τ ⊧ Γ ∋⋆ γ0 ∼ γ1
    → τ ⊧ Γ ∋⋆ γ1 ∼ γ0.
  Proof.
    move=> Γctx γ01.
    induction Γ; eauto.
    split; simplify_eqs.
    - apply: IHΓ; eauto.
      + by case: Γctx.
      + by case: γ01.
    - suff: τ ⊧ t ⫽ (γ1 ∘ Fin.FS) ∼ (t ⫽ (γ0 ∘ Fin.FS)).
      + move=> [R [𝒟0 𝒟1]].
        case: γ01 => //= [_ [S [ℰ γ01]]].
        eexists; T.split; eauto.
        apply: symmetric.
        * apply: per.
          apply: TS.is_cper_valued.
          eassumption.
        * replace R with S; auto.
          apply: TS.is_extensional; eauto.
      + case: Γctx => _ 𝒟.
        apply: ty_eq_symm.
        apply: 𝒟.
        by case: γ01.
  Qed.

  Theorem env_eq_trans {Ψ} {Γ : Prectx Ψ} {τ γ0 γ1 γ2} `{TS.cper_valued τ} `{TS.extensional τ} :
    τ ⊧ Γ ctx
    → τ ⊧ Γ ∋⋆ γ0 ∼ γ1
    → τ ⊧ Γ ∋⋆ γ1 ∼ γ2
    → τ ⊧ Γ ∋⋆ γ0 ∼ γ2.
  Proof.
    move=> Γctx γ01 γ12.
    induction Γ; eauto.
    split; simplify_eqs.
    - apply: IHΓ; eauto.
      + by case: Γctx.
      + case: γ01 => X _.
        exact X.
      + case: γ12 => X _.
        exact X.
    - suff: τ ⊧ t ⫽ (γ0 ∘ Fin.FS) ∼ (t ⫽ (γ1 ∘ Fin.FS)) ∧ τ ⊧ t ⫽ (γ1 ∘ Fin.FS) ∼ (t ⫽ (γ2 ∘ Fin.FS)).
      + move=> [[R [𝒟0 𝒟1]] [R' [𝒟'0 𝒟'1]]].
        case: γ01 => //= [_ [S [ℰ γ01]]].
        case: γ12 => //= [_ [S' [ℱ γ01']]].
        eexists; T.split; eauto.
        apply: transitive; eauto.
        * apply: per.
          apply: TS.is_cper_valued.
          eassumption.
        * suff: S = R ∧ R = S'.
          ** move=> [Q1 Q2].
             by rewrite Q1 Q2.
          ** split; apply: TS.is_extensional; eauto.
      + split.
        * case: Γctx => _ 𝒟.
          apply: 𝒟.
          by case: γ01.
        * case: Γctx => _ 𝒟.
          apply: 𝒟.
          by case: γ12.
  Qed.

  Theorem env_eq_refl_left {Ψ} {Γ : Prectx Ψ} {τ γ0 γ1} `{TS.cper_valued τ} `{TS.extensional τ} :
    τ ⊧ Γ ctx
    → τ ⊧ Γ ∋⋆ γ0 ∼ γ1
    → τ ⊧ Γ ∋⋆ γ0 ∼ γ0.
  Proof.
    move=> *.
    apply: env_eq_trans; eauto.
    apply: env_eq_symm; eauto.
  Qed.

  Theorem open_ty_eq_refl_left {Ψ} {Γ : Prectx Ψ} {τ A A'} `{TS.cper_valued τ} `{TS.extensional τ} :
    τ ⊧ Γ ctx
    → τ ⊧ Γ ≫ A ∼ A'
    → τ ⊧ Γ ≫ A ∼ A.
  Proof.
    move=> 𝒟 ℰ γ0 γ1 γ01.
    apply: ty_eq_trans.
    - apply: ty_eq_symm.
      apply: ℰ.
      apply: env_eq_symm; eauto.
    - apply: ℰ.
      apply: env_eq_refl_left; eauto.
  Qed.

  Theorem open_mem_eq_refl_left {Ψ} {Γ : Prectx Ψ} {τ A A' M0 M1} `{TS.cper_valued τ} `{TS.extensional τ} :
    τ ⊧ Γ ctx
    → τ ⊧ Γ ≫ A ∼ A'
    → τ ⊧ Γ ≫ A ∋ M0 ∼ M1
    → τ ⊧ Γ ≫ A ∋ M0 ∼ M0.
  Proof.
    move=> 𝒟 ℰ ℱ γ0 γ1 γ01.
    apply: mem_eq_trans; auto.
    - apply: mem_eq_symm; auto.
      apply: replace_ty_in_mem_eq.
      + apply: ℱ.
        apply: env_eq_refl_left; eauto.
        apply: env_eq_symm; eauto.
      + apply: ty_eq_trans.
        * apply: ty_eq_symm.
          apply: ℰ; eauto.
        * apply: ℰ.
          apply: env_eq_refl_left; eauto.
          apply: env_eq_symm; eauto.
    - eauto.
  Qed.
End General.

Module Univ.
  Lemma formation_S {n : nat} :
    τ[S n] ⊧ 𝕌[n] ∼ 𝕌[n].
  Proof.
    eexists; split; Tac.tower_intro; apply: Sig.init; Spine.simplify;
    eexists; split; eauto; split; eauto; split.
  Qed.

  Theorem formation_lvl {n i : nat} :
    i < n
    → τ[n] ⊧ 𝕌[i] ∼ 𝕌[i].
  Proof.
    case => [| j q ].
    + apply: formation_S.
    + eexists; split; Tac.tower_intro; apply: Sig.init; Spine.simplify;
      exists i; simpl; (eexists; first by omega); (split; first by auto); reflexivity.
  Qed.

  Theorem formation_ω {i} :
    τω ⊧ 𝕌[i] ∼ 𝕌[i].
  Proof.
    apply: Level.eq_ty_from_level.
    apply: formation_lvl.
    eauto.
  Qed.

  Lemma intro {i A0 A1} :
    τ[i] ⊧ A0 ∼ A1
    → τω ⊧ 𝕌[i] ∋ A0 ∼ A1.
  Proof.
    move=> 𝒟.
    apply: (Level.eq_mem_from_level (S i)).
    esplit; split.
    - rewrite /Tower.t -Clo.roll.
      apply: Sig.init.
      Spine.simplify.
      exists i; repeat split; eauto.
    - eauto.
  Qed.

  Lemma inversion {i A0 A1} :
    τω ⊧ 𝕌[i] ∋ A0 ∼ A1
    → τ[i] ⊧ A0 ∼ A1.
  Proof.
    move=> [R [[n 𝒟] ℰ]].
    Tower.destruct_tower.
    destruct n; Spine.simplify.
    - contradiction.
    - case: H => //= [j [p [ev spec]]].
      OpSem.destruct_evals.
      rewrite spec in ℰ.
      case: ℰ => //= [S [ℰ1 ℰ2]].
      by exists S.
  Qed.

  Lemma inversionω {i A0 A1} :
    τω ⊧ 𝕌[i] ∋ A0 ∼ A1
    → τω ⊧ A0 ∼ A1.
  Proof.
    move=> 𝒟.
    apply: Level.eq_ty_from_level.
    apply: inversion.
    eassumption.
  Qed.

  Lemma open_inversionω {Ψ} {Γ : Prectx Ψ} {i A0 A1} :
    τω ⊧ Γ ≫ 𝕌[i] ∋ A0 ∼ A1
    → τω ⊧ Γ ≫ A0 ∼ A1.
  Proof.
    move=> 𝒟 γ0 γ1 γ01.
    specialize (𝒟 γ0 γ1).
    suff: τω ⊧ Γ ∋⋆ γ0 ∼ γ1.
    - move=> /𝒟 ℱ.
      apply: Level.eq_ty_from_level.
      apply: inversion.
      eassumption.
    - by induction Γ.
  Qed.

  Lemma open_inversion {Ψ} {Γ : Prectx Ψ} {i A0 A1} :
    τω ⊧ Γ ≫ 𝕌[i] ∋ A0 ∼ A1
    → τ[i] ⊧ Γ ≫ A0 ∼ A1.
  Proof.
    move=> 𝒟 γ0 γ1 γ01.
    specialize (𝒟 γ0 γ1).
    apply: inversion.
    apply: 𝒟.
    apply: Level.eq_env_from_level.
    eauto.
  Qed.

  Theorem spine_inversion {n i R} :
    τ[n] (Prog.univ i, R)
    → Spine.t n (Prog.univ i, R).
  Proof.
    move=> ?.
    by Tower.destruct_tower.
  Qed.

  Ltac tac :=
    simpl;
    match goal with
    | |- τω ⊧ _ ≫ _ ∼ _ => move=> ? ? ?; tac
    | |- τω ⊧ 𝕌[_] ∼ 𝕌[_] => apply: formation_ω
    | |- τω ⊧ _ ∼ _ => apply: Level.eq_ty_from_level; tac
    | |- τ[_] ⊧ _ ∼ _ => apply: inversion
    end.
End Univ.

Module Unit.
  Theorem formation i :
    τ[i] ⊧ 𝟙 ∼ 𝟙.
  Proof.
    eexists; split; Tac.tower_intro; apply: Sig.conn; eauto.
  Qed.

  Theorem ax_equality :
    τω ⊧ 𝟙 ∋ ★ ∼ ★.
  Proof.
    eexists; split.
    - exists 0; Tac.tower_intro; apply: Sig.conn; eauto.
    - econstructor; eauto.
  Qed.
End Unit.

Module Bool.
  Theorem tt_equality :
    τω ⊧ 𝟚 ∋ Prog.tt ∼ Prog.tt.
  Proof.
    eexists; split.
    - exists 0; Tac.tower_intro; apply: Sig.conn; eauto.
    - econstructor; eauto.
  Qed.

  Theorem ff_equality :
    τω ⊧ 𝟚 ∋ Prog.ff ∼ Prog.ff.
  Proof.
    eexists; split.
    - exists 0; Tac.tower_intro; apply: Sig.conn; eauto.
    - econstructor; eauto.
  Qed.

  Theorem formation i :
    τ[i] ⊧ 𝟚 ∼ 𝟚.
  Proof.
    eexists; split; Tac.tower_intro; apply: Sig.conn; eauto.
  Qed.

  Ltac tac :=
    simpl;
    match goal with
    | |- τ[_] ⊧ 𝟚 ∼ 𝟚 => apply: formation
    | |- τω ⊧ 𝟚 ∋ _ ∼ _ => apply: tt_equality + apply: ff_equality
    | |- τω ⊧ 𝕌[_] ∋ _ ∼ _ => apply: Univ.intro; tac
    end.
End Bool.

Module Fam.

  Local Hint Extern 40 => Program.simplify_subst.
  Local Hint Resolve General.mem_eq_refl_left General.mem_eq_symm.

  (* This is a very bad proof, sorry. *)
  Theorem family_choice {τ A0 A1 B0 B1} `{TS.cper_valued τ} `{TS.extensional τ} :
    τ ⊧ A0 ∼ A1
    → τ ⊧ ⋄ ∙ A0 ≫ B0 ∼ B1
    → ∃ (R : Prog.t 0 → rel),
      ∀ M0 M1,
        τ ⊧ A0 ∋ M0 ∼ M1
        → R M0 = R M1
          ∧ τ ((B0 ⫽ Sub.inst0 M0)%prog, R M0)
          ∧ τ ((B1 ⫽ Sub.inst0 M1)%prog, R M0)
          ∧ τ ((B0 ⫽ Sub.inst0 M1)%prog, R M0)
          ∧ τ ((B1 ⫽ Sub.inst0 M0)%prog, R M0).
  Proof.
    move=> 𝒟 ℰ.
    set R := (fun M =>
         fun Ms =>
           τ ⊧ A0 ∋ M ∼ M
           → τ ⊧ B0 ⫽ Sub.inst0 M ∋ (π₁ Ms) ∼ (π₂ Ms)).

    exists R.

    move=> M0 M1 ℱ.
    destruct (ℰ (Sub.inst0 M1) (Sub.inst0 M0)) as [Rℰ [ℰ0 ℰ1]]; eauto.
    destruct (ℰ (Sub.inst0 M0) (Sub.inst0 M0)) as [Rℰ' [ℰ0' ℰ1']]; eauto.

    suff: R M0 = R M1.
    - move=> Q; repeat split; auto.
      + T.use ℰ0'; repeat f_equal.
        T.eqcd; case => M'0 M'1 //=.
        apply: propositional_extensionality; split.
        * move=> M'0M'1 M0M0 //=.
          eexists; split; eauto.
        * move=> //= 𝒢.
          destruct 𝒢 as [R𝒢 [𝒢0 𝒢1]]; eauto.
          replace Rℰ' with R𝒢; eauto.
          apply: TS.is_extensional; eauto.

      + destruct (ℰ (Sub.inst0 M1) (Sub.inst0 M1)) as [Rℰ'' [ℰ0'' ℰ1'']]; eauto.
        T.use ℰ1''; repeat f_equal.
        rewrite Q.
        T.eqcd; case => M'0 M'1 //=.
        apply: propositional_extensionality; split.
        * move=> M'0M'1 M1M1 //=.
          eexists; split; eauto.
        * move=> //= 𝒢.
          destruct 𝒢 as [R𝒢 [𝒢0 𝒢1]]; eauto.
          replace Rℰ'' with R𝒢; eauto.
          apply: TS.is_extensional; eauto.
      +  destruct (ℰ (Sub.inst0 M1) (Sub.inst0 M1)) as [Rℰ'' [ℰ0'' ℰ1'']]; eauto.
         T.use ℰ0''; repeat f_equal.
         rewrite Q.
         T.eqcd; case => M'0 M'1 //=.
         apply: propositional_extensionality; split.
         * move=> M'0M'1 M1M1 //=.
           exists Rℰ''; split; auto.
         * move=> //= 𝒢.
           destruct 𝒢 as [R𝒢 [𝒢0 𝒢1]]; eauto.
           replace Rℰ'' with R𝒢; eauto.
           apply: TS.is_extensional; eauto.

      + T.use ℰ1'; repeat f_equal.
        T.eqcd; case => M'0 M'1 //=.
        apply: propositional_extensionality; split.

        * move=> M'0M'1 M1M1 //=.
          eexists; split; eauto.
        * move=> //= 𝒢.
          destruct 𝒢 as [R𝒢 [𝒢0 𝒢1]]; eauto.
          replace Rℰ' with R𝒢; eauto.
          apply: TS.is_extensional; eauto.

    - T.eqcd; case => M'0 M'1 //=.
      apply: propositional_extensionality; split => 𝒢 ℋ.
      + case: 𝒢 => [|S [𝒢1 𝒢2]]; eauto.
        eexists; split; eauto.
        replace Rℰ with S; eauto.
        apply: TS.is_extensional; eauto; simpl.
        replace Rℰ with Rℰ'; eauto.
        apply: TS.is_extensional; eauto.
      + case: 𝒢 => [|S [𝒢1 𝒢2]]; eauto.
        eexists; split; eauto.
        replace Rℰ' with S; eauto.
        apply: TS.is_extensional; eauto; simpl.
        replace Rℰ' with Rℰ; eauto.
        apply: TS.is_extensional; eauto.
  Qed.

End Fam.

Module Arr.
  Theorem formation {n A0 A1 B0 B1} :
    τ[n] ⊧ A0 ∼ A1
    → τ[n] ⊧ (⋄ ∙ A0) ≫ B0 ∼ B1
    → τ[n] ⊧ (A0 ⇒ B0) ∼ (A1 ⇒ B1).
  Proof.
    move=> 𝒟 /(Fam.family_choice 𝒟) [ℰ Rℰsp].
    case: 𝒟 => R𝒟 [𝒟0 𝒟1].

    eexists; split; Tac.tower_intro;
    (apply: Sig.conn; first by eauto);
    (econstructor; first by eauto).
    - move=> M0 M1 M0M1;
      (case: (Rℰsp M0 M1); first by [exists R𝒟]).
      move=> Q [? [? [? ?]]];
      repeat split; eauto;
      rewrite -Q; eauto.
    - move=> M0 M1 M0M1;
      (case: (Rℰsp M0 M1); first by [exists R𝒟]).
      move=> Q [? [? [? ?]]];
      repeat split; eauto; by rewrite -Q.
  Qed.

  Theorem univ_eq {i A0 A1 B0 B1} :
    τω ⊧ 𝕌[i] ∋ A0 ∼ A1
    → τω ⊧ ⋄ ∙ A0 ≫ 𝕌[i] ∋ B0 ∼ B1
    → τω ⊧ 𝕌[i] ∋ (A0 ⇒ B0) ∼ (A1 ⇒ B1).
  Proof.
    move=> /Univ.inversion 𝒟 /Univ.open_inversion ℰ.
    apply: Univ.intro.
    apply: formation; auto.
  Qed.

  Theorem intro {i A B f0 f1} :
    τω ⊧ ⋄ ∙ A ≫ B ∋ f0 ∼ f1
    → τ[i] ⊧ A ∼ A
    → τ[i] ⊧ ⋄ ∙ A ≫ B ∼ B
    → τω ⊧ (A ⇒ B) ∋ 𝛌{f0} ∼ 𝛌{f1}.
  Proof.
    move=> 𝒟 ℰ /(Fam.family_choice ℰ) ℱ.
    apply: (Level.eq_mem_from_level i).
    case: ℰ => Rℰ [ℰ0 _].
    case: ℱ => Rℱ ℱsp.
    eexists; split.
    - Tac.tower_intro.
      apply: Sig.conn; first by auto.
      econstructor; eauto.
      move=> M0 M1 M0M1.
      case: (ℱsp M0 M1); auto.
      + eexists; eauto.
      + move=> Q [? [? [? ?]]].
        repeat T.split; eauto;
        by rewrite -Q.
    - econstructor=> M0 M1 M0M1.
      suff ? : is_cper (Rℱ M0).
      + apply: crel.
        * destruct (ℱsp M0 M1); auto.
          by exists Rℰ.
        * by apply: OpSem.app_lam.
        * apply: symmetric.
          ** by apply: per.
          ** apply: crel; first by auto.
             *** by apply: OpSem.app_lam.
             *** edestruct (𝒟 (Sub.inst0 M0) (Sub.inst0 M1)) as [R𝒟 [𝒟0 𝒟1]]; eauto.
                 **** simpl; split; auto.
                      simplify_subst.
                      exists Rℰ; split; eauto.
                      eexists; eauto.
                 **** replace (Rℱ M0) with R𝒟.
                      ***** apply: symmetric; auto.
                            apply: per; apply: TS.is_cper_valued; eauto.
                      ***** edestruct ℱsp; first by [exists Rℰ; eauto].
                            T.destruct_conjs.
                            apply: TS.is_extensional; eauto.
                            eexists; eauto.
      + edestruct ℱsp; eauto.
        * eexists Rℰ; eauto.
        * T.destruct_conjs.
          apply: TS.is_cper_valued; eauto.
          eexists; eauto.
  Qed.

  Theorem elim {i A B f0 f1 M0 M1} :
    τ[i] ⊧ A ∼ A
    → τ[i] ⊧ ⋄ ∙ A ≫ B ∼ B
    → τω ⊧ (A ⇒ B) ∋ f0 ∼ f1
    → τω ⊧ A ∋ M0 ∼ M1
    → τω ⊧ (B ⫽ Sub.inst0 M0) ∋ (f0 ⋅ M0) ∼ (f1 ⋅ M1).
  Proof.
    move=> 𝒟 /(Fam.family_choice 𝒟) [Rℰ Rℰsp] /Level.eq_mem_to_level [nℱ ℱ] /Level.eq_mem_to_level [n𝒢 𝒢].
    case: ℱ => Rℱ [ℱ0 ℱ1].
    case: (Rℰsp M0 M1).
    - apply: Level.mem_eq_at_lvl_of_typehood; eauto.
    - Tower.destruct_tower.
      dependent destruction ℱ1.
      move=> Q [ℰ0 [ℰ1 [ℰ2 ℰ3]]].
      eexists; split.
      + eexists; eauto.
      + replace (Rℰ M0) with (R1 M0).
        * apply: H; eauto.
          case: 𝒢 => R𝒢 [𝒢0 𝒢1].
          replace R0 with R𝒢; auto.
          apply: TS.is_extensional; eexists; eauto.
        * edestruct H1; eauto.
          ** case: 𝒢 => R𝒢 [𝒢0 𝒢1].
             replace R0 with R𝒢; eauto.
             apply: TS.is_extensional; eexists; eauto.
          ** T.destruct_conjs.
             apply: TS.is_extensional; eexists; eauto.
  Qed.
End Arr.

Module Prod.
  Local Hint Extern 40 => simplify_subst.
  Local Hint Resolve General.mem_eq_refl_left General.mem_eq_symm.

  Theorem formation {n A0 A1 B0 B1} :
    τ[n] ⊧ A0 ∼ A1
    → τ[n] ⊧ (⋄ ∙ A0) ≫ B0 ∼ B1
    → τ[n] ⊧ (A0 × B0) ∼ (A1 × B1).
  Proof.
    move=> 𝒟 /(Fam.family_choice 𝒟) [ℰ Rℰsp].
    case: 𝒟 => R𝒟 [𝒟0 𝒟1].

    eexists; split; Tac.tower_intro;
    (apply: Sig.conn; first by eauto);
    (econstructor; first by eauto).
    - move=> M0 M1 M0M1;
      (case: (Rℰsp M0 M1); first by [exists R𝒟]).
      move=> Q [? [? [? ?]]];
      repeat split; eauto;
      rewrite -Q; eauto.
    - move=> M0 M1 M0M1;
      (case: (Rℰsp M0 M1); first by [exists R𝒟]).
      move=> Q [? [? [? ?]]];
      repeat split; eauto; by rewrite -Q.
  Qed.

  Theorem univ_eq {i A0 A1 B0 B1} :
    τω ⊧ 𝕌[i] ∋ A0 ∼ A1
    → τω ⊧ ⋄∙A0 ≫ 𝕌[i] ∋ B0 ∼ B1
    → τω ⊧ 𝕌[i] ∋ (A0 × B0) ∼ (A1 × B1).
  Proof.
    move=> /Univ.inversion 𝒟 /Univ.open_inversion ℰ.
    apply: Univ.intro.
    apply: formation; auto.
  Qed.

  Theorem intro i {A B M00 M01 M10 M11} :
    τω ⊧ A ∋ M00 ∼ M10
    → τω ⊧ B ⫽ Sub.inst0 M00 ∋ M01 ∼ M11
    → τ[i] ⊧ A ∼ A
    → τ[i] ⊧ ⋄∙A ≫ B ∼ B
    → τω ⊧ (A × B) ∋ ⟨M00, M01⟩ ∼ ⟨M10, M11⟩.
  Proof.
    move=>
     /Level.eq_mem_to_level [n1 𝒟]
     /Level.eq_mem_to_level [n2 ℰ]
     ℱ
     /(Fam.family_choice ℱ) => 𝒢.

    apply: (Level.eq_mem_from_level (i + n1 + n2)).
    case: 𝒟 => [R𝒟 [𝒟0 𝒟1]].
    case: 𝒢; eauto.
    - move=> R𝒢 𝒢.
      eexists; split.
      + Tac.tower_intro; apply: Sig.conn; auto.
        constructor; eauto.
        * Tac.tower_mono.
        * move=> M0 M1 p.
          specialize (𝒢 M0 M1).
          suff ℋ: τ[i] ⊧ A ∋ M0 ∼ M1.
          ** case: (𝒢 ℋ) => Q [? [? [? ?]]].
             repeat split; auto; (rewrite -Q; Tac.tower_mono) || Tac.tower_mono.
          ** apply: Level.mem_eq_at_lvl_of_typehood; eauto.
             exists R𝒟; split; eauto.
      + constructor.
        * apply: crel.
          ** apply: TS.is_cper_valued; eexists; eauto.
          ** apply: OpSem.fst_pair.
          ** apply: symmetric; first by [apply: per; apply: TS.is_cper_valued; eexists; eauto].
             apply: crel.
             *** apply: TS.is_cper_valued; eexists; eauto.
             *** apply: OpSem.fst_pair.
             *** apply: symmetric; auto.
                 apply: per; apply: TS.is_cper_valued; eexists; eauto.
        * case: ℰ => Rℰ [ℰ0 ℰ1].
          replace (R𝒢 (⟨M00, M01⟩.1)%prog) with Rℰ; auto.
          ** apply: crel.
             *** apply: TS.is_cper_valued; eexists; eauto.
             *** apply: OpSem.snd_pair.
             *** apply: symmetric; first by [apply: per; apply: TS.is_cper_valued; eexists; eauto].
                 apply: crel.
                 **** apply: TS.is_cper_valued; eexists; eauto.
                 **** apply: OpSem.snd_pair.
                 **** apply: symmetric; auto.
                      apply: per; apply: TS.is_cper_valued; eexists; eauto.
          ** edestruct (𝒢 M00(⟨M10, M11⟩.1)%prog).
             *** apply: General.mem_eq_conv_both.
                 **** auto.
                 **** apply: OpSem.fst_pair.
                 **** apply: Level.mem_eq_at_lvl_of_typehood; first (exists R𝒟); eauto.
             *** edestruct (𝒢 (⟨M00, M01⟩.1)%prog (⟨M10, M11⟩.1)%prog).
                 **** apply: General.mem_eq_conv_both.
                      ***** apply: OpSem.fst_pair.
                      ***** apply: OpSem.fst_pair.
                      ***** apply: Level.mem_eq_at_lvl_of_typehood; first (exists R𝒟); eauto.
                 **** destruct H0 as [H01 [H02 [H03 H04]]].
                      destruct H2 as [H21 [H22 [H23 H24]]].
                      apply: (TS.is_extensional τω); eauto.
                      ***** eexists; eauto.
                      ***** exists i; simpl.
                            rewrite H in H04.
                            by rewrite H1.
  Qed.
End Prod.

Module TowerChoice.
  Lemma ty_eq {n : nat} {A1 A2 : 𝕂 → Prog.t 0} :
    (∀ κ, ∃ Rκ, τ[n] (A1 κ, Rκ) ∧ τ[n] (A2 κ, Rκ))
    → ∃ S, ∀ κ, τ[n] (A1 κ, S κ) ∧ τ[n] (A2 κ, S κ).
  Proof.
    move=> X.
    apply (@unique_choice _ _ (fun κ R => τ[n] (A1 κ, R) ∧ τ[n] (A2 κ, R))) => κ.
    case: (X κ) => S T.
    eexists; split; eauto => S' T';
    apply: TS.is_extensional; eexists;
    T.destruct_conjs; eauto.
  Qed.

  Lemma mem_eq {n : nat} {A : 𝕂 → Prog.t 0} {M0 M1} :
    (∀ κ, ∃ Rκ, τ[n] (A κ, Rκ) ∧ Rκ (M0 κ, M1 κ))
    → ∃ S, ∀ κ, τ[n] (A κ, S κ) ∧ S κ (M0 κ, M1 κ).
  Proof.
    move=> X.
    apply (@unique_choice _ _ (fun κ R => τ[n] (A κ, R) ∧ R (M0 κ, M1 κ))) => κ.
    case: (X κ) => S T.
    eexists; split; eauto => S' T';
    apply: TS.is_extensional; eexists;
    T.destruct_conjs; eauto.
  Qed.
End TowerChoice.

Module KArr.
  Theorem formation {n B0 B1} :
    (∀ κ, τ[n] ⊧ (B0 κ) ∼ (B1 κ))
    → τ[n] ⊧ (Prog.karr B0) ∼ (Prog.karr B1).
  Proof.
    case /TowerChoice.ty_eq => S 𝒟.
    eexists; split; Tac.tower_intro;
    (apply: Sig.conn; first by [eauto]);
    constructor => κ; case: (𝒟 κ); eauto.
  Qed.

  Theorem intro_at_lvl {n A M0 M1} :
    (∀ κ, τ[n] ⊧ (A κ) ∋ (M0 κ) ∼ (M1 κ))
    → τ[n] ⊧ Prog.karr A ∋ (Prog.klam M0) ∼ (Prog.klam M1).
  Proof.
    case /TowerChoice.mem_eq => S 𝒟.
    eexists; split.
    - Tac.tower_intro; (apply: Sig.conn; first by [eauto]);
      constructor=> κ; case: (𝒟 κ); eauto.
    - constructor=> κ.
      suff H : is_cper (S κ).
      + eapply (crel _ H (M0 κ) (Prog.kapp (Prog.klam M0) κ)).
        * move=> ? ?; by apply: OpSem.kapp_eval.
        * apply: symmetric; first by (apply: per).
          eapply (crel _ H (M1 κ) (Prog.kapp (Prog.klam M1) κ)).
          ** move=> ? ?; by apply: OpSem.kapp_eval.
          ** apply: symmetric; first by (apply: per).
             T.specialize_hyps.
             by T.destruct_conjs.
      + apply: TS.is_cper_valued.
        T.specialize_hyps; T.destruct_conjs.
        eexists; eauto.
  Qed.

  Theorem intro {A M0 M1} :
    τω ⊧ (Prog.karr A) ∼ (Prog.karr A)
    → (∀ κ, τω ⊧ (A κ) ∋ (M0 κ) ∼ (M1 κ))
    → τω ⊧ Prog.karr A ∋ (Prog.klam M0) ∼ (Prog.klam M1).
  Proof.
    move=> /Level.eq_ty_to_level [n𝒟 𝒟] ℰ.
    apply: (Level.eq_mem_from_level n𝒟).
    apply: intro_at_lvl => κ.
    T.specialize_hyps.

    case: {ℰ} (Level.eq_mem_to_level ℰ) => nℰ ℰ.
    apply: Level.mem_eq_at_lvl_of_typehood; first by eassumption.

    case: 𝒟 => R [𝒟 _].
    Tower.destruct_tower.
    eexists; split; T.specialize_hyps; eauto.
  Qed.

  Theorem elim {i B f0 f1 κ} :
    (∀ κ, τ[i] ⊧ (B κ) ∼ (B κ))
    → τω ⊧ Prog.karr B ∋ f0 ∼ f1
    → τω ⊧ (B κ) ∋ (Prog.kapp f0 κ) ∼ (Prog.kapp f1 κ).
  Proof.
    case /TowerChoice.ty_eq => S 𝒟.
    move=> /(Level.eq_mem_to_level) [nℰ ℰ].
    case: ℰ => Rℰ [ℰ0 ℰ1].
    T.specialize_hyps.
    Tower.destruct_tower.
    dependent destruction ℰ1.
    T.specialize_hyps.
    eexists; split; eauto.
    eexists; eauto.
  Qed.
End KArr.

Module Isect.
  Theorem formation {n B0 B1} :
    (∀ κ, τ[n] ⊧ (B0 κ) ∼ (B1 κ))
    → τ[n] ⊧ ⋂ B0 ∼ ⋂ B1.
  Proof.
    case /TowerChoice.ty_eq => S 𝒟.
    eexists; split; Tac.tower_intro;
    (apply: Sig.conn; first by [eauto]);
    constructor => κ; case: (𝒟 κ); eauto.
  Qed.

  Theorem intro_at_lvl {n A M0 M1} :
    (∀ κ, τ[n] ⊧ (A κ) ∋ M0 ∼ M1)
    → τ[n] ⊧ ⋂ A ∋ M0 ∼ M1.
  Proof.
    case /TowerChoice.mem_eq => S 𝒟.
    eexists; split.
    - Tac.tower_intro; (apply: Sig.conn; first by [eauto]);
      constructor=> κ; case: (𝒟 κ); eauto.
    - move=> κ; case: (𝒟 κ); eauto.
  Qed.

  (* NOTE that the type equality premise is necessary for this rule to be true! *)
  Theorem intro {A M0 M1} :
    τω ⊧ (⋂ A) ∼ (⋂ A)
    → (∀ κ, τω ⊧ (A κ) ∋ M0 ∼ M1)
    → τω ⊧ ⋂ A ∋ M0 ∼ M1.
  Proof.
    move=> /Level.eq_ty_to_level [n𝒟 𝒟] ℰ.
    apply: (Level.eq_mem_from_level n𝒟).
    apply: intro_at_lvl => κ.
    T.specialize_hyps.

    case: {ℰ} (Level.eq_mem_to_level ℰ) => nℰ ℰ.
    apply: Level.mem_eq_at_lvl_of_typehood; first by eassumption.

    case: 𝒟 => R [𝒟 _].
    Tower.destruct_tower.
    eexists; split; T.specialize_hyps; eauto.
  Qed.

  Hint Extern 5 => Tac.prove_pick_eq.

  Theorem preserves_sigma {i A0 B0 A1 B1} :
    (∀ κ, τ[i] ⊧ (A0 κ) ∼ (A1 κ))
    → (∀ κ, τ[i] ⊧ ⋄ ∙ A0 κ ≫ (B0 κ) ∼ (B1 κ))
    → τ[i] ⊧ (⋂[κ] (A0 κ × (B0 κ))) ∼ ((⋂ A1) × (⋂ B1)).
  Proof.
    move=> 𝒟 ℰ.

    exists (fun Ms => ∀ κ, Connective.prod_el (τ[i] @ (A0 κ)) (fun x => τ[i] @ ((B0 κ) ⫽ Sub.inst0 x)%prog) Ms).
    split.

    - Tac.tower_intro; apply: Sig.conn; eauto.
      rewrite !Clo.roll; constructor=> κ.
      Tac.tower_intro; apply: Sig.conn; eauto.
      rewrite !Clo.roll; constructor.
      + case: (𝒟 κ) => ? [𝒟0 𝒟1].
        T.use 𝒟0; rewrite /Tower.t; repeat f_equal; eauto.
      + move=> M0 M1 M0M1.
        case: (Fam.family_choice (𝒟 κ) (ℰ κ)) => RB /(_ M0 M1) ℱ.
        case: ℱ.
        * eexists; split; eauto.
          case: (𝒟 κ) => ? [𝒟0 ?].
          T.use 𝒟0; repeat f_equal; eauto.
        * move=> ℱ0 [ℱ1 [ℱ2 [ℱ3 ℱ4]]].
          repeat split; [T.use ℱ1 | T.use ℱ1 | T.use ℱ3 | T.use ℱ3];
          rewrite /Tower.t; repeat f_equal; eauto.

    - Tac.ts_choose_rel (Connective.prod_el (fun Ms => ∀ κ, τ[i] @ (A0 κ) Ms) (fun x Ms => ∀ κ, τ[i] @ (B0 κ ⫽ Sub.inst0 x)%prog Ms)).
      + Tac.tower_intro; apply: Sig.conn; eauto.
        rewrite Clo.roll; constructor.
        * Tac.tower_intro; apply: Sig.conn; eauto.
          rewrite Clo.roll; constructor=> κ.
          case: (𝒟 κ) => ? [? 𝒟1].
          T.use 𝒟1; rewrite /Tower.t; repeat f_equal.
          apply: functional_extensionality => ?;
          apply: equal_f; eauto.
        * move=> M0 M1 M0M1; repeat split;
          Tac.tower_intro; (apply: Sig.conn; first by [simpl; eauto]);
          rewrite Clo.roll; constructor=> κ;
          case: (Fam.family_choice (𝒟 κ) (ℰ κ)) => RB ℱ;
          (case: (ℱ M0 M1);
           first
             by
               [case: (𝒟 κ) => RD [𝒟0 𝒟1]; exists RD; split;
                [eauto | T.use (M0M1 κ); apply: equal_f; eauto]]);
          move=> ℱ0 [ℱ1 [ℱ2 [ℱ3 ℱ4]]];
          [T.use ℱ4 | T.use ℱ4 | T.use ℱ2 | T.use ℱ2];
          rewrite /Tower.t; repeat f_equal; eauto;
          apply: functional_extensionality => ?; apply: equal_f; eauto.
      + apply: binrel_extensionality => M0 M1; split.
        * move=> H; split=> κ; specialize (H κ); dependent destruction H; auto.
        * move=> H; dependent destruction H; auto.
  Qed.

  Theorem cartesian {n A0 B0 A1 B1} :
    (∀ κ, τ[n] ⊧ (A0 κ) ∼ (A1 κ))
    → (∀ κ, τ[n] ⊧ (B0 κ) ∼ (B1 κ))
    → τ[n] ⊧ (⋂[κ] (A0 κ × (B0 κ).[^1])) ∼ ((⋂ A1) × (⋂ B1).[^1]).
  Proof.
    move=> 𝒟 ℰ.
    apply: preserves_sigma; simplify_subst; eauto.
    move=> ? ? ?.
    simplify_subst.
    eauto.
  Qed.

  Theorem irrelevance {i A B}:
    τ[i] ⊧ A ∼ B
    → τ[i] ⊧ A ∼ ⋂[_] B.
  Proof.
    Tac.prove.

    match goal with
    | |- Connective.has _ _ (_, ?R) =>
      replace R with (fun M0M1 => ∀ κ:𝕂, R M0M1)
    end.

    + Tac.prove.
    + T.eqcd => ?.
      apply: propositional_extensionality.
      case: LocalClock => ? _.
      T.split; eauto.
  Qed.
End Isect.

Module Later.

  Local Hint Extern 5 => Tac.prove_pick_eq.

  Theorem formation {κ n} {A B} :
    ▷[κ] (τ[n] ⊧ A ∼ B)
    → τ[n] ⊧ ▶[κ] A ∼ ▶[κ] B.
  Proof.
    move => 𝒟.
    unfold atomic_eq_ty in 𝒟.
    exists (fun Ms => ▷[κ] (τ[n] @ A Ms)); split.
    - Tac.tower_intro; apply: Sig.conn; eauto.
      apply: Connective.has_later.
      Later.gather; case=> R' [AR' BR'].
      T.use AR'.
      rewrite /Tower.t Clo.roll; repeat f_equal; eauto.

    - Tac.tower_intro; apply: Sig.conn; eauto.
      apply: Connective.has_later.
      Later.gather; case=> R' [AR' BR'].
      T.use BR'.
      rewrite /Tower.t Clo.roll; repeat f_equal; eauto.
  Qed.

  Lemma level_commute_eq_ty {A B} :
    τω ⊧ A ∼ B
    → ∃ n, τ[n] ⊧ A ∼ B.
  Proof.
    case => R [[n1 AR] [n2 BR]].
    exists (n1 + n2).
    exists R; split;
    Tac.tower_mono.
  Qed.

  Lemma level_commute_eq_mem {A M0 M1} :
    τω ⊧ A ∋ M0 ∼ M1
    → ∃ n, τ[n] ⊧ A ∋ M0 ∼ M1.
  Proof.
    case => R [[n AR] M0M1].
    exists n; exists R; auto.
  Qed.

  Theorem intro {κ} {A M1 M2} :
    ▷[κ] (τω ⊧ A ∋ M1 ∼ M2)
    → τω ⊧ ▶[κ] A ∋ M1 ∼ M2.
  Proof.
    move=> /(Later.map level_commute_eq_mem).
    move=> /Later.yank_existential; case; auto => n 𝒟.
    exists (fun Ms => ▷[κ] (τ[n] @ A Ms)).
    split.
    - exists n; Tac.tower_intro.
      apply: Sig.conn; eauto.
      apply: Connective.has_later.
      Later.gather; case => R' [AR' M0M1].
      T.use AR'; rewrite /Tower.t Clo.roll; repeat f_equal; eauto.
    - Later.gather; case=> R' [AR' M0M1].
      T.use M0M1; repeat f_equal.
      apply: equal_f; eauto.
  Qed.

  Theorem mem_univ_inversion {κ i} {A0 A1} :
    (τω ⊧ 𝕌[i] ∋ ▶[κ] A0 ∼ ▶[κ] A1)
    → ▷[κ] (τω ⊧ 𝕌[i] ∋ A0 ∼ A1).
  Proof.
    move=> /Level.eq_mem_to_level [n [R [𝒟 A0A1]]].
    Tower.destruct_tower.
    induction n; Spine.simplify; try by [contradiction].
    case: H => //= [j [? [? [Rspec]]]].
    apply: Later.push_existential.
    exists R.
    OpSem.destruct_evals.
    rewrite Later.cart.
    split.
    - apply: Later.next.
      exists (S n).
      rewrite /Tower.t -Clo.roll.
      apply: Sig.init.
      Spine.simplify.
      eauto.
    - rewrite Rspec in A0A1.
      case: A0A1 => //= [S [H1 H2]].
      replace (Clo.t (Spine.t j)) with (Tower.t j) in H1, H2; last by [auto].
      Tower.destruct_tower.
      Tower.destruct_tower.
      suff: ▷[κ] (R = R0).
      + move=> E; Later.gather.
        move=> //= [H5 [H6 E]].
        exists R; split; first by [auto].
        by rewrite -E in H5.
      + apply: (Later.map (functional_extensionality R R0)).
        apply: Later.push_universal.
        move=> M0M1.
        apply: Later.commute_eq.
        by apply: (equal_f x).
  Qed.

  Theorem univ_eq {κ i} {A0 A1} :
    τω ⊧ ▶[κ] 𝕌[i] ∋ A0 ∼ A1
    → τω ⊧ 𝕌[i] ∋ ▶[κ] A0 ∼ ▶[κ] A1.
  Proof.
    move=> /Level.eq_mem_to_level [n [R [𝒟 ℰ]]].
    Tower.destruct_tower.
    esplit; T.split.
    - exists (i + 1).
      Tac.prove.
      replace (i + 1) with (S i); last by [omega].
      Spine.simplify.
      esplit; repeat T.split; eauto.
      reflexivity.
    - have H1 := Later.map Univ.spine_inversion H0.
      induction n.
      + exists (fun _ => ▷[κ0] ⊤).
        (* any relation will do! *)
        replace (Clo.t (Spine.t i)) with τ[i]; last by [auto].
        split; simpl; Tac.prove;
        Later.gather => *; T.destruct_conjs;
        Spine.simplify; by [contradiction].
      + move {IHn}; suff: ▷[κ0] (τ[i] ⊧ A0 ∼ A1).
        * move=> 𝒟.
          exists (fun Ms => ▷[κ0] (τ[i] @ A0 Ms)); split; simpl.
          ** Tac.tower_intro; apply: Sig.conn; eauto.
             apply: Connective.has_later.
             rewrite Clo.roll.
             Later.gather; case=> A0A1 [UiR0 [UiR0' [S [A0S A1S]]]].
             T.use A0S; rewrite /Tower.t; repeat f_equal; eauto.
          ** rewrite -Clo.roll; apply: Sig.conn; eauto.
             apply: Connective.has_later.
             Later.gather; case => A0A1 [UiR0 [UiR0' [S [A0S A1S]]]].
             T.use A1S; rewrite /Tower.t; repeat f_equal; eauto.
        * Later.gather; case => H1 [H2 H3].
          Spine.simplify; simpl in *.
          case: H3 => [j [? [? R0spec]]].
          OpSem.destruct_evals.
          simpl in *; by [rewrite R0spec in H1].
  Qed.

  Lemma force_reflexive {i A} :
    (τ[i] ⊧ ⋂ A ∼ ⋂ A)
    → τ[i] ⊧ ⋂[κ] ▶[κ] (A κ) ∼ ⋂[κ] (A κ).
  Proof.
    move=> [R [𝒟 _]].
    exists R; T.split; auto.
    Tower.destruct_tower.
    replace (fun M0M1 => ∀ κ, S κ M0M1) with (fun M0M1 => ∀ κ, ▷[κ] (S κ M0M1)).
    - Tac.prove.
      T.specialize_hyps.
      rewrite -Clo.roll.
      by Tac.prove; apply: Later.next.
    - T.eqcd => ?.
      apply: Later.force.
  Qed.

  Theorem force {i A B} :
    (τ[i] ⊧ ⋂ A ∼ ⋂ B)
    → τ[i] ⊧ ⋂[κ] ▶[κ] A κ ∼ ⋂[κ] B κ.
  Proof.
    move=> 𝒟.
    apply: General.ty_eq_trans.
    - eassumption.
    - apply: force_reflexive.
      apply: General.ty_eq_refl_left.
      eassumption.
  Qed.

  Theorem loeb_induction_closed κ i {A B M0 M1} :
    τ[i] ⊧ A ∼ B
    → τω ⊧ ⋄ ∙ ▶[κ]A ≫ A.[^1] ∋ M0 ∼ M1
    → τω ⊧ A ∋ 𝛍{ M0 } ∼ 𝛍{ M1 }.
  Proof.
    move=> [R [AR _]] ℰ.
    apply: (@Later.loeb κ).

    move=> ℱ.
    T.efwd ℰ.
    - apply: General.mem_eq_conv_both.
      + move=> V; case: (fix_unfold M0 V) => _; apply.
      + move=> V; case: (fix_unfold M1 V) => _; apply.
      + T.use ℰ; f_equal; by Program.simplify_subst.
    - simpl; split; auto.
      exists (fun M0M1 => ▷[κ] (R M0M1)); split.
      + exists i.
        Tac.prove.
        Later.gather.
        move=> [? ?].
          by rewrite Prog.subst_ret.
      + Later.gather; case => R' [AR' mue0mue1].
        replace R with R'; auto.
        apply: TS.is_extensional.
        * exact AR'.
        * eexists; eauto.
  Qed.

  Lemma fun_ty_inversion {i A B R} :
    τ[i] ((A ⇒ B)%prog, R)
    → ∃ (RA : rel) (RB : Prog.t 0 → rel),
      τ[i] (A, RA)
      ∧ (∀ M0 M1 : Prog.t 0,
            RA (M0, M1)
            → τ[i] ((B ⫽ Sub.inst0 M0)%prog, RB M0)
              ∧ τ[i] ((B ⫽ Sub.inst0 M0)%prog, RB M1)
              ∧ τ[i] ((B ⫽ Sub.inst0 M1)%prog, RB M1)
              ∧ τ[i] ((B ⫽ Sub.inst0 M1)%prog, RB M0))
      ∧ R = Connective.fun_el RA RB.
  Proof.
    move=> 𝒟.
    Tower.destruct_tower.
    eauto.
  Qed.

  Theorem apply κ {A B f0 f1} :
    τω ⊧ ▶[κ] (A ⇒ B) ∋ f0 ∼ f1
    → τω ⊧ (▶[κ] A) ⇒ (▶[κ] B) ∋ f0 ∼ f1.
  Proof.
    move=> /Level.eq_mem_to_level [n𝒟 [R𝒟 [𝒟0 𝒟1]]].
    apply: (Level.eq_mem_from_level n𝒟).
    Tower.destruct_tower.

    exists (Connective.fun_el (fun Ms => ▷[κ0] (τ[n𝒟] @ A Ms)) (fun x => fun Ms => ▷[κ0] (τ[n𝒟] @ (B ⫽ Sub.inst0 x)%prog Ms))).
    split.
    - Tac.tower_intro; apply: Sig.conn; eauto.
      apply: Connective.has_arr.
      + rewrite !Clo.roll.
        Tac.tower_intro; apply: Sig.conn; eauto.
        apply: Connective.has_later.
        Later.gather; case=> M0M1 ABR.
        rewrite Clo.roll.
        Tower.destruct_tower.
        T.use H1; repeat f_equal; eauto.
      + rewrite !Clo.roll.
        move=> M0 M1 M0M1; repeat split;
        Tac.tower_intro;
        (apply: Sig.conn; first by [simpl; eauto]);
        apply: Connective.has_later; rewrite !Clo.roll;
        Later.gather; case=> X1 [X2 X3]; Tower.destruct_tower;
        specialize (H2 M0 M1); (edestruct H2 as [H3 [H4 [H5 H6]]]; first by [T.use X3; apply: equal_f; eauto]).
        * T.use H4; repeat f_equal; eauto.
        * T.use H4; repeat f_equal; eauto.
        * T.use H5; repeat f_equal; eauto.
        * T.use H6; repeat f_equal; eauto.

    - split=> M0 M1 M0M1.
      Later.gather; case=> f0f1 [H1 H2].
      Tower.destruct_tower.
      dependent destruction f0f1.
      specialize (H M0 M1).
      T.efwd_thru H.
      + apply: equal_f.
        edestruct H3 as [H5 [H6 [H7 H8]]]; eauto.
      + T.use H2; apply: equal_f; eauto.
  Qed.

  Lemma existential_trickery {A} {P Q : A → Prop} :
    (∀ (x : {x : A | P x}), Q (proj1_sig x))
    → (∀ x : A, P x → Q x).
  Proof.
    move=> H x px.
    apply: (H (exist _ x px)).
  Defined.

  Theorem pi_later_univ_eq i κ {A0 A1 B0 B1} :
    τω ⊧ ▶[κ] 𝕌[i] ∋ A0 ∼ A1
    → τω ⊧ ⋄ ∙ A0 ≫ ▶[κ] 𝕌[i] ∋ B0 ∼ B1
    → τω ⊧ ▶[κ] 𝕌[i] ∋ (A0 ⇒ B0) ∼ (A1 ⇒ B1).
  Proof.
    move=> [R𝒟 [𝒟0 𝒟1]] ℰ.
    exists R𝒟; split; eauto.
    case: 𝒟0 => n 𝒟0.
    Tower.destruct_tower.

    suff ℱ : ▷[κ0] (τω ⊧ ⋄ ∙ A0 ≫ 𝕌[i] ∋ B0 ∼ B1).
    - Later.gather.
      case => X [Y Z].
      rewrite -Clo.roll in Y.
      dependent induction n.
      + Clo.destruct_sig.
        * contradiction.
        * OpSem.destruct_evals.
          Clo.destruct_has.
      + Clo.destruct_sig; Spine.simplify.
        * case: H => //= [j [? [? Q]]].
          OpSem.destruct_evals.
          rewrite Q //=; rewrite Q //= in X.

          ecase (@Fam.family_choice τ[j]); try by [typeclasses eauto].
          ** eauto.
          ** apply: Univ.open_inversion; eauto.
          ** move=> Rℰ Rℰsp.
             case: X => RA [X0 X1].
             eexists; split; Tac.tower_intro;
             (apply: Sig.conn; first by [auto]);
             (constructor; first by [eassumption]);
             move=> M0 M1 M0M1;
             (case: (Rℰsp M0 M1); first by [eexists; split; eauto]);
             move=> Q' ?; T.destruct_conjs; repeat split; eauto; by rewrite -Q'.
        * OpSem.destruct_evals.
          dependent induction H1.

    - apply: Later.push_universal => γ0.
      apply: (Later.map existential_trickery).
      apply: Later.push_universal; case => γ1 γ01 //=.
      apply: mem_univ_inversion.
      apply: univ_eq.
      by apply: ℰ.
  Qed.

  Theorem preserves_pi i κ {A0 A1 B0 B1} :
    ▷[κ] (τ[i] ⊧ A0 ∼ A1)
    → ▷[κ] (τ[i] ⊧ ⋄ ∙ A0 ≫ B0 ∼ B1)
    → τ[i] ⊧ ▶[κ] (A0 ⇒ B0) ∼ ((▶[κ] A1) ⇒ (▶[κ] B1)).
  Proof.
    move=> 𝒟 ℰ.
    exists (fun Ms => ▷[κ] (Connective.fun_el (τ[i] @ A0) (fun x => τ[i] @ (B1 ⫽ Sub.inst0 x)%prog) Ms)).
    split.

    - Tac.tower_intro; apply: Sig.conn; eauto.
      constructor; rewrite !Clo.roll.
      Later.gather; case=> 𝒟 ℰ.
      Tac.tower_intro; apply: Sig.conn; eauto.
      constructor; rewrite !Clo.roll.
      + case: 𝒟 => ? [𝒟0 ?].
        T.use 𝒟0; rewrite /Tower.t; repeat f_equal; eauto.
      + move=> M0 M1 M0M1.
        case: (Fam.family_choice 𝒟 ℰ) => RB ℱ.
        case: (ℱ M0 M1).
        * exists (τ[i] @ A0); split; eauto.
          case: 𝒟 => ? [𝒟0 ?]; T.use 𝒟0.
          repeat f_equal; eauto.
        * move=> ℱ0 [ℱ1 [ℱ2 [ℱ3 ℱ4]]].
          repeat split; [T.use ℱ1 | T.use ℱ1 | T.use ℱ3 | T.use ℱ3];
          rewrite /Tower.t; repeat f_equal; eauto.

    - Tac.ts_choose_rel (Connective.fun_el (fun Ms => ▷[κ] (τ[i] @ A0 Ms)) (fun x => fun Ms => ▷[κ] (τ[i] @ (B1 ⫽ Sub.inst0 x)%prog Ms))).
      + Tac.tower_intro; apply: Sig.conn; eauto.
        rewrite !Clo.roll; constructor.
        * Tac.tower_intro; apply: Sig.conn; eauto.
          rewrite !Clo.roll; constructor.
          Later.gather; case=> [[RA [𝒟0 𝒟1]]] _.
          T.use 𝒟1; rewrite /Tower.t; repeat f_equal; eauto.
        * move=> M0 M1 M0M1; repeat split;
        Tac.tower_intro; (apply: Sig.conn; first by [simpl; eauto]);
        apply: Connective.has_later; Later.gather; case=> 𝒟 [/(Fam.family_choice 𝒟)] => ℰ ℱ;
        rewrite !Clo.roll; case: ℰ => R ℰ; specialize (ℰ M0 M1);
        (destruct ℰ as [H1 [H2 [H3 [H4 H5]]]];
          first by
              [ exists (τ[i] @ A0); split; case 𝒟=> RA [𝒟0 𝒟1];
                [ T.use 𝒟0; repeat f_equal; eauto
                | T.use ℱ; apply: equal_f; apply: (TS.is_extensional τ[i]); simpl; T.use 𝒟1; repeat f_equal; eauto
                ]
              ]);
        [T.use H5 | T.use H5 | T.use H3 | T.use H3];
        rewrite /Tower.t; repeat f_equal; eauto.
      + apply: binrel_extensionality => M0 M1; split.
        * move=> ℱ; split=> N0 N1 N0N1.
          Later.gather; case=> X0 [X1 X2].
          dependent destruction X2.
          dependent destruction H0.
          eauto.
        * move=> X.
          dependent destruction X.
          have: ▷[ κ] (∀ N0 N1, (τ[ i] @ A0) (N0, N1) → (τ[ i] @ (B1 ⫽ Sub.inst0 N0)%prog) ((M0 ⋅ N0)%prog, (M1 ⋅ N1)%prog)).
          ** apply: Later.push_universal => N0.
             apply: Later.push_universal => N1.
             specialize (H N0 N1).
             by rewrite Later.commute_imp.
          ** move {H} => H.
             Later.gather; case=> ? [? ?].
             split; eauto.
  Qed.

  Theorem preserves_sigma i κ {A0 A1 B0 B1} :
    ▷[κ] (τ[i] ⊧ A0 ∼ A1)
    → ▷[κ] (τ[i] ⊧ ⋄ ∙ A0 ≫ B0 ∼ B1)
    → τ[i] ⊧ ▶[κ] (A0 × B0) ∼ ((▶[κ] A1) × (▶[κ] B1)).
  Proof.
    move=> 𝒟 ℰ.
    apply: General.ty_eq_symm.

    exists (Connective.prod_el (fun Ms => ▷[κ] (τ[i] @ A1 Ms)) (fun x => fun Ms => ▷[κ] (τ[i] @ (B1 ⫽ Sub.inst0 x)%prog Ms))).
    split.

    - Tac.tower_intro; apply: Sig.conn; eauto.
      constructor; rewrite !Clo.roll.
      + Tac.tower_intro; apply: Sig.conn; eauto.
        apply: Connective.has_later.
        Later.gather; case=> 𝒟 _.
        rewrite !Clo.roll.
        case: 𝒟 => RA [𝒟0 𝒟1].
        T.use 𝒟1; rewrite /Tower.t; repeat f_equal; eauto.
      + move=> M0 M1 M0M1; repeat split;
        Tac.tower_intro; (apply: Sig.conn; first by [simpl; eauto]);
        apply: Connective.has_later; Later.gather; case=> 𝒟 [/(Fam.family_choice 𝒟)] => ℰ ℱ;
        rewrite !Clo.roll; case: ℰ => R ℰ; specialize (ℰ M0 M1);
        (destruct ℰ as [H1 [H2 [H3 [H4 H5]]]];
          first by
              [ exists (τ[i] @ A0); split; case 𝒟=> RA [𝒟0 𝒟1];
                [ T.use 𝒟0; repeat f_equal; eauto
                | T.use ℱ; apply: equal_f; apply: (TS.is_extensional τ[i]); simpl; T.use 𝒟1; repeat f_equal; eauto
                ]
              ]);
        [T.use H5 | T.use H5 | T.use H3 | T.use H3];
        rewrite /Tower.t; repeat f_equal; eauto.

    - Tac.ts_choose_rel (fun Ms => ▷[κ] (Connective.prod_el (τ[i] @ A1) (fun x => τ[i] @ (B1 ⫽ Sub.inst0 x)%prog) Ms)).
      + Tac.tower_intro; apply: Sig.conn; eauto.
        apply: Connective.has_later.
        Later.gather; case=> 𝒟 /(Fam.family_choice 𝒟) [RB ℰ]; rewrite !Clo.roll.
        Tac.tower_intro; apply: Sig.conn; eauto.
        apply: Connective.has_prod; rewrite !Clo.roll.
        * case: 𝒟 => RA [𝒟0 𝒟1].
          T.use 𝒟0; rewrite /Tower.t; repeat f_equal; eauto.
        * move=> M0 M1 M0M1; specialize (ℰ M0 M1).
          destruct ℰ as [ℰ1 [ℰ2 [ℰ3 [ℰ4 ℰ5]]]].
          ** exists (τ[i] @ A1); split; eauto.
             case: 𝒟 => RA [𝒟0 𝒟1]; T.use 𝒟0; repeat f_equal; eauto.
          ** repeat split; [T.use ℰ2 | T.use ℰ2 | T.use ℰ4 | T.use ℰ4];
             rewrite /Tower.t; repeat f_equal; eauto.
      + apply: binrel_extensionality => M0 M1; split.
        * move=> H.
          dependent destruction H.
          Later.gather; case=> ? [? [? ?]].
          constructor; eauto.
        * move=> H.
          constructor; Later.gather; case=> 𝒟 [ℰ X];
          dependent destruction X; eauto.
  Qed.
End Later.

Module Canonicity.
  Definition quote_bool (b : bool) : Prog.t 0 :=
    match b with
    | true => Prog.tt
    | false => Prog.ff
    end.

  Notation "⌊ b ⌋𝔹" := (quote_bool b).

  Theorem canonicity {M} :
    τω ⊧ 𝟚 ∋ M ∼ M
    → ∃ b : bool, M ⇓ ⌊b⌋𝔹.
  Proof.
    move=> /Level.eq_mem_to_level [n [R [𝒟 ?]]].
    Tower.destruct_tower.
    Connective.destruct_cext.
    dependent destruction H1.
    - by exists true.
    - by exists false.
  Qed.
End Canonicity.


(** * Associations *)

Set Implicit Arguments.

Require Export decidable_IN.

(** Given a set [A], asociaions are list of elements of [name * A].
   Associations are used for

   - simultaneous substitution

   - simultaneous renaming

   - Kripke semantics *)

Definition assoc (A:Type) := list (name * A).

(** Domain of an association *)

Fixpoint dom (A : Type) (rho: assoc A) {struct rho} : list name :=
  match rho with
    | nil           => nil
    | (x,a) :: rho0 => x :: dom rho0
  end.

Fixpoint fun_assoc A (rho:assoc A) (x:name) {struct rho} : option A :=
  match rho with
    | nil => None
    | (y,a) :: rho0
      => if eqdec x y then Some a else fun_assoc rho0 x
  end.

Notation " rho ^^ x " := (@fun_assoc _ rho x) (at level 60).

(** A tactic distinguishing values of function association. *)

Ltac case_assoc :=
  match goal with
    | |- context [ ?eta ^^ ?x ]       => destruct (eta ^^ x)
    | H : context [ ?eta ^^ ?x ] |- _ => destruct (eta ^^ x)
  end.

(** If [a] is not in [dom (rho)], then [rho (a)] is undefined. *)

Lemma notIN_dom_None : forall A (a: name) (rho: assoc A),
  a # (dom rho) ->
  rho ^^ a = None.
Proof.
  induction rho as [| (x, a0)]; auto; simpl; intros; case_var; intuition.
Qed.

Hint Resolve notIN_dom_None.

(** If [a] is in [dom (rho)], there is some [b] s.t. [rho(a) = Some x]. *)

Fixpoint IN_dom_sig X (a : name) (eta : assoc X) {struct eta} :
  IN_name a (dom eta) -> {x : X | eta ^^ a = Some x} :=
  match eta return IN_name a (dom eta) -> {x : X | eta ^^ a = Some x} with
    | nil => fun H   => False_rect _ H
    | (b, y) :: eta0 =>
      match a == b as s0
        return (if s0 then True else IN_name a (dom eta0)) ->
        {x : X | (if s0 then Some y else eta0 ^^ a) = Some x}
        with
        | left _   =>
          fun _ => exist _ y (eq_refl (Some y))
        | right H0 =>
          fun H => IN_dom_sig a eta0 H
      end
  end.

(*
Lemma IN_dom_sig : forall A (a: name) (rho: assoc A),
  (IN_name a (dom rho)) ->
  {b : A | rho ^^ a = Some b}.
Proof.
induction rho as [| [x y]]; simpl; intros;
  [ intuition
    | case_var;
      [ exact (exist (fun b => Some y = Some b) y (refl_equal (Some y)))
        | auto
      ]
  ].
Qed.
*)

Lemma fun_assoc_eq: forall X (eta : assoc X) a b,
  a = b ->
  forall x,
    ((b, x) :: eta) ^^ a = Some x.
Proof.
  simpl; intros; case_var; intuition.
Qed.

Lemma fun_assoc_neq: forall X (eta : assoc X) a b,
  a <> b ->
  forall x,
    eta ^^ a  = ((b, x) :: eta) ^^ a.
Proof.
  simpl; intros; case_var; intuition.
Qed.

Lemma fun_assoc_ext_1 : forall A (eta eta0 : assoc A) x y,
  x = y ->
  forall z d d',
    (eta ++ (x, d) :: eta0) ^^ z = (eta ++ (x, d) :: (y, d') :: eta0) ^^ z.
Proof.
  induction eta as [ | [x0 a ]]; simpl; intros;
    repeat case_var; intuition try congruence; auto.
Qed.

Lemma fun_assoc_ext_2 : forall A (eta eta0 : assoc A) x y,
  x <> y ->
  forall z d d',
    (eta ++ (x, d) :: (y, d') :: eta0) ^^ z =
    (eta ++ (y, d') :: (x, d) :: eta0) ^^ z.
Proof.
  induction eta as [ | [x0 a ]]; simpl; intros;
    repeat case_var; intuition try congruence; auto.
Qed.

Lemma fun_assoc_ext_3 :
  forall A (eta eta0 : assoc A) x y,
    x = y -> IN_name x (dom (eta)) ->
    forall d,
      (eta ++ eta0) ^^ x = (eta ++ (y, d) :: eta0) ^^ x.
Proof.
  induction eta as [ | [x0 a ] ]; simpl; intros;
  repeat case_var; intuition try congruence. auto; intuition.
Qed.


(*
 * Copyright (c) 2009-2012, Andrew Appel, Robert Dockins and Aquinas Hobor.
 * This presentation of Permission Algebras and Separation Algebras
 * includes ideas from a discussion with Jonas Jensen and also from
 * a paper by Francois Pottier.
 *)
Require Import VST.msl.Extensionality.

Set Implicit Arguments.

Class Join (t: Type) : Type := join: t -> t -> t -> Prop.

(* "Permission Algebra": commutative semigroup,
   such that if units exist, they must have certain properties. *)
Class Perm_alg (t: Type) {J: Join t} : Type :=
  mkPerm   {
   join_eq: forall {x y z z'}, join x y z -> join x y z' -> z = z';
   join_assoc: forall {a b c d e}, join a b d -> join d c e ->
                    {f : t & join b c f /\ join a f e};
   join_comm: forall {a b c}, join a b c -> join b a c;
   join_positivity: forall {a a' b b'}, join a a' b -> join b b' a -> a=b
}.
Arguments Perm_alg _ {J}.

Definition unit_for {t}{J: Join t} (e a: t) := join e a a.
Definition identity {t} {J: Join t} (e: t) := forall a b, join e a b -> a=b.

#[export] Hint Extern 2 (@join _ _ _ _ _) =>
   (eapply join_comm; trivial;
     try eassumption;
     (* This next line looks superfluous, but it is not: it catches the
      case where H is join at a function type, where the goal is
      join at an applied function. *)
     match goal with H: @join _ _ _ _ _ |- _ => apply H end)
    : core.
 (* Hint Immediate join_comm. *)

#[export] Hint Unfold unit_for : core.

Lemma join_assoc_uniq:
  forall {t} {J: Join t} (PA1 PA2: @Perm_alg t J),
      forall a b c d e H H',
         (projT1 (@join_assoc _ _ PA1  a b c d e H H'))
        = (projT1 (@join_assoc _ _ PA2  a b c d e H H')).
Proof.
  intros.
  destruct (@join_assoc _ _ PA1  a b c d e H H') as [f [? ?]].
  destruct (@join_assoc _ _ PA2  a b c d e H H') as [g [? ?]].
  simpl. apply (join_eq j j1).
Qed.

  (* Sep_alg: additional properties that makes a Permission Algebra
     into a Separation Algebra. *)
  Class Sep_alg A {J: Join A} : Type :=
    mkSep {
      core: A -> A;
      core_unit: forall t, unit_for (core t) t;
      join_core: forall {a b c}, join a b c -> core a = core c
    }.
Arguments Sep_alg _ {J}.

Lemma core_duplicable {A}{J: Join A}{SA: Sep_alg A}:
  forall a, join (core a) (core a) (core a).
Proof.
 intros.
 generalize (core_unit a); unfold unit_for; intro.
 generalize (core_unit (core a)); unfold unit_for; intro.
 generalize (join_core H); intro.
 rewrite H1 in H0; auto.
Qed.

Lemma core_self_join {A}{J: Join A}{SA: Sep_alg A}:
  forall a, a = core a -> join a a a.
Proof.
  intros.
  generalize (core_unit a); rewrite <- H; intro. apply H0.
Qed.

Lemma core_idem {A}{J: Join A}{SA: Sep_alg A}:
  forall a, core (core a) = core a.
Proof.
 intros.
 generalize (core_unit a); unfold unit_for; intro.
 apply (join_core H).
Qed.

Lemma core_hom {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall {a b c}, join a b c -> join (core a) (core b) (core c).
Proof.
 intros.
 generalize (join_core H); intro.
  generalize (join_core (join_comm H)); intro.
 rewrite H0; rewrite H1.
 apply core_duplicable.
Qed.

Lemma split_core' {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
 forall a b c, join a b (core c) -> a = core a.
Proof.
 intros.
 generalize (join_core H); rewrite core_idem; intro.
 rewrite <- H0 in H.
 clear dependent c.
 generalize (core_unit a); unfold unit_for; intro.
 eapply join_positivity; eauto.
Qed.

Lemma split_core{A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
 forall a b c, join a b (core c) -> unit_for a a.
Proof.
 intros.
 unfold unit_for.
 replace a with (core a).
 apply core_duplicable.
 symmetry; eapply split_core'; eauto.
Qed.

Lemma core_uniq {t} {J: Join t}{PA: Perm_alg t}:
   forall (SA1: @Sep_alg _ J)
          (SA2: @Sep_alg _ J),
     forall x, @core _ _ SA1 x = @core _ _ SA2 x.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
 intros.
 generalize  (@core_unit _ _ SA1 x); unfold unit_for; intro.
 generalize  (@core_unit _ _ SA2 x); unfold unit_for; intro.
 destruct (join_assoc (join_comm H0) (join_comm H1)) as [f [? ?]].
 generalize (@core_unit _ _ SA2 (@core _ _ SA1 x)); unfold unit_for; intro.
 generalize (@core_unit _ _ SA1 (@core _ _ SA2 x)); unfold unit_for; intro.
 destruct (join_assoc ( H4) H2) as [g [? ?]].
 destruct (join_assoc H5 (join_comm H2)) as [h [? ?]].
 generalize (join_eq H6 (join_comm H8)); intro. rewrite <- H10 in *; clear dependent h.
 generalize (@join_core _ _ SA1 _ _ _ H4); intro.
 generalize (@join_core _ _ SA1 _ _ _ H0); intro.
 generalize (@join_core _ _ SA2 _ _ _ H0); intro.
 rewrite H11 in *. rewrite H12 in *. rewrite H10 in *.
 apply join_comm in H4.
 apply (join_eq H4 H5).
Qed.

Lemma join_core2 {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall a b c, join a b c -> core a = core b.
Proof.
intros. generalize H; intro.
apply join_comm in H.
apply join_core in H0; apply join_core in H. congruence.
Qed.

(* Disj_alg: adds the property that no nonempty element can join with itself. *)
Class Disj_alg  (t: Type) {J: Join t} :=
   join_self: forall {a b}, join a a b -> identity a.
Arguments Disj_alg _ {J}.

Lemma join_self' {A}{J: Join A}{DA: Disj_alg A} :
  forall {a b}, join a a b -> a = b.
Proof.
 intros.
 eapply join_self; eauto.
Qed.

Lemma   unit_identity {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A} :
        forall {e} b, unit_for e b -> identity e.
Proof.
 intros.
 destruct (join_assoc (join_comm H) (join_comm H)) as [? []].
 eapply join_self; eauto.
Qed.

Lemma core_identity  {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall a, identity (core a).
Proof.
  repeat intro.
  eapply join_eq; eauto.
  replace (core a) with (core a0); [apply core_unit|].
  symmetry; rewrite <- core_idem.
  eapply join_core2; eauto.
Qed.

Lemma join_ex_identity  {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
     forall a, {e : A & prod (identity e) (unit_for e a) }.
Proof.
 intros.
 exists (core a).
 split.
 apply core_identity.
 apply core_unit.
Qed.

Lemma identity_core  {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall a, identity a -> a = core a.
Proof.
  intros.
  symmetry; apply H.
  apply join_comm, core_unit.
Qed.

  (* Sing_alg: adds the property that makes the Permission Algebra
     into a single-unit Separation Algebra.  (this is the "traditional"
     kind of Separation Algebra).   *)
Class Sing_alg A {J: Join A}{SA: Sep_alg A} :=
    mkSing {
      the_unit: A;
      the_unit_core: forall a, core a = the_unit
    }.
Arguments Sing_alg _ {J} {SA}.
Arguments mkSing [A] [J] [SA] _ _.

  (* Positive Permission Algebra: there are no units, every element is nonempty *)
  Class Pos_alg  {A} {J: Join A} :=
    no_units: forall e a, ~unit_for e a.
Arguments Pos_alg _ {J}.

(* Has the "cross-split" property described in Dockins et al,
    "A fresh look at separation algebras and share accounting", 2009 *)
Class Cross_alg (t: Type)  `{J: Join t} :=
   cross_split :
      forall a b c d z : t,
       join a b z ->
       join c d z ->
    { x:(t*t*t*t) &  match x with (ac,ad,bc,bd) =>
         join ac ad a /\ join bc bd b /\ join ac bc c /\ join ad bd d
       end
    }.
Arguments Cross_alg _ {J}.

(* Has the "triple join" property  *)
Class Trip_alg {A} {J: Join A} :=
  triple_join_exists:
  forall (a b c ab bc ac : A), join a b ab -> join b c bc -> join a c ac ->
       {abc | join ab c abc}.
Arguments Trip_alg _ {J}.

(* We do NOT yet introduce "emp" as a notation or synonym for "identity".
  This is because "emp" is a predicate of Separation Logic, but this file
  contains only Separation Algebras.  Some separation logics have
  predicates that are not just "t -> Prop", and therefore it is premature
  in this file to define "emp".
*)

(** * Lemmas about separation algebras. *)

Lemma  join_ex_units{A}{J: Join A}{SA: Sep_alg A}:
    forall a, {e : A & unit_for e a }.
Proof.
 intros. exists (core a). apply core_unit.
Qed.

Lemma same_identity {A}{J: Join A}{PA: Perm_alg A}:
  forall e e' a, identity e -> unit_for e a -> identity e' -> unit_for e' a -> e = e'.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
 intros.
 unfold unit_for in *.
 destruct (join_assoc (join_comm H1) (join_comm H3)) as [f [? ?]].
 generalize (H0 _ _ H4); intro.
 generalize (H2 _ _ (join_comm H4)); intro.
 rewrite H6; apply H7.
Qed.

Lemma same_unit {A}{J: Join A}{PA: Perm_alg A}{SA:Sep_alg A}{CA: Disj_alg A}:
       forall {e1 e2 a}, unit_for e1 a -> unit_for e2 a -> e1 = e2.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
intros.
generalize (unit_identity _ H0); intro.
unfold unit_for in *.
destruct (join_assoc (join_comm H0) (join_comm H1)) as [f [? ?]].
generalize (H2 _ _ H3); intro.
rewrite <- H5 in *; clear f H5.
apply join_comm in H3.
apply (unit_identity _ H1 _ _ H3).
Qed.

  (** Elements [a] and [b] join. *)
  Definition joins {A} {J: Join A} (a b : A) : Prop :=
    exists c, join a b c.

  Definition overlap {A}{J: Join A} (a b: A) := ~(joins a b).

  Lemma join_joins {A} {J: Join A}: forall {a b c},
    join a b c -> joins a b.
  Proof. intros; econstructor; eauto.
  Qed.

  Lemma join_joins' {A} {J: Join A} {PA: Perm_alg A}: forall {a b c},
    join a b c -> joins b a.
  Proof.
    intros; econstructor. eauto.
  Qed.

  Lemma joins_sym {A}  {J: Join A} {PA: Perm_alg A}: forall a b,
    joins a b <-> joins b a.
  Proof.
    intros.
    split; intro; destruct H;
      exists x; apply join_comm; trivial.
  Qed.

  Lemma joins_sym': forall {A} `{Perm_alg A} {phi1 phi2}, joins phi1 phi2 -> joins phi2 phi1.
  Proof.
   intros.
   apply joins_sym. auto.
  Qed.

  (** Elememt [a] is a subelement of [c] .  This relation forms a partial order. *)
  Definition join_sub {A} `{Join A} (a c : A) : Prop :=
    exists b, join a b c.

  Lemma join_join_sub {A} `{Perm_alg A}: forall {a b c},
    join a b c ->
    join_sub a c.
  Proof.
    intros; econstructor; eauto.
  Qed.

  Lemma join_join_sub' {A} `{Perm_alg A}: forall {a b c},
    join a b c ->
    join_sub b c.
  Proof.
    intros; econstructor; eauto.
  Qed.

  Lemma join_sub_refl {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall a,
    join_sub a a.
  Proof.
    intros.
    exists (core a). apply join_comm.
    apply core_unit.
  Qed.

  #[export] Hint Resolve join_sub_refl : core.

  Lemma join_sub_trans {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall a b c,
    join_sub a b ->
    join_sub b c ->
    join_sub a c.
  Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
    intros. destruct H0; destruct H1.
    destruct (join_assoc H0 H1) as [f [? ?]].
    econstructor; eauto.
  Qed.

  Lemma join_sub_unit_for {A} {J: Join A}{PA: Perm_alg A}:
    forall e a b, unit_for e a -> join_sub a b -> unit_for e b.
  Proof.
    unfold unit_for; intros ???? [].
    destruct (join_assoc H H0) as [b' []].
    assert (b' = b) by (eapply join_eq; eauto).
    subst; auto.
  Qed.

Lemma join_sub_same_identity {A} {J: Join A}{PA: Perm_alg A}:
   forall e e' a c,  identity e -> unit_for e a -> identity e' -> unit_for e' c ->
                  join_sub a c -> e = e'.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
  intros.
  destruct H4.
  unfold unit_for in *.
  destruct (join_assoc (join_comm H1) H4) as [f [? ?]].
   generalize (H0 _ _ H5); intro.
   rewrite <- H7 in *; clear dependent f.
   destruct (join_assoc H5 (join_comm H6)) as [g [? ?]].
   generalize (join_eq H4 (join_comm H7)); intro.
   rewrite <- H9 in *; clear dependent g.
   apply same_identity with c; auto.
Qed.

  Lemma join_sub_joins {A} `{HA: Perm_alg A}: forall {a b},
    join_sub a b -> joins a b -> joins a a.
  Proof.
    intros a b [? ?] [? ?].
    apply join_comm in H0.
    destruct (join_assoc H H0) as [? [? ?]].
    destruct (join_assoc H1 (join_comm H2)) as [? [? ?]].
    econstructor; eauto.
  Qed.
  (* Note: there are two other conceivable conclusions from the above
     premises: "joins b b" and "join_sub b a".  Neither must follow, since
     neither is true on the bools, but also neither is a contradiction
     since both are true on Z *)

  Lemma join_sub_joins_trans {A} `{HA: Perm_alg A}: forall {a b c},
    join_sub a c -> joins c b -> joins a b.
  Proof.
    intros.
    destruct H as [wx ?].
    destruct H0 as [wy ?].
    destruct (join_assoc (join_comm H) H0) as [wf [? ?]].
    econstructor; eauto.
  Qed.

  Lemma join_sub_joins'  {A} `{HA: Perm_alg A}:
    forall {a a' b b' : A},
      join_sub a a' -> join_sub b b' -> joins a' b' -> joins a b.
  Proof.
    intros.
    destruct H; destruct H0; destruct H1.
    destruct (join_assoc (join_comm H) H1) as [f [? ?]].
    destruct (join_assoc (join_comm H0) (join_comm H2)) as [g [? ?]].
    exists g; apply join_comm; auto.
  Qed.

  Definition sub_silhouette {A} `{Perm_alg A} (a b: A) : Prop :=
    forall c, joins c b -> joins c a.

  Definition same_silhouette {A} `{Perm_alg A} (a b: A) : Prop :=
    forall c, joins c a <-> joins c b.

  Lemma sub_silhouette_refl {A} `{Perm_alg A}: forall a, sub_silhouette a a.
  Proof. unfold sub_silhouette; intuition. Qed.

  Lemma sub_silhouette_trans {A} `{Perm_alg A}: forall a b c,
    sub_silhouette a b -> sub_silhouette b c -> sub_silhouette a c.
  Proof. unfold sub_silhouette; intuition. Qed.

  Lemma same_silhouette_refl {A} `{Perm_alg A}: forall a, same_silhouette a a.
  Proof. unfold same_silhouette; intuition. Qed.

  Lemma same_silhouette_sym {A} `{Perm_alg A}: forall a b,
    same_silhouette a b -> same_silhouette b a.
  Proof.  unfold same_silhouette; intros; split; apply H0; auto.
  Qed.

  Lemma same_silhouette_trans {A} `{Perm_alg A}: forall a b c,
    same_silhouette a b -> same_silhouette b c -> same_silhouette a c.
 Proof. unfold same_silhouette; intros; split; intros;
             destruct (H0 c0); destruct (H1 c0);   auto. Qed.

  Lemma same_silhouette_sub1{A} `{Perm_alg A}: forall a b,
    same_silhouette a b -> sub_silhouette a b.
  Proof. unfold same_silhouette, sub_silhouette; intros; intuition; destruct (H0 c); auto. Qed.

  Lemma same_silhouette_sub2 {A} `{Perm_alg A}: forall a b,
     same_silhouette a b -> sub_silhouette b a.
  Proof. unfold same_silhouette, sub_silhouette; intros; intuition; destruct (H0 c); auto. Qed.

  Lemma sub_same_silhouette {A} `{Perm_alg A}:
    forall a b, sub_silhouette a b -> sub_silhouette b a -> same_silhouette a b.
  Proof. unfold same_silhouette, sub_silhouette; intuition; destruct (H0 c); auto. Qed.

  Lemma same_silhouette_join {A} `{HA: Perm_alg A}:
    forall phi phi' phiy phiz phiz',
      same_silhouette phi phi' ->
      join phi phiy phiz ->
      join phi' phiy phiz' ->
      same_silhouette phiz phiz'.
  Proof.
    intros.
    intro phiu.
    split; intros [phix ?].
    destruct (join_assoc H0 (join_comm H2)) as [phif [? ?]].
    specialize (H phif).
    destruct H.
    assert (exists phiz, join phi phif phiz) by eauto.
    assert (joins phif phi) by (apply joins_sym;  auto).
    specialize (H H7).
    clear H5 H6 H7.
    destruct H as [phix' ?].
    destruct (join_assoc (join_comm H3) H) as [phig [? ?]].
    generalize (join_eq H1 (join_comm H5)); intro.
    rewrite <- H7 in *. clear phig H7 H5.
    exists phix'.
    auto.
    destruct (join_assoc H1 (join_comm H2)) as [phif [? ?]].
    specialize (H phif).
    destruct H.
    assert (exists phiz, join phi' phif phiz) by eauto.
    assert (joins phif phi') by (apply joins_sym;  auto).
    specialize (H5 H7).
    clear H H6 H7.
    destruct H5 as [phix' ?].
    destruct (join_assoc (join_comm H3) H) as [phig [? ?]].
    generalize (join_eq H0 (join_comm H5)); intro.
    rewrite <- H7 in *; clear phig H7 H5.
    exists phix'.
    auto.
  Qed.

#[export] Hint Resolve join_joins join_joins' join_join_sub join_join_sub' : core.

  Definition nonidentity {A} `{Perm_alg A} (a: A) := ~(identity a).

  (** If [a] is a subelement of [b], their units are equal. *)
  Lemma join_sub_units_eq {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A} :
   forall {a b} ea eb,
    join_sub a b ->
    unit_for ea a ->
    unit_for eb b ->
    ea = eb.
  Proof.
    unfold unit_for.
    intros.
    destruct H.
    destruct (join_assoc H0 H) as [f [? ?]].
    generalize (join_eq H H2); intro.
    rewrite <- H4 in *; clear f H4 H2.
    eapply same_unit; eauto.
  Qed.

  Lemma unit_core{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A}:
      forall {a}, unit_for a a -> a = (core a).
  Proof.
   intros.
   eapply identity_core, unit_identity; eauto.
  Qed.

  (** A unit for an element is a unit for itself (is idempotent). *)
  Lemma unit_self_unit {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A} :
   forall a ea,   unit_for ea a ->  unit_for ea ea.
  Proof.
    intros.
    unfold unit_for in *.
    destruct (join_assoc (join_comm H) (join_comm H)) as [f [? _]].
    generalize (unit_identity _ H); intro.
    generalize (H1 _ _ H0); intro.
   rewrite <- H2 in H0; clear f H2.
   auto.
  Qed.

  (** If a joins with b, then their units are equal. *)
  Lemma joins_units_eq {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A}:
   forall {a b} ea eb,
    joins a b ->
    unit_for ea a ->
    unit_for eb b ->
    ea  = eb.
  Proof.
    intros.
    destruct H.
    unfold unit_for in *.
    destruct (join_assoc (join_comm H0) H) as [f [? ?]].
    generalize (unit_identity _ H0 _ _ H2); intro.
    rewrite <- H4 in *; clear f H4.
    eapply same_unit; eauto.
  Qed.

  (** The existence of identity elements. *)
  Lemma join_ex_identities {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall a,
    {e : A & identity e /\ joins e a}.
  Proof.
    intro x.
    destruct (join_ex_identity x) as [e [? ?]].
   exists e; split; auto.
   exists x; auto.
  Qed.

  (** If something is an identity and it joins with an element then it is a
     unit for that element. *)
  Lemma identity_unit {A} `{HA: Perm_alg A}: forall e a,
    identity e ->
    joins e a ->
    unit_for e a.
  Proof.
    intros. destruct H0.
    generalize (H a x H0); intro.
    rewrite <- H1 in *; clear x H1.
    trivial.
  Qed.

  Lemma identity_unit' {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
    forall a,  identity a -> unit_for a a.
  Proof.
    repeat intro.
    apply identity_unit; trivial.
    exists a.
    destruct (join_ex_units a) as [ea H0].
    generalize (join_comm H0); intro.
    generalize (H ea a H1); intro.
    rewrite <- H2 in *; clear a H2.
    trivial.
  Qed.

  (** Identities are exactly units for themselves (are idempotent).*)
  Lemma identity_unit_equiv {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A}:
    forall a,  identity a <-> unit_for a a.
  Proof.
    intros.
    split; [apply identity_unit' | apply unit_identity].
  Qed.

  (** Joinable identities are unique. *)
  Lemma identities_unique {A} `{HA: Perm_alg A} :
   forall e1 e2,  identity e1 ->  identity e2 ->  joins e1 e2 ->  e1 = e2.
  Proof.
    intros.
    destruct H1.
    assert (e2 = x) by auto.
    apply join_comm in H1.
    assert (e1 = x) by auto.
    rewrite H3; rewrite H2; reflexivity.
  Qed.

Lemma split_identity{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
 forall a b c, join a b c -> identity c -> identity a.
Proof.
 intros.
 apply identity_core in H0.
 rewrite H0 in H.
 erewrite split_core' by eauto.
 apply core_identity.
Qed.

  (* The contrapositive of split_identity *)
  Lemma join_nonidentity {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall a b c,
    nonidentity a -> join a b c -> nonidentity c.
  Proof.
    intros a b c H H0 H1.
    contradiction H.
    apply split_identity with b c; auto.
  Qed.

  Lemma join_sub_antisym {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall x y,
    join_sub x y ->
    join_sub y x ->
    x = y.
  Proof.
    intros ? ? [? ?] [? ?].
    eapply join_positivity; eauto.
  Qed.

  (** This lemma uses the full power of self_join and eliminates both N and Z. *)
  Lemma join_sub_joins_identity {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{DS: Disj_alg A}: forall a b,
    join_sub a b -> joins a b -> identity a.
  Proof.
    intros.
    generalize (join_sub_joins H H0); intro.
    destruct H1.
    eapply join_self; eauto.
  Qed.

  (** Sometimes it is useful to use a negative form of the previous lemma *)
  Lemma join_overlap {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{DS: Disj_alg A}: forall a b,
    join_sub a b -> nonidentity a -> overlap a b.
  Proof.
    repeat intro.
    apply H0.
    eapply join_sub_joins_identity; eauto.
  Qed.

(** The opposite of identity is maximal or full *)

Definition full {A} {JA: Join A}(sigma : A) : Prop :=
   forall sigma', joins sigma sigma' -> identity sigma'.

Definition maximal {A} {JA: Join A} (sigma : A) : Prop :=
  forall sigma', join_sub sigma sigma' -> sigma = sigma'.

Lemma full_maximal {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A} :
       forall a, full a <-> maximal a.
Proof with auto.
 pose proof I. (* hack: shift up auto-named hyps *)
  split; intro.
  intros a'' ?.
  destruct H1 as [a' ?].
  specialize (H0 a').
  apply H0. eauto. apply join_comm...
  intros a' ?.
  destruct H1 as [a'' ?].
  rewrite <- (H0 a'') in *; eauto; clear a'' H0.
  eapply unit_identity; eauto.
Qed.

(** The elements of a multi-unit separation algebra can be partitioned
    into equivalance classes, where two elements are in the class iff
    they have the same unit.
  *)

  Definition comparable {A} `{Sep_alg A}  (a b:A)
    := core a = core b.

  Lemma comparable_refl {A} `{Sep_alg A} : forall a, comparable a a.
  Proof. intros; red; auto. Qed.

  Lemma comparable_sym {A} `{Sep_alg A}: forall a b, comparable a b -> comparable b a.
  Proof. unfold comparable; intros; symmetry; auto. Qed.

  Lemma comparable_trans {A} `{Sep_alg A}: forall a b c, comparable a b -> comparable b c -> comparable a c.
  Proof. unfold comparable; intros; etransitivity; eauto. Qed.

  Lemma comparable_common_unit {A} `{Sep_alg A}: forall a b,
    comparable a b ->
    exists e, join e a a /\ join e b b.
  Proof.
    intros.
    red in H0.
    exists (core a); split.
    apply core_unit.
    rewrite H0; apply core_unit.
  Qed.

  Lemma common_unit_comparable {A} `{Sep_alg A} : forall a b,
    (exists e, join e a a /\ join e b b) ->
    comparable a b.
  Proof.
    intros.
    destruct H0 as [e [H1 H2]].
    unfold comparable.
    rewrite <- (join_core H1).  apply (join_core H2).
Qed.

Lemma join_comparable  {A} `{Sep_alg A}:
  forall phi1 phi2 phi3, join phi1 phi2 phi3 -> comparable phi1 phi3.
Proof.
  intros.
  unfold comparable.
  eapply join_core; eauto.
Qed.

Lemma join_comparable2  {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2 phi3, join phi1 phi2 phi3 -> comparable phi1 phi2.
Proof.
  intros.
  unfold comparable.
  generalize (join_core H); intro.
  generalize (join_core (join_comm H)); intro.
  rewrite H0; rewrite H1; reflexivity.
Qed.

Lemma join_sub_comparable  {A} `{Sep_alg A} : forall a c,
  join_sub a c -> comparable a c.
Proof.
  intros.
  destruct H0.
  eapply join_comparable; eauto.
Qed.

Lemma joins_comparable  {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A} : forall a c,
  joins a c -> comparable a c.
Proof.
  intros a c H0.
  destruct H0.
  eapply join_comparable2; eauto.
Qed.

Lemma join_unit1 {A} `{Perm_alg A}:
  forall x y z, unit_for x z -> y = z -> join x y z.
Proof.
intros. rewrite H1 in *; auto.
Qed.

Lemma join_unit2 {A} `{Perm_alg A}:
  forall x y z, unit_for y z -> x = z -> join x y z.
Proof.
intros. rewrite  H1 in *;  clear x H1. apply join_comm; auto.
Qed.

Lemma join_unit1_e {A} `{Perm_alg A}:
  forall x y z, identity x -> join x y z -> y = z.
Proof.
intros.
eapply join_eq; eauto.
apply identity_unit; eauto.
Qed.

Lemma join_unit2_e {A} `{Perm_alg A}:
  forall x y z, identity y -> join x y z -> x = z.
Proof.
intros.
apply join_comm in H1.
eapply join_unit1_e; eauto.
Qed.

Lemma PermAlg_ext:
  forall (T: Type) (J: @Join T) (sa1 sa2: @Perm_alg T J), sa1=sa2.
Proof. intros.
destruct sa1, sa2.
f_equal; try apply proof_irr.
extensionality a b c d e H1 H2.
destruct (join_assoc1 a b c d e H1 H2) as [f [? ?]].
destruct (join_assoc0 a b c d e H1 H2) as [f0 [? ?]].
apply existT_ext.
eapply join_eq0; eauto.
Qed.

Lemma Sep_alg_ext {T} {J} {PA: @Perm_alg _ J}:
   forall (sa1 sa2: @Sep_alg T J), sa1=sa2.
Proof.
intros.
generalize (@core_uniq _ J _ sa1 sa2); intro.
destruct sa1; destruct sa2.
simpl in H.
assert (core0 = core1).
  extensionality; auto.
subst core1.
f_equal.
apply proof_irr.
apply proof_irr.
Qed.

Definition nonunit {A} `{Join A}  (a: A) := forall x, ~ unit_for a x.

Lemma nonidentity_nonunit {A} {JA: Join A} {PA: Perm_alg A}{SA: Sep_alg A}{CA: Disj_alg A}:
  forall {a}, nonidentity a -> nonunit a.
Proof.
 intros. intros ? H0; apply H. eapply unit_identity; apply H0.
Qed.

Lemma nonunit_nonidentity {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall x, nonunit x -> ~identity x.
Proof. intros. intro.
  apply identity_unit' in H0. apply (H _ H0).
Qed.

(* Canc_alg: makes a Permission Algebra into a cancellative Perm.Alg. *)
Class Canc_alg (t: Type) {J: Join t} :=
    join_canc: forall {a1 a2 b c}, join a1 b c -> join a2 b c -> a1 = a2.
Arguments Canc_alg _ {J}.


Require Export Instances.
Require Export Instances.Typ.

Definition tfin T :=
  exists l: list T, forall x: T, List.In x l.

Lemma not_tfin T: ~tfin T <-> forall l: list T, exists x: T, ~List.In x l.
Proof.
  split.
  + intros H l.
    assert (~forall x: T, List.In x l).
      contradict H.
      now exists l.
    clear H.
    destruct (classic (exists x: T, ~List.In x l)).
    assumption.
    destruct H0.
    intros x.
    destruct (classic (List.In x l)).
    assumption.
    destruct H.
    now exists x.
  + intros H [l Hl].
    specialize (H l).
    destruct H as [x []].
    apply Hl.
Qed.

Lemma tfin_epic A B (f: A ~> B): epic f -> tfin A -> tfin B.
Proof.
  intros Hf [l Hl].
  rewrite Typ_epic in Hf.
  exists (List.map f l).
  intros y.
  specialize (Hf y).
  destruct Hf as [x Hf].
  subst y.
  apply List.in_map, Hl.
Qed.

Definition fin (C: Category) :=
  tfin C /\ forall x y: C, tfin (x ~> y).

Lemma fin_splitepic {S T: Category} (F: S ~> T): splitepic F -> fin S -> fin T.
Proof.
  intros HF H.
  split; [apply proj1 in H | apply proj2 in H].
  eapply tfin_epic, H.
  apply splitepic_is_epic.
  apply fobj_splitepic, HF.
  intros x y.
  destruct HF as [G HF].
  assert ((x ~> y) = ((F ∘ G) x ~> (F ∘ G) y)).
  now rewrite HF.
  rewrite H0; clear H0.
  specialize (H (G x) (G y)).
  destruct H as [l Hl].
  exists (List.map (fmap F) l).
  intros f'.
  assert (exists f: x ~> y, fmap (F ∘ G) f = f').
  revert f'.
  rewrite HF.
  intros f.
  now exists f.
  destruct H as [f Hf].
  subst f'.
  simpl.
  apply List.in_map, Hl.
Qed.

Lemma fin_splitmonic {S T: Category} (F: S ~> T): splitmonic F -> fin T -> fin S.
Proof.
  intros [G H].
  apply (fin_splitepic G).
  now exists F.
Qed.

Instance fin_iso: Proper (isomorphic Cat ==> iff) fin.
Proof.
  enough (Proper (isomorphic Cat ==> impl) fin).
  now split; apply H.
  intros A B [I].
  red.
  apply (fin_splitepic I).
  apply iso_is_splitepic.
Qed.

Lemma fin_0: fin 0.
Proof.
  split.
  now exists nil.
  easy.
Qed.

Lemma fin_1: fin 1.
Proof.
  split.
  2: intros [] [].
  all: exists (tt :: nil)%list.
  all: intros [].
  all: now left.
Qed.

Lemma fin_coprod (A B: Category): fin A -> fin B -> fin (A + B).
Proof.
  intros Ha Hb.
  split.
  all: [> apply proj1 in Ha | apply proj2 in Ha].
  all: [> apply proj1 in Hb | apply proj2 in Hb].
  + destruct Ha as [xs Hx], Hb as [ys Hy].
    exists (List.map inl xs ++ List.map inr ys)%list.
    intros [x | y].
    all: apply List.in_or_app.
    all: [> left | right].
    all: apply List.in_map.
    apply Hx.
    apply Hy.
  + intros [x | x] [y | y].
    1: apply Ha.
    3: apply Hb.
    all: now exists nil.
Qed.

Lemma fin_prod (A B: Category): fin A -> fin B -> fin (A × B).
Proof.
  intros Ha Hb.
  split.
  all: [> apply proj1 in Ha | apply proj2 in Ha].
  all: [> apply proj1 in Hb | apply proj2 in Hb].
  + destruct Ha as [xs Hx], Hb as [ys Hy].
    exists (List.flat_map (fun x => List.map (fun y => (x, y)) ys) xs).
    intros [x y].
    apply List.in_flat_map.
    exists x.
    split.
    apply Hx.
    apply List.in_map.
    apply Hy.
  + intros [x1 y1] [x2 y2].
    specialize (Ha x1 x2).
    specialize (Hb y1 y2).
    destruct Ha as [fs Hf], Hb as [gs Hg].
    exists (List.flat_map (fun f => List.map (fun g => (f, g)) gs) fs).
    intros [f g].
    apply List.in_flat_map.
    exists f.
    split.
    apply Hf.
    apply List.in_map.
    apply Hg.
Qed.


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

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import prelude.basics.
Require Import prelude.cubical_methods.
Require Import groupoid_quotient.gquot.

Local Open Scope cat.

Section gquot_rec.
  Variable (G : groupoid)
           (Y : UU)
           (gclY : G → Y)
           (gcleqY : ∏ {a₁ a₂ : G},
               a₁ --> a₂ → gclY a₁ = gclY a₂)
           (geY : ∏ (a : G), gcleqY (identity a) = idpath _)
           (gconcatY : ∏ (a₁ a₂ a₃: G) (g₁: a₁ --> a₂) (g₂: a₂ --> a₃),
               gcleqY (g₁ · g₂) = gcleqY g₁ @ gcleqY g₂)
           (truncY : isofhlevel 3 Y).

  Definition gquot_rec : gquot G → Y.
  Proof.
    simple refine (gquot_ind
                     (λ _, Y)
                     gclY
                     (λ a₁ a₂ g, PathOverConstant_map1 _ (gcleqY g))
                     (λ a, const_globe_over
                                 (ge G a)
                                 (gcleqY (identity a))
                                 (idpath _)
                                 (geY a))
                     _
                     (λ _, truncY)) ; simpl.
    intros a₁ a₂ a₃ g₁ g₂.
    simple refine (globe_over_whisker
                     (λ _, Y)
                     _
                     (idpath _)
                     (PathOver_inConstantFamily_concat _ _)
                     (const_globe_over
                        (gconcat G g₁ g₂)
                        (gcleqY (g₁ · g₂))
                        (gcleqY g₁ @ gcleqY g₂)
                        (gconcatY a₁ a₂ a₃ g₁ g₂)
                     )
                  ).
  Defined.

  Definition gquot_rec_beta_gcleq (a₁ a₂ : G) (g : a₁ --> a₂)
    : maponpaths gquot_rec (gcleq G g) = gcleqY g.
  Proof.
    apply (PathOver_inConstantFamily_inj (gcleq G g)).
    refine (!(apd_const _ _) @ _).
    apply gquot_ind_beta_gcleq.
  Qed.
End gquot_rec.

Arguments gquot_rec {G} Y gclY gcleqY geY gconcatY {truncY}.

(** If the we have a family of sets, then we can simplify the induction principle. *)
Section gquot_ind_set.
  Variable (G : groupoid)
           (Y : gquot G → UU)
           (gclY : ∏ (a : G), Y(gcl G a))
           (gcleqY : ∏ (a₁ a₂ : G) (g : a₁ --> a₂),
               PathOver (gcleq G g) (gclY a₁) (gclY a₂))
           (truncY : ∏ (x : gquot G), isaset (Y x)).

  Definition gquot_ind_set : ∏ (g : gquot G), Y g.
  Proof.
    simple refine (gquot_ind Y gclY gcleqY _ _ _)
    ; intros.
    - apply path_globe_over_hset.
      apply truncY.
    - apply path_globe_over_hset.
      apply truncY.
    - apply hlevelntosn.
      apply truncY.
  Defined.

  Definition gquot_ind_set_beta_gcl (a : G)
    : gquot_ind_set (gcl G a) = gclY a
    := idpath _.

  Definition gquot_ind_set_beta_gcleq : ∏ (a₁ a₂ : G) (g : a₁ --> a₂),
      apd gquot_ind_set (gcleq G g)
      =
      gcleqY a₁ a₂ g.
  Proof.
    apply gquot_ind_beta_gcleq.
  Qed.
End gquot_ind_set.

Arguments gquot_ind_set {G} Y gclY gcleqY truncY.

(** If the we have a family of propositions, then we can simplify the induction principle. *)
Section gquot_ind_prop.
  Variable (G : groupoid)
           (Y : gquot G → UU)
           (gclY : ∏ (a : G), Y(gcl G a))
           (truncY : ∏ (x : gquot G), isaprop (Y x)).

  Definition gquot_ind_prop : ∏ (g : gquot G), Y g.
  Proof.
    simple refine (gquot_ind_set Y gclY _ _).
    - intros.
      apply PathOver_path_hprop.
      apply truncY.
    - intro.
      apply hlevelntosn.
      apply truncY.
  Qed.
End gquot_ind_prop.

Arguments gquot_ind_prop {G} Y gclY.

(** The double recursion principle.
    We use [gquot_rec], [gquot_ind_set] and [gquot_ind_prop] to define it.
 *)
Section gquot_double_rec.
  Variable (G₁ G₂ : groupoid)
           (Y : UU)
           (truncY : isofhlevel 3 Y).

  Variable (f : G₁ → G₂ → Y)
           (fr : ∏ (a : G₁) (b₁ b₂ : G₂),
               b₁ --> b₂ -> f a b₁ = f a b₂)
           (fre : ∏ (a : G₁) (b : G₂),
               fr a b b (identity b) = idpath _)
           (frc : ∏ (a : G₁) (b₁ b₂ b₃ : G₂)
                         (g₁ : b₁ --> b₂) (g₂ : b₂ --> b₃),
               fr a b₁ b₃ (g₁ · g₂)
               =
               (fr a b₁ b₂ g₁) @ (fr a b₂ b₃ g₂))
           (fl : ∏ (a₁ a₂ : G₁) (b : G₂),
               a₁ --> a₂ -> f a₁ b = f a₂ b)
           (fle : ∏ (a : G₁) (b : G₂),
               fl a a b (identity a) = idpath _)
           (flc : ∏ (a₁ a₂ a₃ : G₁) (b : G₂)
                         (g₁ : a₁ --> a₂) (g₂ : a₂ --> a₃),
               fl a₁ a₃ b (g₁ · g₂)
               =
               (fl a₁ a₂ b g₁) @ (fl a₂ a₃ b g₂))
           (fp : ∏ (a₁ a₂ : G₁) (b₁ b₂ : G₂)
                        (g₁ : a₁ --> a₂) (g₂ : b₁ --> b₂),
               square (fl a₁ a₂ b₂ g₁)
                      (fr a₁ b₁ b₂ g₂)
                      (fr a₂ b₁ b₂ g₂)
                      (fl a₁ a₂ b₁ g₁)).

  Definition gquot_double_rec' : gquot G₁ → gquot G₂ → Y.
  Proof.
    intros x y.
    simple refine (gquot_rec _ _ _ _ _ x).
    - refine (λ a, gquot_rec Y (f a) (fr a) (fre a) (frc a) y).
      exact truncY.
    - intros a₁ a₂ g₁ ; simpl.
      simple refine (gquot_ind_set (λ z, _) _ _ _ y).
      + exact (λ b, fl a₁ a₂ b g₁).
      + intros b₁ b₂ g₂.
        apply map_PathOver.
        refine (whisker_square (idpath _) _ _ (idpath _) _).
        * symmetry.
          apply gquot_rec_beta_gcleq.
        * symmetry.
          apply gquot_rec_beta_gcleq.
        * exact (fp a₁ a₂ b₁ b₂ g₁ g₂).
      + intro.
        exact (truncY _ _).
    - abstract
        (intros a ;
         simple refine (gquot_ind_prop (λ z, _) _ _ y) ;
         [ exact (λ b, fle a b)
         | exact (λ _, truncY _ _ _ _)]).
    - abstract
        (intros a₁ a₂ a₃ g ;
         simple refine (gquot_ind_prop (λ z, _) _ _ y) ;
         [ exact (λ b, flc a₁ a₂ a₃ b g)
         | intro ;
           use impred ; intro ;
           exact (truncY _ _ _ _)]).
    - exact truncY.
  Defined.

  Definition gquot_double_rec'_beta_l_gcleq
             {a₁ a₂ : G₁} (b : G₂)
             (g : a₁ --> a₂)
    : maponpaths (λ z, gquot_double_rec' z (gcl G₂ b)) (gcleq G₁ g)
      =
      fl a₁ a₂ b g.
  Proof.
    apply gquot_rec_beta_gcleq.
  Qed.

  Definition gquot_double_rec'_beta_r_gcleq
             (a : G₁) {b₁ b₂ : G₂}
             (g : b₁ --> b₂)
    : maponpaths (gquot_double_rec' (gcl G₁ a)) (gcleq G₂ g)
      =
      fr a b₁ b₂ g.
  Proof.
    apply (gquot_rec_beta_gcleq G₂).
  Qed.

  Definition gquot_double_rec : gquot G₁ × gquot G₂ → Y
    := uncurry gquot_double_rec'.

  Definition gquot_double_rec_point (a : G₁) (b : G₂)
    : gquot_double_rec (gcl G₁ a ,, gcl G₂ b) = f a b
    := idpath _.

  Definition gquot_double_rec_beta_gcleq
             {a₁ a₂ : G₁} {b₁ b₂ : G₂}
             (g₁ : a₁ --> a₂) (g₂ : b₁ --> b₂)
    : maponpaths gquot_double_rec (pathsdirprod (gcleq G₁ g₁) (gcleq G₂ g₂))
      =
      fl a₁ a₂ b₁ g₁ @ fr a₂ b₁ b₂ g₂.
  Proof.
    refine (uncurry_ap _ _ _ @ _).
    refine (maponpaths (λ z, z @ _) (gquot_rec_beta_gcleq G₁ _ _ _ _ _ _ _ _ _) @ _).
    exact (maponpaths (λ z, _ @ z) (gquot_rec_beta_gcleq G₂ _ _ _ _ _ _ _ _ _)).
  Qed.

  Definition gquot_double_rec_beta_l_gcleq
             {a₁ a₂ : G₁} (b : G₂)
             (g : a₁ --> a₂)
    : maponpaths gquot_double_rec (pathsdirprod (gcleq G₁ g) (idpath (gcl G₂ b)))
      =
      fl a₁ a₂ b g.
  Proof.
    refine (uncurry_ap _ _ _ @ _).
    refine (maponpaths (λ z, z @ _) (gquot_rec_beta_gcleq G₁ _ _ _ _ _ _ _ _ _) @ _).
    apply pathscomp0rid.
  Qed.

  Definition gquot_double_rec_beta_r_gcleq
             (a : G₁) {b₁ b₂ : G₂}
             (g : b₁ --> b₂)
    : maponpaths gquot_double_rec (pathsdirprod (idpath (gcl G₁ a)) (gcleq G₂ g))
      =
      fr a b₁ b₂ g.
  Proof.
    refine (uncurry_ap _ _ _ @ _).
    exact (maponpaths (λ z, _ @ z) (gquot_rec_beta_gcleq G₂ _ _ _ _ _ _ _ _ _)).
  Qed.
End gquot_double_rec.

Arguments gquot_double_rec {G₁ G₂} Y {_ _}.
Arguments gquot_double_rec' {G₁ G₂} Y {_ _}.
Arguments gquot_double_rec_beta_gcleq {G₁ G₂} Y {_ _}.

(** Double induction over a family of sets.
    We use the same trick as for double recursion.
 *)
Section gquot_double_ind_set.
  Variable (G₁ G₂ : groupoid)
           (Y : gquot G₁ → gquot G₂ → UU)
           (Yisaset : ∏ (a : gquot G₁) (b : gquot G₂), isaset (Y a b)).

  Variable (f : ∏ (a : G₁) (b : G₂), Y (gcl G₁ a) (gcl G₂ b))
           (fr : ∏ (a : G₁) (b₁ b₂ : G₂) (g : b₁ --> b₂),
                 PathOver (gcleq G₂ g) (f a b₁) (f a b₂))
           (fl : ∏ (a₁ a₂ : G₁) (b : G₂) (g : a₁ --> a₂),
                 @PathOver
                   _ _ _
                   (gcleq G₁ g)
                   (λ z : gquot G₁, Y z (gcl G₂ b))
                   (f a₁ b)
                   (f a₂ b)).

  Definition gquot_double_ind_set : ∏ (a : gquot G₁) (b : gquot G₂), Y a b.
  Proof.
    intros a b.
    revert a.
    use gquot_ind_set.
    - intro a.
      revert b.
      use gquot_ind_set.
      + exact (f a).
      + exact (fr a).
      + intro ; apply Yisaset.
    - abstract
        (intros a₁ a₂ g ;
         revert b ;
         use gquot_ind_prop ;
         [ exact (λ b, fl a₁ a₂ b g)
         | intro ;
           apply PathOver_hprop ;
           intro ;
           apply Yisaset]).
    - intro x.
      apply Yisaset.
  Defined.
End gquot_double_ind_set.

Arguments gquot_double_ind_set {G₁ G₂} Y {_ _}.

(** Double induction over a family of propositions.
    We use the same trick as before.
 *)
Section gquot_double_ind_prop.
  Variable (G₁ G₂ : groupoid)
           (Y : gquot G₁ → gquot G₂ → UU)
           (Yisaprop : ∏ (a : gquot G₁) (b : gquot G₂), isaprop (Y a b)).

  Variable (f : ∏ (a : G₁) (b : G₂), Y (gcl G₁ a) (gcl G₂ b)).

  Definition gquot_double_ind_prop : ∏ (a : gquot G₁) (b : gquot G₂), Y a b.
  Proof.
    intros x y.
    simple refine (gquot_ind_prop (λ z, _) _ _ x).
    + simple refine (λ a, gquot_ind_prop (λ z, _) (f a) _ y).
      intro ; simpl.
      apply Yisaprop.
    + intro ; simpl.
      apply Yisaprop.
  Defined.
End gquot_double_ind_prop.

Arguments gquot_double_ind_prop {G₁ G₂} Y.

(** A special instance of double recursion for defining set-relations.
    This requires univalence, because we need to give equalities in [hSet].
    These equalities are made with [path_hset] and two functions need to be given.
    For the higher coherencies, these functions need to satisfy some laws.
 *)
Section gquot_relation.
  Variable (G₁ G₂ : groupoid)
           (R : G₁ → G₂ → hSet)
           (fl : ∏ (a₁ a₂ : G₁) (b : G₂), a₁ --> a₂ → R a₁ b → R a₂ b)
           (fr : ∏ (a : G₁) (b₁ b₂ : G₂), b₁ --> b₂ → R a b₁ → R a b₂).
  Variable (fl_isweq : ∏ (a₁ a₂ : G₁) (b : G₂) (g : a₁ --> a₂), isweq (fl a₁ a₂ b g))
           (fr_isweq : ∏ (a : G₁) (b₁ b₂ : G₂) (g : b₁ --> b₂), isweq (fr a b₁ b₂ g)).

  Variable (fl_id : ∏ (a : G₁) (b : G₂), homot (fl a a b (identity a)) (λ z, z))
           (fl_comp : ∏ (a₁ a₂ a₃ : G₁) (b : G₂)
                        (g₁ : a₁ --> a₂) (g₂ : a₂ --> a₃),
                      homot
                        (fl a₁ a₃ b (g₁ · g₂))
                        (fl a₂ a₃ b g₂ ∘ (fl a₁ a₂ b g₁))%functions)
           (fr_id : ∏ (a : G₁) (b : G₂), homot (fr a b b (identity b)) (λ z, z))
           (fr_comp : ∏ (a : G₁) (b₁ b₂ b₃ : G₂)
                        (g₁ : b₁ --> b₂) (g₂ : b₂ --> b₃),
                      homot
                        (fr a b₁ b₃ (g₁ · g₂))
                        (fr a b₂ b₃ g₂ ∘ (fr a b₁ b₂ g₁))%functions)
           (fc : ∏ (a₁ a₂ : G₁) (b₁ b₂ : G₂)
                   (g₁ : a₁ --> a₂) (g₂ : b₁ --> b₂),
                 (homot
                   (fl a₁ a₂ b₂ g₁ ∘ fr a₁ b₁ b₂ g₂)
                   (fr a₂ b₁ b₂ g₂ ∘ fl a₁ a₂ b₁ g₁))%functions
           ).

  Definition fl_weq
    : ∏ (a₁ a₂ : G₁) (b : G₂), a₁ --> a₂ → R a₁ b ≃ R a₂ b.
  Proof.
    intros a₁ a₂ b g.
    use make_weq.
    - exact (fl a₁ a₂ b g).
    - exact (fl_isweq a₁ a₂ b g).
  Defined.

  Definition fr_weq
    : ∏ (a : G₁) (b₁ b₂ : G₂), b₁ --> b₂ → R a b₁ ≃ R a b₂.
  Proof.
    intros a b₁ b₂ g.
    use make_weq.
    - exact (fr a b₁ b₂ g).
    - exact (fr_isweq a b₁ b₂ g).
  Defined.

  Definition path_hset_fl_refl
             (a : G₁) (b : G₂)
    : @path_HLevel 2 _ _ (fl_weq a a b (identity a)) = idpath _.
  Proof.
    rewrite <- path_HLevel_id.
    apply path_HLevel_eq.
    apply fl_id.
  Qed.

  Definition path_hset_fl_trans
             (a₁ a₂ a₃ : G₁) (b : G₂)
             (g₁ : a₂ --> a₃) (g₂ : a₁ --> a₂)
    : @path_HLevel 2 _ _ (fl_weq a₁ a₃ b (g₂ · g₁))
      =
      (@path_HLevel 2 _ _ (fl_weq a₁ a₂ b g₂))
        @
        @path_HLevel 2 _ _ (fl_weq a₂ a₃ b g₁).
  Proof.
    rewrite <- path_HLevel_comp.
    apply path_HLevel_eq.
    apply fl_comp.
  Qed.

  Definition path_hset_fr_refl
             (a : G₁) (b : G₂)
    : @path_HLevel 2 _ _ (fr_weq a b b (identity b)) = idpath _.
  Proof.
    rewrite <- path_HLevel_id.
    apply path_HLevel_eq.
    apply fr_id.
  Qed.

  Definition path_hset_fr_trans
             (a : G₁) (b₁ b₂ b₃ : G₂)
             (g₁ : b₂ --> b₃) (g₂ : b₁ --> b₂)
    : @path_HLevel 2 _ _ (fr_weq a b₁ b₃ (g₂ · g₁))
      =
      (@path_HLevel 2 _ _ (fr_weq a b₁ b₂ g₂))
        @
        @path_HLevel 2 _ _ (fr_weq a b₂ b₃ g₁).
  Proof.
    rewrite <- path_HLevel_comp.
    apply path_HLevel_eq.
    apply fr_comp.
  Qed.

  Definition path_hset_fl_fr
             (a₁ a₂ : G₁) (b₁ b₂ : G₂)
             (g₁ : a₁ --> a₂)
             (g₂ : b₁ --> b₂)
    : (@path_HLevel 2 _ _ (fr_weq a₁ b₁ b₂ g₂))
        @
        @path_HLevel 2 _ _ (fl_weq a₁ a₂ b₂ g₁)
      =
      (@path_HLevel 2 _ _ (fl_weq a₁ a₂ b₁ g₁))
        @
        @path_HLevel 2 _ _ (fr_weq a₂ b₁ b₂ g₂).
  Proof.
    refine (!(path_HLevel_comp _ _) @ _ @ path_HLevel_comp _ _).
    apply path_HLevel_eq ; cbn.
    apply fc.
  Qed.

  Definition gquot_relation : gquot G₁ → gquot G₂ → hSet.
  Proof.
    simple refine (gquot_double_rec' _ _ _ _ _ _ _ _).
    - apply isofhlevel_HLevel.
    - exact R.
    - exact (λ a b₁ b₂ g, @path_HLevel 2 _ _ (fr_weq a b₁ b₂ g)).
    - exact path_hset_fr_refl.
    - intros.
      apply path_hset_fr_trans.
    - exact (λ a₁ a₂ b g, @ path_HLevel 2 _ _ (fl_weq a₁ a₂ b g)).
    - exact path_hset_fl_refl.
    - intros.
      apply path_hset_fl_trans.
    - intros a₁ a₂ b₁ b₂ g₁ g₂.
      apply path_hset_fl_fr.
  Defined.

  Definition gquot_relation_gcl_gcl (a : G₁) (b : G₂)
    : gquot_relation (gcl G₁ a) (gcl G₂ b) = R a b
    := idpath _.

  Definition gquot_relation_beta_l_gcleq
             {a₁ a₂ : G₁} (b : G₂) (g : a₁ --> a₂)
    : maponpaths (λ z, gquot_relation z (gcl G₂ b)) (gcleq G₁ g)
      =
      @path_HLevel 2 _ _ (fl_weq a₁ a₂ b g).
  Proof.
    exact (gquot_double_rec'_beta_l_gcleq G₁ G₂ hSet _ R _ _ _ _ _ _ _ b g).
  Qed.

  Definition gquot_relation_beta_r_gcleq
             (a : G₁) {b₁ b₂ : G₂} (g : b₁ --> b₂)
    : maponpaths (gquot_relation (gcl G₁ a)) (gcleq G₂ g)
      =
      @path_HLevel 2 _ _ (fr_weq a b₁ b₂ g).
  Proof.
    exact (gquot_double_rec'_beta_r_gcleq G₁ G₂ hSet _ R _ _ _ _ _ _ _ a g).
  Qed.
End gquot_relation.


Section LOCAL_WITNESS.

Load witness_prop.

Variable n : nat.

Record component : Set := mk_component {
  is_s  : bool;
  i     : (set n);
  E_i   : (set n) -> nat
}.

Variable dist : set n -> nat.

Definition local_start_prop (c : component) : Prop :=
  dist c.(i) = 0.

Definition local_trian_prop (c : component) : Prop :=
  forall j, c.(E_i) j > 0 -> dist c.(i) <= dist j + c.(E_i) j.

Definition local_justf_prop (c : component) : Prop :=
  exists j, c.(E_i) j > 0 /\ dist c.(i) = dist j + c.(E_i) j.

Definition local_wtnss_prop (c : component) : Prop :=
  (c.(is_s) = true -> local_start_prop c /\ local_trian_prop c) /\
  (c.(is_s) = false -> local_trian_prop c /\ local_justf_prop c).

Variable start_i :
  (set n).

Variable E_dists : (set n) -> (set n) -> nat.

Definition select (S : set n) : component :=
    {| is_s := (proj1_sig S =? proj1_sig start_i) ; i := S ; E_i := E_dists S |}.

Lemma select_ok : forall i' : set n, (select i').(i) = i'.
Proof.
  intros.
  unfold select.
  assert ((proj1_sig i' = proj1_sig start_i) \/ ~ (proj1_sig i' = proj1_sig start_i)).
  apply classic.
  destruct H.
  apply Nat.eqb_eq in H. rewrite H. simpl. auto.
  apply Nat.eqb_neq in H. rewrite H. simpl. auto.
Qed.

Hypothesis Hstart_component_existence:
  (select start_i).(is_s) = true.
Hypothesis Hstart_component_unique:
  forall c, c <> (select start_i) -> c.(is_s) = false.
Hypothesis Hlw_conjunction : forall (c : set n), local_wtnss_prop (select c).

Definition network_E (i : (set n))(j : (set n)) : nat :=
  (select j).(E_i) i.

Definition network_g : graph := mk_graph n network_E (select start_i).(i).

Lemma global_start_prop : dist network_g.(s) = 0.
Proof.
  assert (A : local_wtnss_prop (select start_i)).
  apply Hlw_conjunction.
  unfold local_wtnss_prop in A.
  destruct A as [A _].
  assert (B := Hstart_component_existence).
  apply A in B.
  destruct B as [B _].
  unfold local_start_prop in B.
  assert (D : network_g.(s) = (select start_i).(i)).
  auto.
  rewrite D.
  auto.
Qed.

Lemma global_trian_prop : forall u v,
  network_g.(E) u v > 0 -> dist v <= dist u + network_g.(E) u v.
Proof.
  intros.
  assert (A : local_wtnss_prop (select v)).
  apply Hlw_conjunction.
  unfold local_wtnss_prop in A.
  destruct (classic (is_s (select v) = true)) as [B|B].
  destruct A as [A _].
  apply A in B.
  destruct B as [_ B].
  unfold local_trian_prop in B.
  simpl in H.
  unfold network_E in H.
  apply B in H.
  simpl.
  unfold network_E.
  assert (C : (select v).(i) = v).
  apply select_ok.
  rewrite C in H.
  apply H.
  destruct A as [_ A].
  apply not_true_is_false in B.
  apply A in B.
  destruct B as [B _].
  unfold local_trian_prop in B.
  simpl in H.
  unfold network_E in H.
  apply B in H.
  simpl.
  assert (C : (select v).(i) = v).
  apply select_ok.
  rewrite C in H.
  apply H.
Qed.

Lemma distinct : forall c_i c_j,
  c_i <> c_j -> select c_i <> select c_j.
Proof.
  intros c_i c_j A.
  assert (B : (select c_i).(i) = c_i).
  apply select_ok.
  assert (C : (select c_j).(i) = c_j).
  apply select_ok.
  rewrite <- B in A.
  rewrite <- C in A.
  destruct (classic (select c_i = select c_j)) as [D|D].
  assert (E : (select c_i).(i) = (select c_j).(i)).
  f_equal.
  apply D.
  tauto.
  apply D.
Qed.

Lemma global_justf_prop : forall v,
  v <> network_g.(s) ->
    exists u, network_g.(E) u v > 0 /\ dist v = dist u + network_g.(E) u v.
Proof.
  intros.
  assert (A : local_wtnss_prop (select v)).
  apply Hlw_conjunction.
  unfold local_wtnss_prop in A.
  destruct A as [_ A].
  assert (B : is_s (select v) = false).
  apply Hstart_component_unique.
  simpl in *.
  apply distinct.
  apply H.
  apply A in B.
  destruct B as [_ B].
  unfold local_justf_prop in B.
  rewrite select_ok in B.
  apply B.
Qed.

Hypothesis Hpath_existence : path_existence network_g.
Definition delta_network_g :=
  proj1_sig (delta_existence network_g Hpath_existence).
Definition delta_network_ok :=
  proj2_sig (delta_existence network_g Hpath_existence).

Theorem dist_eq_network_delta : forall (v : set network_g.(V)),
  dist v = delta_network_g v.
Proof.
  apply dist_eq_delta.
  apply global_start_prop.
  unfold trian_prop.
  apply global_trian_prop.
  unfold justf_prop.
  apply global_justf_prop.
Qed.

Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Peano_dec.
Open Scope nat_scope.

Definition start_check (c : component) :=
  if eq_nat_dec (dist c.(i)) 0 then true else false.

Lemma start_check_ok : forall c,
  local_start_prop c <-> start_check c = true.
Proof.
  intros.
  unfold start_check.
  intros.
  split.
  intros.
  unfold local_start_prop in H.
  destruct eq_nat_dec.
  reflexivity.
  tauto.
  destruct eq_nat_dec.
  intros.
  unfold local_start_prop.
  assumption.
  intros.
  inversion H.
Qed.

End LOCAL_WITNESS.

Extraction start_check.