{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.ZCohomology.Groups.Torus where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.Groups.Connected
open import Cubical.ZCohomology.MayerVietorisUnreduced
open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Sn
open import Cubical.ZCohomology.Groups.Prelims
open import Cubical.ZCohomology.KcompPrelims

open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws

open import Cubical.Data.Sigma
open import Cubical.Data.Int renaming (_+_ to _+ℤ_; +-comm to +ℤ-comm ; +-assoc to +ℤ-assoc)
open import Cubical.Data.Nat
open import Cubical.Data.Unit
open import Cubical.Algebra.Group

open import Cubical.HITs.Pushout
open import Cubical.HITs.S1
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp
open import Cubical.HITs.SetTruncation renaming (rec to sRec ; elim to sElim ; elim2 to sElim2) hiding (map)
open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; elim2 to pElim2 ; ∣_∣ to ∣_∣₁) hiding (map)
open import Cubical.HITs.Nullification
open import Cubical.HITs.Truncation renaming (elim to trElim ; elim2 to trElim2 ; map to trMap ; rec to trRec)

open GroupHom
open GroupIso

private
  module congLemma (key : Unit') where
    module K = lockedCohom key

    main : (n : ℕ) (p : Path (coHomK n) (0ₖ n) (0ₖ n))
              → Path (K.+K n (0ₖ n) (0ₖ n) ≡ K.+K n (0ₖ n) (0ₖ n))
                      (cong (K.+K n (0ₖ n)) p) (cong (λ x → K.+K n x (0ₖ n)) p)
    main n = congIdLeft≡congIdRight (K.+K n) (K.-K n) (0ₖ n) (K.rUnitK n) (K.lUnitK n) (rUnitlUnit0K key n)

--------- H⁰(T²) ------------
H⁰-T²≅ℤ : GroupIso (coHomGr 0 (S₊ 1 × S₊ 1)) intGroup
H⁰-T²≅ℤ =
  H⁰-connected (base , base)
    λ (a , b) → pRec propTruncIsProp
                     (λ id1 → pRec propTruncIsProp
                                   (λ id2 → ∣ ΣPathP (id1 , id2) ∣₁)
                                   (Sn-connected 0 b) )
                     (Sn-connected 0 a)

--------- H¹(T²) -------------------------------

H¹-T²≅ℤ×ℤ : GroupIso (coHomGr 1 ((S₊ 1) × (S₊ 1))) (dirProd intGroup intGroup)
H¹-T²≅ℤ×ℤ = theIso □ dirProdGroupIso (invGroupIso (Hⁿ-Sⁿ≅ℤ 0)) (H⁰-Sⁿ≅ℤ 0)
  where
  helper : (x : hLevelTrunc 3 (S₊ 1)) → ∣ (S¹map x) ∣ ≡ x
  helper = trElim (λ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _)
                  λ a → refl

  typIso : Iso _ _
  typIso = setTruncIso (curryIso ⋄ codomainIso S1→K₁≡S1×Int ⋄ toProdIso)
                      ⋄ setTruncOfProdIso

  theIso : GroupIso _ _
  fun (map theIso) = Iso.fun (typIso)
  isHom (map theIso) =
    sElim2 (λ _ _ → isOfHLevelPath 2 (isOfHLevelΣ 2 setTruncIsSet (λ _ → setTruncIsSet)) _ _)
            λ f g → ΣPathP ((cong ∣_∣₂
                             (funExt (λ x → helper (f (x , base) +ₖ g (x , base))
                                           ∙ sym (cong₂ (λ x y → x +ₖ y)
                                                        (helper (f (x , base)))
                                                        (helper (g (x , base))))))) ,
                           (cong ∣_∣₂
                              (funExt
                                (toPropElim
                                   (λ _ → isSetInt _ _)
                                   (cong winding
                                         (basechange-lemma2
                                           (λ x → f (base , x))
                                           (λ x → g (base , x))
                                           λ x → S¹map x)
                                  ∙∙ winding-hom
                                      (basechange2⁻
                                          (S¹map (f (base , base)))
                                          (λ i → S¹map (f (base , (loop i)))))
                                      (basechange2⁻
                                          (S¹map (g (base , base)))
                                          (λ i → S¹map (g (base , (loop i)))))
                                  ∙∙ sym (addLemma
                                          (winding
                                            (basechange2⁻
                                              (S¹map (f (base , base)))
                                              (λ i → S¹map (f (base , (loop i))))))
                                          (winding
                                            (basechange2⁻
                                              (S¹map  (g (base , base)))
                                              (λ i → S¹map (g (base , (loop i))))))))))))
  inv theIso = Iso.inv typIso
  rightInv theIso = Iso.rightInv typIso
  leftInv theIso = Iso.leftInv typIso

----------------------- H²(T²) ------------------------------
open import Cubical.Foundations.Equiv
H²-T²≅ℤ : GroupIso (coHomGr 2 (S₊ 1 × S₊ 1)) intGroup
H²-T²≅ℤ = invGroupIso (ℤ≅H²-T² unlock)
  where
    module _ (key : Unit') where
      module K = lockedCohom key
      private
        _+K_ : {n : ℕ} → coHomK n → coHomK n → coHomK n
        _+K_ {n = n} = K.+K n

        -K_ : {n : ℕ} → coHomK n → coHomK n
        -K_ {n = n} = K.-K n

        -H_ : {A : Type₀} {n : ℕ} → coHom n A → coHom n A
        -H_ {n = n} = K.-H n

        _+H_ : {A : Type₀} {n : ℕ} → coHom n A → coHom n A → coHom n A
        _+H_ {n = n} = K.+H n

      typIso : Iso _ _
      typIso = helper
            ⋄ (invIso (prodIso (GroupIso→Iso (Hⁿ-S¹≅0 0))
                               (invIso (GroupIso→Iso (Hⁿ-Sⁿ≅ℤ 0))))
            ⋄ ((invIso setTruncOfProdIso)
            ⋄ (invIso (setTruncIso (curryIso
                                  ⋄ codomainIso (S1→K2≡K2×K1' key)
                                  ⋄ toProdIso)))))
        where
        helper : Iso Int (Unit × Int)
        Iso.inv helper = snd
        Iso.fun helper x = tt , x
        Iso.leftInv helper _ = refl
        Iso.rightInv helper _ = refl

      mapIsHom : (x y : Int)
              → Iso.fun typIso (x +ℤ y) ≡ ((Iso.fun typIso x) +H Iso.fun typIso y)
      mapIsHom a b =
          (cong f ((GroupHom.isHom (GroupIso.map (invGroupIso (dirProdGroupIso (Hⁿ-S¹≅0 0) (invGroupIso (Hⁿ-Sⁿ≅ℤ 0)))))
                                                              (_ , a) (_ , b))
                ∙ λ i → guyId i , +H≡+ₕ key _ (~ i) (g a) (g b)))
        ∙∙ helper (g a) (g b)
        ∙∙ cong₂ (_+H_) (λ i → f (guyId2 (~ i) , g a)) λ i → f (guyId2 (~ i) , g b)
        where
        f = Iso.fun (((invIso setTruncOfProdIso ⋄ invIso (setTruncIso (curryIso ⋄ codomainIso (S1→K2≡K2×K1' key) ⋄ toProdIso)))))
        g = GroupIso.inv (invGroupIso (Hⁿ-Sⁿ≅ℤ 0))

        isPropH²-S¹ : isProp (coHom 2 (S₊ 1))
        isPropH²-S¹ = isPropRetract (fun (map (Hⁿ-S¹≅0 0)))
                                    (inv (Hⁿ-S¹≅0 0))
                                    (leftInv (Hⁿ-S¹≅0 0))
                                    isPropUnit

        guyId : ∣ _ ∣₂ ≡ 0ₕ 2
        guyId = isPropH²-S¹ _ _

        guyId2 : ∣ _ ∣₂ ≡ 0ₕ 2
        guyId2 = isPropH²-S¹ _ _

        helper : (x y : ∥ ((S₊ 1) → (hLevelTrunc 3 (S₊ 1) )) ∥₂) →
                  f ((0ₕ 2) , (x +H y)) ≡ f ((0ₕ 2) , x) +H f (0ₕ 2 , y)
        helper =
          sElim2 (λ _ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                 λ f g i → ∣ (λ x → helper2 (f (fst x)) (g (fst x)) (snd x) i) ∣₂
          where
          helper2 : (x y : coHomK 1) (s : S₊ 1)
                 → Iso.inv (S1→K2≡K2×K1' key) (0ₖ 2 , x +K y) s ≡ (Iso.inv (S1→K2≡K2×K1' key) (0ₖ 2 , x)) s +K (Iso.inv (S1→K2≡K2×K1' key) (0ₖ 2 , y)) s
          helper2 =
            trElim2 (λ _ _ → isOfHLevelΠ 3 λ _ → isOfHLevelTrunc 4 _ _)
                    λ a b → λ {base → cong₂ (_+K_) (sym (K.lUnitK _ 0₂)) (sym (K.lUnitK _ 0₂))
                            ; (loop i) j → hcomp (λ k → λ{ (i = i0) → cong₂ (_+K_) (sym (K.lUnitK _ 0₂)) (sym (K.lUnitK _ 0₂)) (j ∧ k)
                                                         ; (i = i1) → cong₂ (_+K_) (sym (K.lUnitK _ 0₂)) (sym (K.lUnitK _ 0₂)) (j ∧ k)
                                                         ; (j = i0) → 0₂ +K (Kn→ΩKn+1 1 (∣ a ∣ +K ∣ b ∣) i)
                                                         ; (j = i1) → cong₂ (_+K_) (sym (K.lUnitK _ (Kn→ΩKn+1 1 ∣ a ∣ i)))
                                                                            (sym (K.lUnitK _ (Kn→ΩKn+1 1 ∣ b ∣ i))) k})
                                               (helper3 ∣ a ∣ ∣ b ∣ j i)}
            where
            helper3 : (a b : coHomK 1) → cong (0₂ +K_) (Kn→ΩKn+1 1 (a +K b)) ≡ cong₂ (_+K_) (Kn→ΩKn+1 1 a) (Kn→ΩKn+1 1 b)
            helper3 a b = cong (cong (0₂ +K_)) (+K→∙ key 1 a b)
                        ∙ (congFunct (0₂ +K_) (Kn→ΩKn+1 1 a) (Kn→ΩKn+1 1 b)
                        ∙∙ (λ i → congLemma.main key 2 (Kn→ΩKn+1 1 a) i ∙ cong (_+K_ ∣ north ∣) (λ i → Kn→ΩKn+1 1 b i))
                        ∙∙ sym (cong₂Funct (_+K_) (Kn→ΩKn+1 1 a) (Kn→ΩKn+1 1 b)))

      ℤ≅H²-T² : GroupIso intGroup (coHomGr 2 (S₊ 1 × S₊ 1))
      fun (map ℤ≅H²-T²) = Iso.fun typIso
      isHom (map ℤ≅H²-T²) = pm key mapIsHom
        where
        pm : (t : Unit')
          → ((x y : Int)
                → Iso.fun typIso (x +ℤ y) ≡ (lockedCohom.+H t _ (Iso.fun typIso x) (Iso.fun typIso y)))
          → isGroupHom intGroup (coHomGr 2 (S₊ 1 × S₊ 1)) (Iso.fun typIso)
        pm unlock p = p
      inv ℤ≅H²-T² = Iso.inv typIso
      rightInv ℤ≅H²-T² = Iso.rightInv typIso
      leftInv ℤ≅H²-T² = Iso.leftInv typIso

private
  to₂ : coHom 2 (S₊ 1 × S₊ 1) → Int
  to₂ = fun (map H²-T²≅ℤ)

  from₂ : Int → coHom 2 (S₊ 1 × S₊ 1)
  from₂ = inv H²-T²≅ℤ

  to₁ : coHom 1 (S₊ 1 × S₊ 1) → Int × Int
  to₁ = fun (map H¹-T²≅ℤ×ℤ)

  from₁ : Int × Int → coHom 1 (S₊ 1 × S₊ 1)
  from₁ = inv H¹-T²≅ℤ×ℤ

  to₀ : coHom 0 (S₊ 1 × S₊ 1) → Int
  to₀ = fun (map H⁰-T²≅ℤ)

  from₀ : Int → coHom 0 (S₊ 1 × S₊ 1)
  from₀ = inv H⁰-T²≅ℤ

{-
-- Compute fast:
test : to₁ (from₁ (0 , 1) +ₕ from₁ (1 , 0)) ≡ (1 , 1)
test = refl

test2 : to₁ (from₁ (5 , 1) +ₕ from₁ (-2 , 3)) ≡ (3 , 4)
test2 = refl

-- Will not compute:

test3 : to₂ (from₂ 0) ≡ 0
test3 = refl

-}


{-# OPTIONS --without-K --allow-unsolved-metas --exact-split #-}

module 22-descent where

import 21-cubical-diagrams
open 21-cubical-diagrams public

-- Section 18.1 Five equivalent characterizations of pushouts

dep-cocone :
  { l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  ( f : S → A) (g : S → B) (c : cocone f g X) (P : X → UU l5) →
  UU (l1 ⊔ l2 ⊔ l3 ⊔ l5)
dep-cocone {S = S} {A} {B} f g c P =
  Σ ((a : A) → P ((pr1 c) a)) (λ hA →
    Σ ((b : B) → P (pr1 (pr2 c) b)) (λ hB →
      (s : S) → Id (tr P (pr2 (pr2 c) s) (hA (f s))) (hB (g s))))

dep-cocone-map :
  { l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  ( f : S → A) (g : S → B) (c : cocone f g X) (P : X → UU l5) →
  ( (x : X) → P x) → dep-cocone f g c P
dep-cocone-map f g c P h =
  pair (λ a → h (pr1 c a)) (pair (λ b → h (pr1 (pr2 c) b)) (λ s → apd h (pr2 (pr2 c) s)))

{- Definition 18.1.1 The induction principle of pushouts -}

Ind-pushout :
  { l1 l2 l3 l4 : Level} (l : Level) →
  { S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4} →
  ( f : S → A) (g : S → B) (c : cocone f g X) → UU (lsuc l ⊔ l1 ⊔ l2 ⊔ l3 ⊔ l4)
Ind-pushout l {X = X} f g c =
  (P : X → UU l) → sec (dep-cocone-map f g c P)

{- Definition 18.1.2 The dependent universal property of pushouts -}

dependent-universal-property-pushout :
  {l1 l2 l3 l4 : Level} (l : Level) {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) → UU _
dependent-universal-property-pushout l f g {X} c =
  (P : X → UU l) → is-equiv (dep-cocone-map f g c P)

{- Remark 18.1.3. We compute the identity type of dep-cocone in order to
   express the computation rules of the induction principle for pushouts. -}

coherence-htpy-dep-cocone :
  {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X)
  (P : X → UU l5) (c' c'' : dep-cocone f g c P)
  (K : (pr1 c') ~ (pr1 c'')) (L : (pr1 (pr2 c')) ~ (pr1 (pr2 c''))) →
  UU (l1 ⊔ l5)
coherence-htpy-dep-cocone {S = S} f g c P
  h h' K L =
  (s : S) →
  Id ( ((pr2 (pr2 h)) s) ∙ (L (g s)))
     ( (ap (tr P (pr2 (pr2 c) s)) (K (f s))) ∙ ((pr2 (pr2 h')) s))

htpy-dep-cocone :
  {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) (P : X → UU l5) →
  (s t : dep-cocone f g c P) → UU (l1 ⊔ (l2 ⊔ (l3 ⊔ l5)))
htpy-dep-cocone {S = S} f g c P h h' =
  Σ ( (pr1 h) ~ (pr1 h')) (λ K →
    Σ ( (pr1 (pr2 h)) ~ (pr1 (pr2 h')))
      ( coherence-htpy-dep-cocone f g c P h h' K))

reflexive-htpy-dep-cocone :
  {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) (P : X → UU l5) →
  (s : dep-cocone f g c P) →
  htpy-dep-cocone f g c P s s
reflexive-htpy-dep-cocone f g (pair i (pair j H)) P
  (pair hA (pair hB hS)) =
  pair htpy-refl (pair htpy-refl htpy-right-unit)

htpy-dep-cocone-eq :
  {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) (P : X → UU l5) →
  {s t : dep-cocone f g c P} →
  Id s t → htpy-dep-cocone f g c P s t
htpy-dep-cocone-eq f g c P {s} {.s} refl =
  reflexive-htpy-dep-cocone f g c P s

abstract
  is-contr-total-htpy-dep-cocone :
    {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
    (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) (P : X → UU l5) →
    (s : dep-cocone f g c P) →
    is-contr
      ( Σ (dep-cocone f g c P)
        ( htpy-dep-cocone f g c P s))
  is-contr-total-htpy-dep-cocone
    {S = S} {A} {B} f g {X} (pair i (pair j H)) P (pair hA (pair hB hS)) =
    is-contr-total-Eq-structure
      ( λ α βγ K →
          Σ (hB ~ (pr1 βγ)) (λ L →
          coherence-htpy-dep-cocone f g
            ( pair i (pair j H)) P (pair hA (pair hB hS)) (pair α βγ) K L))
      ( is-contr-total-htpy hA)
      ( pair hA htpy-refl)
      ( is-contr-total-Eq-structure
        ( λ β γ L →
          coherence-htpy-dep-cocone f g
            ( pair i (pair j H))
            ( P)
            ( pair hA (pair hB hS))
            ( pair hA (pair β γ))
            ( htpy-refl)
            ( L))
        ( is-contr-total-htpy hB)
        ( pair hB htpy-refl)
        ( is-contr-is-equiv
          ( Σ ((s : S) → Id (tr P (H s) (hA (f s))) (hB (g s))) (λ γ → hS ~ γ))
          ( tot (htpy-concat (htpy-inv htpy-right-unit)))
          ( is-equiv-tot-is-fiberwise-equiv
            ( is-equiv-htpy-concat (htpy-inv htpy-right-unit)))
          ( is-contr-total-htpy hS)))

abstract
  is-equiv-htpy-dep-cocone-eq :
    {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
    (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) (P : X → UU l5) →
    (s t : dep-cocone f g c P) → is-equiv (htpy-dep-cocone-eq f g c P {s} {t})
  is-equiv-htpy-dep-cocone-eq f g c P s =
    fundamental-theorem-id s
      ( reflexive-htpy-dep-cocone f g c P s)
      ( is-contr-total-htpy-dep-cocone f g c P s)
      ( λ t → htpy-dep-cocone-eq f g c P {s} {t})

  eq-htpy-dep-cocone :
    {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
    (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) (P : X → UU l5) →
    (s t : dep-cocone f g c P) →
      htpy-dep-cocone f g c P s t → Id s t
  eq-htpy-dep-cocone f g c P s t =
    inv-is-equiv (is-equiv-htpy-dep-cocone-eq f g c P s t)

  issec-eq-htpy-dep-cocone :
    {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
      (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) (P : X → UU l5) →
    (s t : dep-cocone f g c P) →
    ( ( htpy-dep-cocone-eq f g c P {s} {t}) ∘
      ( eq-htpy-dep-cocone f g c P s t)) ~ id
  issec-eq-htpy-dep-cocone f g c P s t =
    issec-inv-is-equiv
    ( is-equiv-htpy-dep-cocone-eq f g c P s t)

  isretr-eq-htpy-dep-cocone :
    {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
    (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) (P : X → UU l5) →
    (s t : dep-cocone f g c P) →
    ( ( eq-htpy-dep-cocone f g c P s t) ∘
      ( htpy-dep-cocone-eq f g c P {s} {t})) ~ id
  isretr-eq-htpy-dep-cocone f g c P s t =
    isretr-inv-is-equiv
      ( is-equiv-htpy-dep-cocone-eq f g c P s t)

ind-pushout :
  { l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4} →
  ( f : S → A) (g : S → B) (c : cocone f g X) →
  Ind-pushout l f g c → (P : X → UU l) →
  dep-cocone f g c P → (x : X) → P x
ind-pushout f g c ind-c P =
  pr1 (ind-c P)

comp-pushout :
  { l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4} →
  ( f : S → A) (g : S → B) (c : cocone f g X) →
  ( ind-c : Ind-pushout l f g c) (P : X → UU l) (h : dep-cocone f g c P) →
  htpy-dep-cocone f g c P
    ( dep-cocone-map f g c P (ind-pushout f g c ind-c P h))
    ( h)
comp-pushout f g c ind-c P h =
  htpy-dep-cocone-eq f g c P (pr2 (ind-c P) h)

left-comp-pushout :
  { l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4} →
  ( f : S → A) (g : S → B) (c : cocone f g X) →
  ( ind-c : Ind-pushout l f g c) (P : X → UU l) (h : dep-cocone f g c P) →
  ( a : A) → Id (ind-pushout f g c ind-c P h (pr1 c a)) (pr1 h a)
left-comp-pushout f g c ind-c P h =
  pr1 (comp-pushout f g c ind-c P h)

right-comp-pushout :
  { l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4} →
  ( f : S → A) (g : S → B) (c : cocone f g X) →
  ( ind-c : Ind-pushout l f g c) (P : X → UU l) (h : dep-cocone f g c P) →
  ( b : B) → Id (ind-pushout f g c ind-c P h (pr1 (pr2 c) b)) (pr1 (pr2 h) b)
right-comp-pushout f g c ind-c P h =
  pr1 (pr2 (comp-pushout f g c ind-c P h))

path-comp-pushout :
  { l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4} →
  ( f : S → A) (g : S → B) (c : cocone f g X) →
  ( ind-c : Ind-pushout l f g c) (P : X → UU l) (h : dep-cocone f g c P) →
  coherence-htpy-dep-cocone f g c P
    ( dep-cocone-map f g c P (ind-pushout f g c ind-c P h))
    ( h)
    ( left-comp-pushout f g c ind-c P h)
    ( right-comp-pushout f g c ind-c P h)
path-comp-pushout f g c ind-c P h =
  pr2 (pr2 (comp-pushout f g c ind-c P h))

abstract
  uniqueness-dependent-universal-property-pushout :
    { l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4} →
    ( f : S → A) (g : S → B) (c : cocone f g X)
    ( dup-c : dependent-universal-property-pushout l f g c) →
    ( P : X → UU l) ( h : dep-cocone f g c P) →
    is-contr
      ( Σ ((x : X) → P x) (λ k →
          htpy-dep-cocone f g c P (dep-cocone-map f g c P k) h))
  uniqueness-dependent-universal-property-pushout f g c dup-c P h =
    is-contr-is-equiv'
      ( fib (dep-cocone-map f g c P) h)
      ( tot (λ k → htpy-dep-cocone-eq f g c P))
      ( is-equiv-tot-is-fiberwise-equiv
        ( λ k → is-equiv-htpy-dep-cocone-eq f g c P
          ( dep-cocone-map f g c P k) h))
      ( is-contr-map-is-equiv (dup-c P) h)

{- This finishes the formalization of remark 18.1.3. -}

{- Before we state the main theorem of this section, we also state a dependent
   version of the pullback property of pushouts. -}

cone-dependent-pullback-property-pushout :
  {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) (P : X → UU l5) →
  let i = pr1 c
      j = pr1 (pr2 c)
      H = pr2 (pr2 c)
  in
  cone
    ( λ (h : (a : A) → P (i a)) → λ (s : S) → tr P (H s) (h (f s)))
    ( λ (h : (b : B) → P (j b)) → λ s → h (g s))
    ( (x : X) → P x)
cone-dependent-pullback-property-pushout f g (pair i (pair j H)) P =
  pair
    ( λ h → λ a → h (i a))
    ( pair
      ( λ h → λ b → h (j b))
      ( λ h → eq-htpy (λ s → apd h (H s))))

dependent-pullback-property-pushout :
  {l1 l2 l3 l4 : Level} (l : Level) {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  UU (l1 ⊔ (l2 ⊔ (l3 ⊔ (l4 ⊔ lsuc l))))
dependent-pullback-property-pushout l {S} {A} {B} f g {X}
  (pair i (pair j H)) =
  (P : X → UU l) →
  is-pullback
    ( λ (h : (a : A) → P (i a)) → λ s → tr P (H s) (h (f s)))
    ( λ (h : (b : B) → P (j b)) → λ s → h (g s))
    ( cone-dependent-pullback-property-pushout f g (pair i (pair j H)) P)

{- Theorem 18.1.4 The following properties are all equivalent:

   1. universal-property-pushout
   2. pullback-property-pushout
   3. dependent-pullback-property-pushout
   4. dependent-universal-property-pushout
   5. Ind-pushout

   We have already shown that 1 ↔ 2. Therefore we will first show that
   3 ↔ 4 ↔ 5. Finally, we will show that 2 ↔ 3. Here are the precise references
   to the proofs of those parts:

   Proof of 1 → 2.
   pullback-property-pushout-universal-property-pushout

   Proof of 2 → 1
   universal-property-pushout-pullback-property-pushout

   Proof of 2 → 3
   dependent-pullback-property-pullback-property-pushout

   Proof of 3 → 2
   pullback-property-dependent-pullback-property-pushout

   Proof of 3 → 4
   dependent-universal-property-dependent-pullback-property-pushout

   Proof of 4 → 3
   dependent-pullback-property-dependent-universal-property-pushout

   Proof of 4 → 5
   Ind-pushout-dependent-universal-property-pushout

   Proof of 5 → 4
   dependent-universal-property-pushout-Ind-pushout
   -}

{- Proof of Theorem 18.1.4, (v) implies (iv). -}

dependent-naturality-square :
  {l1 l2 : Level} {A : UU l1} {B : A → UU l2} (f f' : (x : A) → B x)
  {x x' : A} (p : Id x x') {q : Id (f x) (f' x)} {q' : Id (f x') (f' x')} →
  Id ((apd f p) ∙ q') ((ap (tr B p) q) ∙ (apd f' p)) →
  Id (tr (λ y → Id (f y) (f' y)) p q) q'
dependent-naturality-square f f' refl {q} {q'} s =
  inv (s ∙ (right-unit ∙ (ap-id q)))

htpy-eq-dep-cocone-map :
  { l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  ( f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  ( H : Ind-pushout l f g c) { P : X → UU l} (h h' : (x : X) → P x) →
  Id (dep-cocone-map f g c P h) (dep-cocone-map f g c P h') → h ~ h'
htpy-eq-dep-cocone-map f g c ind-c {P} h h' p =
  ind-pushout f g c ind-c
    ( λ x → Id (h x) (h' x))
    ( pair
      ( pr1 (htpy-dep-cocone-eq f g c P p))
      ( pair
        ( pr1 (pr2 (htpy-dep-cocone-eq f g c P p)))
        ( λ s →
          dependent-naturality-square h h' (pr2 (pr2 c) s)
            ( pr2 (pr2 (htpy-dep-cocone-eq f g c P p)) s))))

dependent-universal-property-pushout-Ind-pushout :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  ((l : Level) → Ind-pushout l f g c) →
  ((l : Level) → dependent-universal-property-pushout l f g c)
dependent-universal-property-pushout-Ind-pushout f g c ind-c l P =
  is-equiv-has-inverse
    ( ind-pushout f g c (ind-c l) P)
    ( pr2 (ind-c l P))
    ( λ h → eq-htpy (htpy-eq-dep-cocone-map f g c (ind-c l)
      ( ind-pushout f g c (ind-c l) P (dep-cocone-map f g c P h))
      ( h)
      ( pr2 (ind-c l P) (dep-cocone-map f g c P h))))

{- Proof of Theorem 18.1.4, (iv) implies (v). -}

Ind-pushout-dependent-universal-property-pushout :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  ((l : Level) → dependent-universal-property-pushout l f g c) →
  ((l : Level) → Ind-pushout l f g c)
Ind-pushout-dependent-universal-property-pushout f g c dup-c l P =
  pr1 (dup-c l P)

{- Proof of Theorem 18.1.4, (iv) implies (iii). -}

triangle-dependent-pullback-property-pushout :
  {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) (P : X → UU l5) →
  let i = pr1 c
      j = pr1 (pr2 c)
      H = pr2 (pr2 c)
  in
  ( dep-cocone-map f g c P) ~
  ( ( tot (λ h → tot (λ h' → htpy-eq))) ∘
    ( gap
      ( λ (h : (a : A) → P (i a)) → λ s → tr P (H s) (h (f s)))
      ( λ (h : (b : B) → P (j b)) → λ s → h (g s))
      ( cone-dependent-pullback-property-pushout f g c P)))
triangle-dependent-pullback-property-pushout f g (pair i (pair j H)) P h =
  eq-pair refl (eq-pair refl (inv (issec-eq-htpy (λ x → apd h (H x)))))

dependent-pullback-property-dependent-universal-property-pushout :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  ((l : Level) → dependent-universal-property-pushout l f g c) →
  ((l : Level) → dependent-pullback-property-pushout l f g c)
dependent-pullback-property-dependent-universal-property-pushout
  f g (pair i (pair j H)) I l P =
  let c = (pair i (pair j H)) in
  is-equiv-right-factor
    ( dep-cocone-map f g c P)
    ( tot (λ h → tot λ h' → htpy-eq))
    ( gap
      ( λ h x → tr P (H x) (h (f x)))
      ( λ h x → h (g x))
      ( cone-dependent-pullback-property-pushout f g c P))
    ( triangle-dependent-pullback-property-pushout f g c P)
    ( is-equiv-tot-is-fiberwise-equiv
      ( λ h → is-equiv-tot-is-fiberwise-equiv
        ( λ h' → funext (λ x → tr P (H x) (h (f x))) (λ x → h' (g x)))))
    ( I l P)

{- Proof of Theorem 18.1.4, (iv) implies (iii). -}

dependent-universal-property-dependent-pullback-property-pushout :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  ((l : Level) → dependent-pullback-property-pushout l f g c) →
  ((l : Level) → dependent-universal-property-pushout l f g c)
dependent-universal-property-dependent-pullback-property-pushout
  f g (pair i (pair j H)) dpullback-c l P =
  let c = (pair i (pair j H)) in
  is-equiv-comp
    ( dep-cocone-map f g c P)
    ( tot (λ h → tot λ h' → htpy-eq))
    ( gap
      ( λ h x → tr P (H x) (h (f x)))
      ( λ h x → h (g x))
      ( cone-dependent-pullback-property-pushout f g c P))
    ( triangle-dependent-pullback-property-pushout f g c P)
    ( dpullback-c l P)
    ( is-equiv-tot-is-fiberwise-equiv
      ( λ h → is-equiv-tot-is-fiberwise-equiv
        ( λ h' → funext (λ x → tr P (H x) (h (f x))) (λ x → h' (g x)))))

{- Proof of Theorem 18.1.4, (iii) implies (ii). -}

concat-eq-htpy :
  {l1 l2 : Level} {A : UU l1} {B : A → UU l2} {f g h : (x : A) → B x}
  (H : f ~ g) (K : g ~ h) → Id (eq-htpy (H ∙h K)) ((eq-htpy H) ∙ (eq-htpy K))
concat-eq-htpy {A = A} {B} {f} H K =
  ind-htpy f
    ( λ g H →
      ( h : (x : A) → B x) (K : g ~ h) →
      Id (eq-htpy (H ∙h K)) ((eq-htpy H) ∙ (eq-htpy K)))
    ( λ h K → ap (concat' f (eq-htpy K)) (inv (eq-htpy-htpy-refl _))) H _ K

pullback-property-dependent-pullback-property-pushout :
  {l1 l2 l3 l4 : Level} (l : Level) {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  dependent-pullback-property-pushout l f g c →
  pullback-property-pushout l f g c
pullback-property-dependent-pullback-property-pushout
  l f g (pair i (pair j H)) dpb Y =
  is-pullback-htpy
    ( λ h s → tr (λ x → Y) (H s) (h (f s)))
    ( λ h → eq-htpy (λ s → inv (tr-triv (H s) (h (f s)))))
    ( λ h s → h (g s))
    ( htpy-refl)
    { c = pair
      ( λ h a → h (i a))
      ( pair (λ h b → h (j b)) (λ h → eq-htpy (h ·l H)))}
    ( cone-dependent-pullback-property-pushout
      f g (pair i (pair j H)) (λ x → Y))
    ( pair
      ( λ h → refl)
      ( pair
        ( λ h → refl)
        ( λ h → right-unit ∙
          ( ( ap eq-htpy
              ( eq-htpy (λ s →
                inv-con
                  ( tr-triv (H s) (h (i (f s))))
                  ( ap h (H s))
                  ( apd h (H s))
                  ( inv (apd-triv h (H s)))))) ∙
            ( concat-eq-htpy
              ( λ s → inv (tr-triv (H s) (h (i (f s)))))
              ( λ s → apd h (H s)))))))
    ( dpb (λ x → Y))

{- Proof of Theorem 18.1.4, (ii) implies (iii). -}

{- We first define the family of lifts, which is indexed by maps Y → X. -}

fam-lifts :
  {l1 l2 l3 : Level} (Y : UU l1) {X : UU l2} (P : X → UU l3) →
  (Y → X) → UU (l1 ⊔ l3)
fam-lifts Y P h = (y : Y) → P (h y)

tr-fam-lifts' :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4) →
  (h : B → X) {f g : A → B} (H : f ~ g) →
  fam-lifts A P (h ∘ f) → fam-lifts A P (h ∘ g)
tr-fam-lifts' P h {f} {g} H k s = tr (P ∘ h) (H s) (k s)

TR-EQ-HTPY-FAM-LIFTS :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4) →
  (h : B → X) {f g : A → B} (H : f ~ g) → UU (l1 ⊔ l4)
TR-EQ-HTPY-FAM-LIFTS {A = A} P h H =
  tr (fam-lifts A P) (eq-htpy (h ·l H)) ~ (tr-fam-lifts' P h H)

tr-eq-htpy-fam-lifts-htpy-refl :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4) →
  (h : B → X) (f : A → B) → TR-EQ-HTPY-FAM-LIFTS P h (htpy-refl' f)
tr-eq-htpy-fam-lifts-htpy-refl P h f k =
  ap (λ t → tr (fam-lifts _ P) t k) (eq-htpy-htpy-refl (h ∘ f))

abstract
  tr-eq-htpy-fam-lifts :
    {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4) →
    (h : B → X) {f g : A → B} (H : f ~ g) →
    TR-EQ-HTPY-FAM-LIFTS P h H
  tr-eq-htpy-fam-lifts P h {f} =
    ind-htpy f
      ( λ g H → TR-EQ-HTPY-FAM-LIFTS P h H)
      ( tr-eq-htpy-fam-lifts-htpy-refl P h f)

  compute-tr-eq-htpy-fam-lifts :
    {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4) →
    (h : B → X) (f : A → B) →
    Id  ( tr-eq-htpy-fam-lifts P h (htpy-refl' f))
        ( tr-eq-htpy-fam-lifts-htpy-refl P h f)
  compute-tr-eq-htpy-fam-lifts P h f =
    comp-htpy f
      ( λ g H → TR-EQ-HTPY-FAM-LIFTS P h H)
      ( tr-eq-htpy-fam-lifts-htpy-refl P h f)

{- One of the basic operations on lifts is precomposition by an ordinary
   function. -}

precompose-lifts :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3}
  (P : X → UU l4) → (f : A → B) → (h : B → X) →
  (fam-lifts B P h) → (fam-lifts A P (h ∘ f))
precompose-lifts P f h h' a = h' (f a)

{- Given two homotopic maps, their precomposition functions have different
   codomains. However, there is a commuting triangle. We obtain this triangle
   by homotopy induction. -}

TRIANGLE-PRECOMPOSE-LIFTS :
  { l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3}
  ( P : X → UU l4) {f g : A → B} (H : f ~ g) → UU (l1 ⊔ (l2 ⊔ (l3 ⊔ l4)))
TRIANGLE-PRECOMPOSE-LIFTS {A = A} {B} {X} P {f} {g} H =
  (h : B → X) →
    ( (tr (fam-lifts A P) (eq-htpy (h ·l H))) ∘ (precompose-lifts P f h)) ~
    ( precompose-lifts P g h)

triangle-precompose-lifts-htpy-refl :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3}
  (P : X → UU l4) (f : A → B) → TRIANGLE-PRECOMPOSE-LIFTS P (htpy-refl' f)
triangle-precompose-lifts-htpy-refl {A = A} P f h h' =
  tr-eq-htpy-fam-lifts-htpy-refl P h f (λ a → h' (f a))

abstract
  triangle-precompose-lifts :
    {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3}
    (P : X → UU l4) {f g : A → B} (H : f ~ g) →
    TRIANGLE-PRECOMPOSE-LIFTS P H
  triangle-precompose-lifts {A = A} P {f} =
    ind-htpy f
      ( λ g H → TRIANGLE-PRECOMPOSE-LIFTS P H)
      ( triangle-precompose-lifts-htpy-refl P f)

  compute-triangle-precompose-lifts :
    {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3}
    (P : X → UU l4) (f : A → B) →
    Id
      ( triangle-precompose-lifts P (htpy-refl' f))
      ( triangle-precompose-lifts-htpy-refl P f)
  compute-triangle-precompose-lifts P f =
    comp-htpy f
      ( λ g H → TRIANGLE-PRECOMPOSE-LIFTS P H)
      ( triangle-precompose-lifts-htpy-refl P f)

{- There is a similar commuting triangle with the computed transport function.
   This time we don't use homotopy induction to construct the homotopy. We
   give an explicit definition instead. -}

triangle-precompose-lifts' :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3}
  (P : X → UU l4) {f g : A → B} (H : f ~ g) → (h : B → X) →
  ( (tr-fam-lifts' P h H) ∘ (precompose-lifts P f h)) ~
  ( precompose-lifts P g h)
triangle-precompose-lifts' P H h k = eq-htpy (λ a → apd k (H a))

compute-triangle-precompose-lifts' :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3}
  (P : X → UU l4) (f : A → B) → (h : B → X) →
  ( triangle-precompose-lifts' P (htpy-refl' f) h) ~
  ( htpy-refl' ( precompose-lifts P f h))
compute-triangle-precompose-lifts' P f h k = eq-htpy-htpy-refl _

{- There is a coherence between the two commuting triangles. This coherence
   is again constructed by homotopy induction. -}

COHERENCE-TRIANGLE-PRECOMPOSE-LIFTS :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4)
  {f g : A → B} (H : f ~ g) → UU (l1 ⊔ (l2 ⊔ (l3 ⊔ l4)))
COHERENCE-TRIANGLE-PRECOMPOSE-LIFTS {A = A} {B} {X} P {f} {g} H =
  (h : B → X) →
    ( triangle-precompose-lifts P H h) ~
    ( ( ( tr-eq-htpy-fam-lifts P h H) ·r (precompose-lifts P f h)) ∙h
      ( triangle-precompose-lifts' P H h))

coherence-triangle-precompose-lifts-htpy-refl :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4)
  (f : A → B) → COHERENCE-TRIANGLE-PRECOMPOSE-LIFTS P (htpy-refl' f)
coherence-triangle-precompose-lifts-htpy-refl P f h =
  ( htpy-eq (htpy-eq (compute-triangle-precompose-lifts P f) h)) ∙h
  ( ( ( htpy-inv htpy-right-unit) ∙h
      ( htpy-ap-concat
        ( λ h' → tr-eq-htpy-fam-lifts-htpy-refl P h f (λ a → h' (f a)))
        ( htpy-refl)
        ( triangle-precompose-lifts' P htpy-refl h)
        ( htpy-inv (compute-triangle-precompose-lifts' P f h)))) ∙h
    ( htpy-eq
      ( ap
        ( λ t →
          ( t ·r (precompose-lifts P f h)) ∙h
          ( triangle-precompose-lifts' P htpy-refl h))
        ( inv (compute-tr-eq-htpy-fam-lifts P h f)))))

abstract
  coherence-triangle-precompose-lifts :
    {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4)
    {f g : A → B} (H : f ~ g) → COHERENCE-TRIANGLE-PRECOMPOSE-LIFTS P H
  coherence-triangle-precompose-lifts P {f} =
    ind-htpy f
      ( λ g H → COHERENCE-TRIANGLE-PRECOMPOSE-LIFTS P H)
      ( coherence-triangle-precompose-lifts-htpy-refl P f)

  compute-coherence-triangle-precompose-lifts :
    {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4)
    (f : A → B) →
      Id  ( coherence-triangle-precompose-lifts P (htpy-refl' f))
        ( coherence-triangle-precompose-lifts-htpy-refl P f)
  compute-coherence-triangle-precompose-lifts P f =
    comp-htpy f
      ( λ g H → COHERENCE-TRIANGLE-PRECOMPOSE-LIFTS P H)
      ( coherence-triangle-precompose-lifts-htpy-refl P f)

total-lifts :
  {l1 l2 l3 : Level} (A : UU l1) {X : UU l2} (P : X → UU l3) →
  UU _
total-lifts A {X} P = type-choice-∞ {A = A} {B = λ a → X} (λ a → P)

precompose-total-lifts :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3}
  (P : X → UU l4) → (A → B) →
  total-lifts B P → total-lifts A P
precompose-total-lifts {A = A} P f =
  toto
    ( λ h → (a : A) → P (h a))
    ( λ h → h ∘ f)
    ( precompose-lifts P f)

coherence-square-inv-choice-∞ :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3}
  (P : X → UU l4) (f : A → B) →
  coherence-square
    ( precompose-total-lifts P f)
    ( inv-choice-∞ {A = B} {B = λ x → X} {C = λ x y → P y})
    ( inv-choice-∞)
    ( λ h → h ∘ f)
coherence-square-inv-choice-∞ P f = htpy-refl

{- Our goal is now to produce a homotopy between (precompose-total-lifts P f)
   and (precompose-total-lifts P g) for homotopic maps f and g, and a coherence
   filling a cilinder. -}

HTPY-PRECOMPOSE-TOTAL-LIFTS :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3}
  (P : X → UU l4) {f g : A → B} (H : f ~ g) →
  UU (l1 ⊔ (l2 ⊔ (l3 ⊔ l4)))
HTPY-PRECOMPOSE-TOTAL-LIFTS P {f} {g} H =
  (precompose-total-lifts P f) ~ (precompose-total-lifts P g)

htpy-precompose-total-lifts :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4)
  {f g : A → B} (H : f ~ g) → HTPY-PRECOMPOSE-TOTAL-LIFTS P H
htpy-precompose-total-lifts {A = A} {B} P {f} {g} H =
  htpy-toto
    { P = fam-lifts B P}
    ( fam-lifts A P)
    ( λ h → eq-htpy (h ·l H))
    ( precompose-lifts P f)
    ( triangle-precompose-lifts P H)

{- We show that when htpy-precompose-total-lifts is applied to htpy-refl, it
   computes to htpy-refl. -}

tr-id-left-subst :
  {i j : Level} {A : UU i} {B : UU j} {f : A → B} {x y : A}
  (p : Id x y) (b : B) → (q : Id (f x) b) →
  Id (tr (λ (a : A) → Id (f a) b) p q) ((inv (ap f p)) ∙ q)
tr-id-left-subst refl b q = refl

compute-htpy-precompose-total-lifts :
  { l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4)
  ( f : A → B) →
  ( htpy-precompose-total-lifts P (htpy-refl' f)) ~
  ( htpy-refl' (toto (fam-lifts A P) (λ h → h ∘ f) (precompose-lifts P f)))
compute-htpy-precompose-total-lifts {A = A} P f (pair h h') =
  let α = λ (t : Id (h ∘ f) (h ∘ f)) → tr (fam-lifts A P) t (λ a → h' (f a))
  in
  ap eq-pair'
    ( eq-pair
      ( eq-htpy-htpy-refl (h ∘ f))
      ( ( tr-id-left-subst
          { f = α}
          ( eq-htpy-htpy-refl (h ∘ f))
          ( λ a → h' (f a))
          ( triangle-precompose-lifts P htpy-refl h h')) ∙
        ( ( ap
            ( λ t → inv (ap α (eq-htpy-htpy-refl (λ a → h (f a)))) ∙ t)
            ( htpy-eq
              ( htpy-eq (compute-triangle-precompose-lifts P f) h) h')) ∙
          ( left-inv (triangle-precompose-lifts-htpy-refl P f h h')))))

COHERENCE-HTPY-INV-CHOICE-∞ :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4)
  {f g : A → B} (H : f ~ g) → UU _
COHERENCE-HTPY-INV-CHOICE-∞ P {f} {g} H =
  ( ( coherence-square-inv-choice-∞ P f) ∙h
    ( inv-choice-∞ ·l ( htpy-precompose-total-lifts P H))) ~
  ( ( ( λ h → eq-htpy (h ·l H)) ·r inv-choice-∞) ∙h
    ( coherence-square-inv-choice-∞ P g))

coherence-htpy-inv-choice-∞-htpy-refl :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4)
  (f : A → B) → COHERENCE-HTPY-INV-CHOICE-∞ P (htpy-refl' f)
coherence-htpy-inv-choice-∞-htpy-refl {X = X} P f =
  ( htpy-ap-concat
    ( coherence-square-inv-choice-∞ P f)
    ( inv-choice-∞ ·l ( htpy-precompose-total-lifts P htpy-refl))
    ( htpy-refl)
    ( λ h →
      ap (ap inv-choice-∞) (compute-htpy-precompose-total-lifts P f h))) ∙h
  ( htpy-inv
    ( htpy-ap-concat'
      ( ( htpy-precomp htpy-refl (Σ X P)) ·r inv-choice-∞)
      ( htpy-refl)
      ( htpy-refl)
      ( λ h → compute-htpy-precomp f (Σ X P) (inv-choice-∞ h))))

abstract
  coherence-htpy-inv-choice-∞ :
    {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {X : UU l3} (P : X → UU l4)
    {f g : A → B} (H : f ~ g) → COHERENCE-HTPY-INV-CHOICE-∞ P H
  coherence-htpy-inv-choice-∞ P {f} =
    ind-htpy f
      ( λ g H → COHERENCE-HTPY-INV-CHOICE-∞ P H)
      ( coherence-htpy-inv-choice-∞-htpy-refl P f)

cone-family-dependent-pullback-property :
  {l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  (f : S → A) (g : S → B) (c : cocone f g X) (P : X → UU l) →
  cone-family
    ( fam-lifts S P)
    ( precompose-lifts P f)
    ( precompose-lifts P g)
    ( cone-pullback-property-pushout f g c X)
    ( fam-lifts X P)
cone-family-dependent-pullback-property f g c P γ =
  pair
    ( precompose-lifts P (pr1 c) γ)
    ( pair
      ( precompose-lifts P (pr1 (pr2 c)) γ)
      ( triangle-precompose-lifts P (pr2 (pr2 c)) γ))

is-pullback-cone-family-dependent-pullback-property :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  (f : S → A) (g : S → B) (c : cocone f g X) →
  ((l : Level) → pullback-property-pushout l f g c) →
  {l : Level} (P : X → UU l) (γ : X → X) →
  is-pullback
    ( ( tr (fam-lifts S P) (eq-htpy (γ ·l (pr2 (pr2 c))))) ∘
      ( precompose-lifts P f (γ ∘ (pr1 c))))
    ( precompose-lifts P g (γ ∘ (pr1 (pr2 c))))
    ( cone-family-dependent-pullback-property f g c P γ)
is-pullback-cone-family-dependent-pullback-property {S = S} {A} {B} {X}
  f g (pair i (pair j H)) pb-c P =
  let c = pair i (pair j H) in
  is-pullback-family-is-pullback-tot
    ( fam-lifts S P)
    ( precompose-lifts P f)
    ( precompose-lifts P g)
    ( cone-pullback-property-pushout f g c X)
    ( cone-family-dependent-pullback-property f g c P)
    ( pb-c _ X)
    ( is-pullback-top-is-pullback-bottom-cube-is-equiv
      ( precomp i (Σ X P))
      ( precomp j (Σ X P))
      ( precomp f (Σ X P))
      ( precomp g (Σ X P))
      ( toto (fam-lifts A P) (precomp i X) (precompose-lifts P i))
      ( toto (fam-lifts B P) (precomp j X) (precompose-lifts P j))
      ( toto (fam-lifts S P) (precomp f X) (precompose-lifts P f))
      ( toto (fam-lifts S P) (precomp g X) (precompose-lifts P g))
      ( inv-choice-∞)
      ( inv-choice-∞)
      ( inv-choice-∞)
      ( inv-choice-∞)
      ( htpy-precompose-total-lifts P H)
      ( htpy-refl)
      ( htpy-refl)
      ( htpy-refl)
      ( htpy-refl)
      ( htpy-precomp H (Σ X P))
      ( coherence-htpy-inv-choice-∞ P H)
      ( is-equiv-inv-choice-∞)
      ( is-equiv-inv-choice-∞)
      ( is-equiv-inv-choice-∞)
      ( is-equiv-inv-choice-∞)
      ( pb-c _ (Σ X P)))

dependent-pullback-property-pullback-property-pushout :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  (f : S → A) (g : S → B) (c : cocone f g X) →
  ((l : Level) → pullback-property-pushout l f g c) →
  ((l : Level) → dependent-pullback-property-pushout l f g c)
dependent-pullback-property-pullback-property-pushout
  {S = S} {A} {B} {X}
  f g (pair i (pair j H)) pullback-c l P =
  let c = pair i (pair j H) in
  is-pullback-htpy'
    ( (tr (fam-lifts S P) (eq-htpy (id ·l H))) ∘ (precompose-lifts P f i))
    ( (tr-eq-htpy-fam-lifts P id H) ·r (precompose-lifts P f i))
    ( precompose-lifts P g j)
    ( htpy-refl)
    ( cone-family-dependent-pullback-property f g c P id)
    { c' = cone-dependent-pullback-property-pushout f g c P}
    ( pair htpy-refl
      ( pair htpy-refl
        ( htpy-right-unit ∙h (coherence-triangle-precompose-lifts P H id))))
    ( is-pullback-cone-family-dependent-pullback-property f g c pullback-c P id)

{- This concludes the proof of Theorem 18.1.4. -}

{- We give some further useful implications -}

dependent-universal-property-universal-property-pushout :
  { l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  ( f : S → A) (g : S → B) (c : cocone f g X) →
  ( (l : Level) → universal-property-pushout l f g c) →
  ( (l : Level) → dependent-universal-property-pushout l f g c)
dependent-universal-property-universal-property-pushout f g c up-X =
  dependent-universal-property-dependent-pullback-property-pushout f g c
    ( dependent-pullback-property-pullback-property-pushout f g c
      ( λ l → pullback-property-pushout-universal-property-pushout l f g c
        ( up-X l)))

-- Section 16.2 Families over pushouts

{- Definition 18.2.1 -}

Fam-pushout :
  {l1 l2 l3 : Level} (l : Level) {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) → UU (l1 ⊔ (l2 ⊔ (l3 ⊔ lsuc l)))
Fam-pushout l {S} {A} {B} f g =
  Σ ( A → UU l)
    ( λ PA → Σ (B → UU l)
      ( λ PB → (s : S) → PA (f s) ≃ PB (g s)))

{- We characterize the identity type of Fam-pushout. -}

coherence-equiv-Fam-pushout :
  { l1 l2 l3 l l' : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  { f : S → A} {g : S → B}
  ( P : Fam-pushout l f g) (Q : Fam-pushout l' f g) →
  ( eA : (a : A) → (pr1 P a) ≃ (pr1 Q a))
  ( eB : (b : B) → (pr1 (pr2 P) b) ≃ (pr1 (pr2 Q) b)) →
  UU (l1 ⊔ l ⊔ l')
coherence-equiv-Fam-pushout {S = S} {f = f} {g} P Q eA eB =
  ( s : S) →
    ( (map-equiv (eB (g s))) ∘ (map-equiv (pr2 (pr2 P) s))) ~
    ( (map-equiv (pr2 (pr2 Q) s)) ∘ (map-equiv (eA (f s))))

equiv-Fam-pushout :
  {l1 l2 l3 l l' : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  {f : S → A} {g : S → B} →
  Fam-pushout l f g → Fam-pushout l' f g → UU (l1 ⊔ l2 ⊔ l3 ⊔ l ⊔ l')
equiv-Fam-pushout {S = S} {A} {B} {f} {g} P Q =
  Σ ( (a : A) → (pr1 P a) ≃ (pr1 Q a)) ( λ eA →
    Σ ( (b : B) → (pr1 (pr2 P) b) ≃ (pr1 (pr2 Q) b))
      ( coherence-equiv-Fam-pushout P Q eA))

reflexive-equiv-Fam-pushout :
  {l1 l2 l3 l : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  {f : S → A} {g : S → B} (P : Fam-pushout l f g) →
  equiv-Fam-pushout P P
reflexive-equiv-Fam-pushout (pair PA (pair PB PS)) =
  pair (λ a → equiv-id (PA a))
    ( pair
      ( λ b → equiv-id (PB b))
      ( λ s → htpy-refl))

equiv-Fam-pushout-eq :
  {l1 l2 l3 l : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  {f : S → A} {g : S → B} {P Q : Fam-pushout l f g} →
  Id P Q → equiv-Fam-pushout P Q
equiv-Fam-pushout-eq {P = P} {.P} refl =
  reflexive-equiv-Fam-pushout P

is-contr-total-equiv-Fam-pushout :
  {l1 l2 l3 l : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  {f : S → A} {g : S → B} (P : Fam-pushout l f g) →
  is-contr (Σ (Fam-pushout l f g) (equiv-Fam-pushout P))
is-contr-total-equiv-Fam-pushout {S = S} {A} {B} {f} {g} P =
  is-contr-total-Eq-structure
    ( λ PA' t eA →
      Σ ( (b : B) → (pr1 (pr2 P) b) ≃ (pr1 t b))
        ( coherence-equiv-Fam-pushout P (pair PA' t) eA))
    ( is-contr-total-Eq-Π
      ( λ a X → (pr1 P a) ≃ X)
      ( λ a → is-contr-total-equiv (pr1 P a))
      ( pr1 P))
    ( pair (pr1 P) (λ a → equiv-id (pr1 P a)))
    ( is-contr-total-Eq-structure
      ( λ PB' PS' eB →
        coherence-equiv-Fam-pushout
          P (pair (pr1 P) (pair PB' PS'))
          (λ a → equiv-id (pr1 P a)) eB)
      ( is-contr-total-Eq-Π
        ( λ b Y → (pr1 (pr2 P) b) ≃ Y)
        ( λ b → is-contr-total-equiv (pr1 (pr2 P) b))
        ( pr1 (pr2 P)))
      ( pair (pr1 (pr2 P)) (λ b → equiv-id (pr1 (pr2 P) b)))
      ( is-contr-total-Eq-Π
        ( λ s e → (map-equiv (pr2 (pr2 P) s)) ~ (map-equiv e))
        ( λ s → is-contr-total-htpy-equiv (pr2 (pr2 P) s))
        ( pr2 (pr2 P))))

is-equiv-equiv-Fam-pushout-eq :
  {l1 l2 l3 l : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  {f : S → A} {g : S → B} (P Q : Fam-pushout l f g) →
  is-equiv (equiv-Fam-pushout-eq {P = P} {Q})
is-equiv-equiv-Fam-pushout-eq P =
  fundamental-theorem-id P
    ( reflexive-equiv-Fam-pushout P)
    ( is-contr-total-equiv-Fam-pushout P)
    ( λ Q → equiv-Fam-pushout-eq {P = P} {Q})

equiv-equiv-Fam-pushout :
  {l1 l2 l3 l : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  {f : S → A} {g : S → B} (P Q : Fam-pushout l f g) →
  Id P Q ≃ equiv-Fam-pushout P Q
equiv-equiv-Fam-pushout P Q =
  pair
    ( equiv-Fam-pushout-eq)
    ( is-equiv-equiv-Fam-pushout-eq P Q)

eq-equiv-Fam-pushout :
  {l1 l2 l3 l : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  {f : S → A} {g : S → B} {P Q : Fam-pushout l f g} →
  (equiv-Fam-pushout P Q) → Id P Q
eq-equiv-Fam-pushout {P = P} {Q} =
  inv-is-equiv (is-equiv-equiv-Fam-pushout-eq P Q)

issec-eq-equiv-Fam-pushout :
  { l1 l2 l3 l : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  { f : S → A} {g : S → B} {P Q : Fam-pushout l f g} →
  ( ( equiv-Fam-pushout-eq {P = P} {Q}) ∘
    ( eq-equiv-Fam-pushout {P = P} {Q})) ~ id
issec-eq-equiv-Fam-pushout {P = P} {Q} =
  issec-inv-is-equiv (is-equiv-equiv-Fam-pushout-eq P Q)

isretr-eq-equiv-Fam-pushout :
  {l1 l2 l3 l : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  {f : S → A} {g : S → B} {P Q : Fam-pushout l f g} →
  ( ( eq-equiv-Fam-pushout {P = P} {Q}) ∘
    ( equiv-Fam-pushout-eq {P = P} {Q})) ~ id
isretr-eq-equiv-Fam-pushout {P = P} {Q} =
  isretr-inv-is-equiv (is-equiv-equiv-Fam-pushout-eq P Q)

{- This concludes the characterization of the identity type of Fam-pushout. -}

{- Definition 18.2.2 -}

desc-fam :
  {l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  {f : S → A} {g : S → B} (c : cocone f g X) →
  (P : X → UU l) → Fam-pushout l f g
desc-fam c P =
  pair
    ( P ∘ (pr1 c))
    ( pair
      ( P ∘ (pr1 (pr2 c)))
      ( λ s → (pair (tr P (pr2 (pr2 c) s)) (is-equiv-tr P (pr2 (pr2 c) s)))))

{- Theorem 18.2.3 -}

Fam-pushout-cocone-UU :
  {l1 l2 l3 : Level} (l : Level) {S : UU l1} {A : UU l2} {B : UU l3}
  {f : S → A} {g : S → B} → cocone f g (UU l) → Fam-pushout l f g
Fam-pushout-cocone-UU l =
  tot (λ PA → (tot (λ PB H s → equiv-eq (H s))))

is-equiv-Fam-pushout-cocone-UU :
  {l1 l2 l3 : Level} (l : Level) {S : UU l1} {A : UU l2} {B : UU l3}
  {f : S → A} {g : S → B} →
  is-equiv (Fam-pushout-cocone-UU l {f = f} {g})
is-equiv-Fam-pushout-cocone-UU l {f = f} {g} =
  is-equiv-tot-is-fiberwise-equiv
    ( λ PA → is-equiv-tot-is-fiberwise-equiv
      ( λ PB → is-equiv-postcomp-Π
        ( λ s → equiv-eq)
        ( λ s → univalence (PA (f s)) (PB (g s)))))

htpy-equiv-eq-ap-fam :
  {l1 l2 : Level} {A : UU l1} (B : A → UU l2) {x y : A} (p : Id x y) →
  htpy-equiv (equiv-tr B p) (equiv-eq (ap B p))
htpy-equiv-eq-ap-fam B {x} {.x} refl =
  reflexive-htpy-equiv (equiv-id (B x))

triangle-desc-fam :
  {l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  {f : S → A} {g : S → B} (c : cocone f g X) →
  ( desc-fam {l = l} c) ~
  ( ( Fam-pushout-cocone-UU l {f = f} {g}) ∘ ( cocone-map f g {Y = UU l} c))
triangle-desc-fam {l = l} {S} {A} {B} {X} (pair i (pair j H)) P =
  eq-equiv-Fam-pushout
    ( pair
      ( λ a → equiv-id (P (i a)))
      ( pair
        ( λ b → equiv-id (P (j b)))
        ( λ s → htpy-equiv-eq-ap-fam P (H s))))

is-equiv-desc-fam :
  {l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  {f : S → A} {g : S → B} (c : cocone f g X) →
  ((l' : Level) → universal-property-pushout l' f g c) →
  is-equiv (desc-fam {l = l} {f = f} {g} c)
is-equiv-desc-fam {l = l} {f = f} {g} c up-c =
  is-equiv-comp
    ( desc-fam c)
    ( Fam-pushout-cocone-UU l)
    ( cocone-map f g c)
    ( triangle-desc-fam c)
    ( up-c (lsuc l) (UU l))
    ( is-equiv-Fam-pushout-cocone-UU l)

equiv-desc-fam :
  {l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  {f : S → A} {g : S → B} (c : cocone f g X) →
  ((l' : Level) → universal-property-pushout l' f g c) →
  (X → UU l) ≃ Fam-pushout l f g
equiv-desc-fam c up-c =
  pair
    ( desc-fam c)
    ( is-equiv-desc-fam c up-c)

{- Corollary 18.2.4 -}

uniqueness-Fam-pushout :
  {l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  (f : S → A) (g : S → B) (c : cocone f g X) →
  ((l' : Level) → universal-property-pushout l' f g c) →
  ( P : Fam-pushout l f g) →
  is-contr
    ( Σ (X → UU l) (λ Q →
      equiv-Fam-pushout P (desc-fam c Q)))
uniqueness-Fam-pushout {l = l} f g c up-c P =
  is-contr-equiv'
    ( fib (desc-fam c) P)
    ( equiv-tot (λ Q →
      ( equiv-equiv-Fam-pushout P (desc-fam c Q)) ∘e
      ( equiv-inv (desc-fam c Q) P)))
    ( is-contr-map-is-equiv (is-equiv-desc-fam c up-c) P)

fam-Fam-pushout :
  {l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  {f : S → A} {g : S → B} (c : cocone f g X) →
  (up-X : (l' : Level) → universal-property-pushout l' f g c) →
  Fam-pushout l f g → (X → UU l)
fam-Fam-pushout {f = f} {g} c up-X P =
  pr1 (center (uniqueness-Fam-pushout f g c up-X P))

issec-fam-Fam-pushout :
  {l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  {f : S → A} {g : S → B} (c : cocone f g X) →
  (up-X : (l' : Level) → universal-property-pushout l' f g c) →
  ((desc-fam {l = l} c) ∘ (fam-Fam-pushout c up-X)) ~ id
issec-fam-Fam-pushout {f = f} {g} c up-X P =
  inv (eq-equiv-Fam-pushout (pr2 (center (uniqueness-Fam-pushout f g c up-X P))))

comp-left-fam-Fam-pushout :
  { l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  { f : S → A} {g : S → B} (c : cocone f g X) →
  ( up-X : (l' : Level) → universal-property-pushout l' f g c) →
  ( P : Fam-pushout l f g) →
  ( a : A) → (pr1 P a) ≃ (fam-Fam-pushout c up-X P (pr1 c a))
comp-left-fam-Fam-pushout {f = f} {g} c up-X P =
  pr1 (pr2 (center (uniqueness-Fam-pushout f g c up-X P)))

comp-right-fam-Fam-pushout :
  { l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  { f : S → A} {g : S → B} (c : cocone f g X) →
  ( up-X : (l' : Level) → universal-property-pushout l' f g c) →
  ( P : Fam-pushout l f g) →
  ( b : B) → (pr1 (pr2 P) b) ≃ (fam-Fam-pushout c up-X P (pr1 (pr2 c) b))
comp-right-fam-Fam-pushout {f = f} {g} c up-X P =
  pr1 (pr2 (pr2 (center (uniqueness-Fam-pushout f g c up-X P))))

comp-path-fam-Fam-pushout :
  { l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  { f : S → A} {g : S → B} (c : cocone f g X) →
  ( up-X : (l' : Level) → universal-property-pushout l' f g c) →
  ( P : Fam-pushout l f g) →
  ( s : S) →
    ( ( map-equiv (comp-right-fam-Fam-pushout c up-X P (g s))) ∘
      ( map-equiv (pr2 (pr2 P) s))) ~
    ( ( tr (fam-Fam-pushout c up-X P) (pr2 (pr2 c) s)) ∘
      ( map-equiv (comp-left-fam-Fam-pushout c up-X P (f s))))
comp-path-fam-Fam-pushout {f = f} {g} c up-X P =
  pr2 (pr2 (pr2 (center (uniqueness-Fam-pushout f g c up-X P))))

{-
-- Section 18.3 The Flattening lemma for pushouts

{- Definition 18.3.1 -}

cocone-flattening-pushout :
  { l1 l2 l3 l4 l5 : Level}
  { S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  ( f : S → A) (g : S → B) (c : cocone f g X)
  ( P : Fam-pushout l5 f g)
  ( Q : X → UU l5)
  ( e : equiv-Fam-pushout P (desc-fam f g c Q)) →
  cocone
    ( toto (pr1 P) f (λ s → id))
    ( toto (pr1 (pr2 P)) g (λ s → map-equiv (pr2 (pr2 P) s)))
    ( Σ X Q)
cocone-flattening-pushout f g c P Q e =
  pair
    ( toto Q
      ( pr1 c)
      ( λ a → map-equiv (pr1 e a)))
    ( pair
      ( toto Q
        ( pr1 (pr2 c))
        ( λ b → map-equiv (pr1 (pr2 e) b)))
      ( htpy-toto Q
        ( pr2 (pr2 c))
        ( λ s → map-equiv (pr1 e (f s)))
        ( λ s → htpy-inv (pr2 (pr2 e) s))))

{- Theorem 18.3.2 The flattening lemma -}

coherence-bottom-flattening-lemma' :
  {l1 l2 l3 : Level} {B : UU l1} {Q : B → UU l2} {T : UU l3}
  {b b' : B} (α : Id b b') {y : Q b} {y' : Q b'} (β : Id (tr Q α y) y')
  (h : (b : B) → Q b → T) → Id (h b y) (h b' y')
coherence-bottom-flattening-lemma' refl refl h = refl

coherence-bottom-flattening-lemma :
  {l1 l2 l3 l4 l5 : Level}
  {A : UU l1} {B : UU l2} {P : A → UU l3} {Q : B → UU l4} {T : UU l5}
  {f f' : A → B} (H : f ~ f')
  {g : (a : A) → P a → Q (f a)}
  {g' : (a : A) → P a → Q (f' a)}
  (K : (a : A) → ((tr Q (H a)) ∘ (g a)) ~ (g' a))
  (h : (b : B) → Q b → T) → (a : A) (p : P a) →
  Id (h (f a) (g a p)) (h (f' a) (g' a p))
coherence-bottom-flattening-lemma H K h a p =
  coherence-bottom-flattening-lemma' (H a) (K a p) h

coherence-cube-flattening-lemma :
  {l1 l2 l3 l4 l5 : Level}
  {A : UU l1} {B : UU l2} {P : A → UU l3} {Q : B → UU l4} {T : UU l5}
  {f f' : A → B} (H : f ~ f')
  {g : (a : A) → P a → Q (f a)}
  {g' : (a : A) → P a → Q (f' a)}
  (K : (a : A) → ((tr Q (H a)) ∘ (g a)) ~ (g' a))
  (h : Σ B Q → T) →
  Id ( eq-htpy
       ( λ a → eq-htpy
         ( coherence-bottom-flattening-lemma H K (ev-pair h) a)))
     ( ap ev-pair
       ( htpy-precomp (htpy-toto Q H g K) T h))
coherence-cube-flattening-lemma {A = A} {B} {P} {Q} {T} {f = f} {f'} H {g} {g'} K = ind-htpy f
    ( λ f' H' →
      (g : (a : A) → P a → Q (f a)) (g' : (a : A) → P a → Q (f' a))
      (K : (a : A) → ((tr Q (H' a)) ∘ (g a)) ~ (g' a)) (h : Σ B Q → T) →
      Id ( eq-htpy
           ( λ a → eq-htpy
             ( coherence-bottom-flattening-lemma H' K (ev-pair h) a)))
         ( ap ev-pair
           ( htpy-precomp (htpy-toto Q H' g K) T h)))
    ( λ g g' K h → {!ind-htpy g (λ g' K' → (h : Σ B Q → T) →
      Id ( eq-htpy
           ( λ a → eq-htpy
             ( coherence-bottom-flattening-lemma htpy-refl (λ a → htpy-eq (K' a)) (ev-pair h) a)))
         ( ap ev-pair
           ( htpy-precomp (htpy-toto Q htpy-refl g (λ a → htpy-eq (K' a))) T h))) ? (λ a → eq-htpy (K a)) h!})
    H g g' K

flattening-pushout' :
  {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  (f : S → A) (g : S → B) (c : cocone f g X) →
  ( P : Fam-pushout l5 f g)
  ( Q : X → UU l5)
  ( e : equiv-Fam-pushout P (desc-fam f g c Q)) →
  (l : Level) →
  pullback-property-pushout l
    ( toto (pr1 P) f (λ s → id))
    ( toto (pr1 (pr2 P)) g (λ s → map-equiv (pr2 (pr2 P) s)))
    ( cocone-flattening-pushout f g c P Q e)
flattening-pushout' f g c P Q e l T =
  is-pullback-top-is-pullback-bottom-cube-is-equiv
    ( ( postcomp-Π (λ x → precomp-Π (map-equiv (pr1 e x)) (λ q → T))) ∘
      ( precomp-Π (pr1 c) (λ x → (Q x) → T)))
    ( ( postcomp-Π (λ x → precomp-Π (map-equiv (pr1 (pr2 e) x)) (λ q → T))) ∘
      ( precomp-Π (pr1 (pr2 c)) (λ x → (Q x) → T)))
    ( precomp-Π f (λ a → (pr1 P a) → T))
    ( ( postcomp-Π (λ s → precomp (map-equiv (pr2 (pr2 P) s)) T)) ∘
      ( precomp-Π g (λ b → (pr1 (pr2 P) b) → T)))
    ( precomp (toto Q (pr1 c) (λ a → map-equiv (pr1 e a))) T)
    ( precomp (toto Q (pr1 (pr2 c)) (λ b → map-equiv (pr1 (pr2 e) b))) T)
    ( precomp (toto (pr1 P) f (λ s → id)) T)
    ( precomp (toto (pr1 (pr2 P)) g (λ s → map-equiv (pr2 (pr2 P) s))) T)
    ev-pair
    ev-pair
    ev-pair
    ev-pair
    ( htpy-precomp
      ( htpy-toto Q
        ( pr2 (pr2 c))
        ( λ s → map-equiv (pr1 e (f s)))
        ( λ s → htpy-inv (pr2 (pr2 e) s)))
      ( T))
    htpy-refl
    htpy-refl
    htpy-refl
    htpy-refl
    ( λ h → eq-htpy (λ s → eq-htpy
      ( coherence-bottom-flattening-lemma
        ( pr2 (pr2 c))
        ( λ s → htpy-inv (pr2 (pr2 e) s))
        ( h)
        ( s))))
    {!!}
    is-equiv-ev-pair
    is-equiv-ev-pair
    is-equiv-ev-pair
    is-equiv-ev-pair
    {!!}

flattening-pushout :
  {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4}
  (f : S → A) (g : S → B) (c : cocone f g X) →
  ( P : Fam-pushout l5 f g)
  ( Q : X → UU l5)
  ( e : equiv-Fam-pushout P (desc-fam f g c Q)) →
  (l : Level) →
  universal-property-pushout l
    ( toto (pr1 P) f (λ s → id))
    ( toto (pr1 (pr2 P)) g (λ s → map-equiv (pr2 (pr2 P) s)))
    ( cocone-flattening-pushout f g c P Q e)
flattening-pushout f g c P Q e l =
  universal-property-pushout-pullback-property-pushout l
    ( toto (pr1 P) f (λ s → id))
    ( toto (pr1 (pr2 P)) g (λ s → map-equiv (pr2 (pr2 P) s)))
    ( cocone-flattening-pushout f g c P Q e)
    ( flattening-pushout' f g c P Q e l)
-}


{-# OPTIONS --without-K #-}

open import lib.Basics
open import lib.types.Pi
open import lib.types.Pointed
open import lib.types.Sigma
open import lib.types.Span
open import lib.types.Paths
import lib.types.Generic1HIT as Generic1HIT

module lib.types.Pushout {i j k} where

module _ where

  private
    data #Pushout-aux (d : Span {i} {j} {k}) : Type (lmax (lmax i j) k) where
      #left : Span.A d → #Pushout-aux d
      #right : Span.B d → #Pushout-aux d

    data #Pushout (d : Span) : Type (lmax (lmax i j) k) where
      #pushout : #Pushout-aux d → (Unit → Unit) → #Pushout d

  Pushout : (d : Span) → Type _
  Pushout d = #Pushout d

  left : {d : Span} → Span.A d → Pushout d
  left a = #pushout (#left a) _

  right : {d : Span} → Span.B d → Pushout d
  right b = #pushout (#right b) _

  postulate  -- HIT
    glue : {d : Span} → (c : Span.C d) → left (Span.f d c) == right (Span.g d c) :> Pushout d

  module PushoutElim {d : Span} {l} {P : Pushout d → Type l}
    (left* : (a : Span.A d) → P (left a))
    (right* : (b : Span.B d) → P (right b))
    (glue* : (c : Span.C d) → left* (Span.f d c) == right* (Span.g d c) [ P ↓ glue c ]) where

    f : Π (Pushout d) P
    f = f-aux phantom  where

      f-aux : Phantom glue* → Π (Pushout d) P
      f-aux phantom (#pushout (#left y) _) = left* y
      f-aux phantom (#pushout (#right y) _) = right* y

    postulate  -- HIT
      glue-β : (c : Span.C d) → apd f (glue c) == glue* c

open PushoutElim public using () renaming (f to Pushout-elim)

module PushoutRec {d : Span} {l} {D : Type l}
  (left* : Span.A d → D) (right* : Span.B d → D)
  (glue* : (c : Span.C d) → left* (Span.f d c) == right* (Span.g d c)) where

  private
    module M = PushoutElim left* right* (λ c → ↓-cst-in (glue* c))

  f : Pushout d → D
  f = M.f

  glue-β : (c : Span.C d) → ap f (glue c) == glue* c
  glue-β c = apd=cst-in {f = f} (M.glue-β c)

module PushoutGeneric {d : Span {i} {j} {k}} where

  open Span d renaming (f to g; g to h)

  open Generic1HIT (Coprod A B) C (inl ∘ g) (inr ∘ h) public

  module _ where

    module To = PushoutRec (cc ∘ inl) (cc ∘ inr) pp

    to : Pushout d → T
    to = To.f

    from-cc : Coprod A B → Pushout d
    from-cc (inl a) = left a
    from-cc (inr b) = right b

    module From = Rec from-cc glue

    from : T → Pushout d
    from = From.f

    abstract
      to-from : (x : T) → to (from x) == x
      to-from = elim to-from-cc to-from-pp where

        to-from-cc : (x : Coprod A B)
          → to (from (cc x)) == cc x
        to-from-cc (inl a) = idp
        to-from-cc (inr b) = idp

        to-from-pp :
          (c : C) → idp == idp [ (λ z → to (from z) == z) ↓ pp c ]
        to-from-pp c = ↓-∘=idf-in to from
          (ap to (ap from (pp c))   =⟨ From.pp-β c |in-ctx ap to ⟩
           ap to (glue c)           =⟨ To.glue-β c ⟩
           pp c ∎)

      from-to : (x : Pushout d) → from (to x) == x
      from-to = Pushout-elim (λ a → idp) (λ b → idp) (λ c → ↓-∘=idf-in from to
        (ap from (ap to (glue c))   =⟨ To.glue-β c |in-ctx ap from ⟩
         ap from (pp c)             =⟨ From.pp-β c ⟩
         glue c ∎))

  generic-pushout : Pushout d ≃ T
  generic-pushout = equiv to from to-from from-to

_⊔^[_]_/_ : (A : Type i) (C : Type k) (B : Type j)
  (fg : (C → A) × (C → B)) → Type (lmax (lmax i j) k)
A ⊔^[ C ] B  / (f , g) = Pushout (span A B C f g)

⊙Pushout : (d : ⊙Span {i} {j} {k}) → Ptd _
⊙Pushout d = ⊙[ Pushout (⊙span-out d) , left (snd (⊙Span.X d)) ]

module _ (d : ⊙Span {i} {j} {k}) where

  open ⊙Span d

  ⊙left : fst (X ⊙→ ⊙Pushout d)
  ⊙left = (left , idp)

  ⊙right : fst (Y ⊙→ ⊙Pushout d)
  ⊙right =
    (right , ap right (! (snd g)) ∙ ! (glue (snd Z)) ∙' ap left (snd f))

  ⊙glue : (⊙left ⊙∘ f) == (⊙right ⊙∘ g)
  ⊙glue = pair=
    (λ= glue)
    (↓-app=cst-in $
      ap left (snd f) ∙ idp
        =⟨ ∙-unit-r _ ⟩
      ap left (snd f)
        =⟨ lemma (glue (snd Z)) (ap right (snd g)) (ap left (snd f)) ⟩
      glue (snd Z) ∙ ap right (snd g)
      ∙ ! (ap right (snd g)) ∙ ! (glue (snd Z)) ∙' ap left (snd f)
        =⟨ !-ap right (snd g)
           |in-ctx (λ w → glue (snd Z) ∙ ap right (snd g) ∙ w
                          ∙ ! (glue (snd Z)) ∙' ap left (snd f)) ⟩
      glue (snd Z) ∙ ap right (snd g)
      ∙ ap right (! (snd g)) ∙ ! (glue (snd Z)) ∙' ap left (snd f)
        =⟨ ! (app=-β glue (snd Z))
           |in-ctx (λ w → w ∙ ap right (snd g) ∙ ap right (! (snd g))
                            ∙ ! (glue (snd Z)) ∙' ap left (snd f)) ⟩
      app= (λ= glue) (snd Z) ∙ ap right (snd g)
      ∙ ap right (! (snd g)) ∙ ! (glue (snd Z)) ∙' ap left (snd f) ∎)
    where
    lemma : ∀ {i} {A : Type i} {x y z w : A}
      (p : x == y) (q : y == z) (r : x == w)
      → r == p ∙ q ∙ ! q ∙ ! p ∙' r
    lemma idp idp idp = idp

⊙pushout-J : ∀ {l} (P : ⊙Span → Type l)
  → ({A : Type i} {B : Type j} (Z : Ptd k) (f : fst Z → A) (g : fst Z → B)
     → P (⊙span (A , f (snd Z)) (B , g (snd Z)) Z (f , idp) (g , idp)))
  → ((ps : ⊙Span) → P ps)
⊙pushout-J P t (⊙span (_ , ._) (_ , ._) Z (f , idp) (g , idp)) = t Z f g


module _ where

record R : Set₁ where
  field
    Type : Set

postulate
  A : Set

module M (x : A) (r₁ : R) (y : A) where

  open R r₁

  r₂ : R
  r₂ = record { Type = A }

  foo : R.Type r₂
  foo = {!!}  -- R.Type r₂

  bar : R.Type r₁
  bar = {!!}  -- Type


{-# OPTIONS --safe --warning=error #-}

open import Sets.EquivalenceRelations
open import Setoids.Setoids
open import Groups.FreeGroup.Definition
open import Groups.Homomorphisms.Definition
open import Groups.Definition
open import Decidable.Sets
open import Numbers.Naturals.Order
open import LogicalFormulae
open import Semirings.Definition
open import Functions.Definition
open import Groups.Isomorphisms.Definition
open import Boolean.Definition
open import Boolean.Lemmas

module Groups.FreeGroup.Parity {a : _} {A : Set a} (decA : DecidableSet A) where

open import Groups.FreeGroup.Word decA
open import Groups.FreeGroup.Group decA

C2 : Group (reflSetoid Bool) xor
Group.+WellDefined C2 refl refl = refl
Group.0G C2 = BoolFalse
Group.inverse C2 = id
Group.+Associative C2 {BoolTrue} {BoolTrue} {BoolTrue} = refl
Group.+Associative C2 {BoolTrue} {BoolTrue} {BoolFalse} = refl
Group.+Associative C2 {BoolTrue} {BoolFalse} {z} = refl
Group.+Associative C2 {BoolFalse} {y} {z} = refl
Group.identRight C2 {BoolTrue} = refl
Group.identRight C2 {BoolFalse} = refl
Group.identLeft C2 {x} = refl
Group.invLeft C2 {BoolTrue} = refl
Group.invLeft C2 {BoolFalse} = refl
Group.invRight C2 {BoolTrue} = refl
Group.invRight C2 {BoolFalse} = refl

parity : (x : A) → ReducedWord → Bool
parity x empty = BoolFalse
parity x (prependLetter (ofLetter y) w _) with decA x y
parity x (prependLetter (ofLetter y) w _) | inl _ = not (parity x w)
parity x (prependLetter (ofLetter y) w _) | inr _ = parity x w
parity x (prependLetter (ofInv y) w _) with decA x y
parity x (prependLetter (ofInv y) w _) | inl _ = not (parity x w)
parity x (prependLetter (ofInv y) w _) | inr _ = parity x w

private
  parityPrepend : (a : A) (w : ReducedWord) (l : A) → ((a ≡ l) → False) → parity a (prepend w (ofLetter l)) ≡ parity a w
  parityPrepend a empty l notEq with decA a l
  parityPrepend a empty l notEq | inl x = exFalso (notEq x)
  parityPrepend a empty l notEq | inr x = refl
  parityPrepend a (prependLetter (ofLetter r) w x) l notEq with decA a l
  parityPrepend a (prependLetter (ofLetter r) w x) l notEq | inl m = exFalso (notEq m)
  parityPrepend a (prependLetter (ofLetter r) w x) l notEq | inr _ = refl
  parityPrepend a (prependLetter (ofInv r) w x) l notEq with decA a r
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inl a=r with decA l r
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inl a=r | inl l=r = exFalso (notEq (transitivity a=r (equalityCommutative l=r)))
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inl a=r | inr l!=r with decA a l
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inl a=r | inr l!=r | inl a=l = exFalso (notEq a=l)
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inl a=r | inr l!=r | inr a!=l with decA a r
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inl a=r | inr l!=r | inr a!=l | inl x₁ = refl
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inl a=r | inr l!=r | inr a!=l | inr bad = exFalso (bad a=r)
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inr a!=r with decA l r
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inl x₁ = refl
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inr l!=r with decA a l
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inr l!=r | inl a=l = exFalso (notEq a=l)
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inr l!=r | inr a!=l with decA a r
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inr l!=r | inr a!=l | inl a=r = exFalso (a!=r a=r)
  parityPrepend a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inr l!=r | inr a!=l | inr x₁ = refl

  parityPrepend' : (a : A) (w : ReducedWord) (l : A) → ((a ≡ l) → False) → parity a (prepend w (ofInv l)) ≡ parity a w
  parityPrepend' a empty l notEq with decA a l
  parityPrepend' a empty l notEq | inl x = exFalso (notEq x)
  parityPrepend' a empty l notEq | inr x = refl
  parityPrepend' a (prependLetter (ofLetter r) w x) l notEq with decA l r
  parityPrepend' a (prependLetter (ofLetter r) w x) l notEq | inl m with decA a r
  ... | inl a=r = exFalso (notEq (transitivity a=r (equalityCommutative m)))
  ... | inr a!=r = refl
  parityPrepend' a (prependLetter (ofLetter r) w x) l notEq | inr l!=r with decA a l
  ... | inl a=l = exFalso (notEq a=l)
  ... | inr a!=l = refl
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq with decA a r
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inl a=r with decA l r
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inl a=r | inl l=r = exFalso (notEq (transitivity a=r (equalityCommutative l=r)))
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inl a=r | inr l!=r with decA a l
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inl a=r | inr l!=r | inl a=l = exFalso (notEq a=l)
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inl a=r | inr l!=r | inr a!=l with decA a r
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inl a=r | inr l!=r | inr a!=l | inl x₁ = refl
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inl a=r | inr l!=r | inr a!=l | inr bad = exFalso (bad a=r)
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inr a!=r with decA l r
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inl l=r with decA a l
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inl l=r | inl a=l = exFalso (notEq a=l)
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inl l=r | inr a!=l with decA a r
  ... | inl a=r = exFalso (a!=r a=r)
  ... | inr _ = refl
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inr l!=r with decA a l
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inr l!=r | inl a=l = exFalso (notEq a=l)
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inr l!=r | inr a!=l with decA a r
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inr l!=r | inr a!=l | inl a=r = exFalso (a!=r a=r)
  parityPrepend' a (prependLetter (ofInv r) w x) l notEq | inr a!=r | inr l!=r | inr a!=l | inr x₁ = refl

  parityPrepend'' : (a : A) (w : ReducedWord) → parity a (prepend w (ofLetter a)) ≡ not (parity a w)
  parityPrepend'' a empty with decA a a
  ... | inl _ = refl
  ... | inr bad = exFalso (bad refl)
  parityPrepend'' a (prependLetter (ofLetter l) w x) with decA a a
  parityPrepend'' a (prependLetter (ofLetter l) w x) | inl _ with decA a l
  parityPrepend'' a (prependLetter (ofLetter l) w x) | inl _ | inl a=l = refl
  parityPrepend'' a (prependLetter (ofLetter l) w x) | inl _ | inr a!=l = refl
  parityPrepend'' a (prependLetter (ofLetter l) w x) | inr bad = exFalso (bad refl)
  parityPrepend'' a (prependLetter (ofInv l) w x) with decA a l
  ... | inl a=l = equalityCommutative (notNot (parity a w))
  parityPrepend'' a (prependLetter (ofInv l) w x) | inr a!=l with decA a a
  parityPrepend'' a (prependLetter (ofInv l) w x) | inr a!=l | inl _ with decA a l
  ... | inl a=l = exFalso (a!=l a=l)
  ... | inr _ = refl
  parityPrepend'' a (prependLetter (ofInv l) w x) | inr a!=l | inr bad = exFalso (bad refl)

  parityPrepend''' : (a : A) (w : ReducedWord) → parity a (prepend w (ofInv a)) ≡ not (parity a w)
  parityPrepend''' a empty with decA a a
  ... | inl _ = refl
  ... | inr bad = exFalso (bad refl)
  parityPrepend''' a (prependLetter (ofLetter l) w x) with decA a l
  ... | inl a=l = equalityCommutative (notNot _)
  parityPrepend''' a (prependLetter (ofLetter l) w x) | inr a!=l with decA a a
  ... | inl _ with decA a l
  parityPrepend''' a (prependLetter (ofLetter l) w x) | inr a!=l | inl _ | inl a=l = exFalso (a!=l a=l)
  parityPrepend''' a (prependLetter (ofLetter l) w x) | inr a!=l | inl _ | inr _ = refl
  parityPrepend''' a (prependLetter (ofLetter l) w x) | inr a!=l | inr bad = exFalso (bad refl)
  parityPrepend''' a (prependLetter (ofInv l) w x) with decA a a
  parityPrepend''' a (prependLetter (ofInv l) w x) | inl _ with decA a l
  ... | inl a=l = refl
  ... | inr a!=l = refl
  parityPrepend''' a (prependLetter (ofInv l) w x) | inr bad = exFalso (bad refl)

  parityHomIsHom : (a : A) → (x y : ReducedWord) → parity a (_+W_ x y) ≡ xor (parity a x) (parity a y)
  parityHomIsHom a empty y = refl
  parityHomIsHom a (prependLetter (ofLetter l) x _) y with decA a l
  parityHomIsHom a (prependLetter (ofLetter .a) x _) y | inl refl = transitivity (parityPrepend'' a (x +W y)) (transitivity (applyEquality not (parityHomIsHom a x y)) (notXor (parity a x) (parity a y)))
  parityHomIsHom a (prependLetter (ofLetter l) x _) y | inr a!=l = transitivity (parityPrepend a (_+W_ x y) l a!=l) (parityHomIsHom a x y)
  parityHomIsHom a (prependLetter (ofInv l) x _) y with decA a l
  parityHomIsHom a (prependLetter (ofInv .a) x _) y | inl refl = transitivity (parityPrepend''' a (x +W y)) (transitivity (applyEquality not (parityHomIsHom a x y)) (notXor (parity a x) (parity a y)))
  parityHomIsHom a (prependLetter (ofInv l) x _) y | inr a!=l = transitivity (parityPrepend' a (x +W y) l a!=l) (parityHomIsHom a x y)

parityHom : (x : A) → GroupHom (freeGroup) C2 (parity x)
GroupHom.groupHom (parityHom x) {y} {z} = parityHomIsHom x y z
GroupHom.wellDefined (parityHom x) refl = refl


module _ where

open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

postulate
  C : Set → Set

record R (F : Nat → Set) : Set where
  field
    n : Nat
    ⦃ iC ⦄ : C (F n)

postulate
  T : Nat → Set
  instance
    iCT5 : C (T 5)

module _ (n m : Nat) where
  foo : n ≡ suc m → Nat → Set
  foo refl p = Nat
    where
      bar : R T
      R.n bar = 5


module STLC.Kovacs.Normalisation where

open import STLC.Kovacs.NormalForm public

--------------------------------------------------------------------------------

-- (Tyᴺ)
infix 3 _⊩_
_⊩_ : 𝒞 → 𝒯 → Set

Γ ⊩ ⎵      = Γ ⊢ⁿᶠ ⎵

Γ ⊩ A ⇒ B = ∀ {Γ′} → (η : Γ′ ⊇ Γ) (a : Γ′ ⊩ A)
                     → Γ′ ⊩ B

-- (Conᴺ ; ∙ ; _,_)
infix 3 _⊩⋆_
data _⊩⋆_ : 𝒞 → 𝒞 → Set
  where
    ∅   : ∀ {Γ} → Γ ⊩⋆ ∅

    _,_ : ∀ {Γ Ξ A} → (ρ : Γ ⊩⋆ Ξ) (a : Γ ⊩ A)
                    → Γ ⊩⋆ Ξ , A

--------------------------------------------------------------------------------

-- (Tyᴺₑ)
acc : ∀ {A Γ Γ′} → Γ′ ⊇ Γ → Γ ⊩ A → Γ′ ⊩ A
acc {⎵}      η M = renⁿᶠ η M
acc {A ⇒ B} η f = λ η′ a → f (η ○ η′) a

-- (Conᴺₑ)
-- NOTE: _⬖_ = acc⋆
_⬖_ : ∀ {Γ Γ′ Ξ} → Γ ⊩⋆ Ξ → Γ′ ⊇ Γ → Γ′ ⊩⋆ Ξ
∅       ⬖ η = ∅
(ρ , a) ⬖ η = ρ ⬖ η , acc η a

--------------------------------------------------------------------------------

-- (∈ᴺ)
getᵥ : ∀ {Γ Ξ A} → Γ ⊩⋆ Ξ → Ξ ∋ A → Γ ⊩ A
getᵥ (ρ , a) zero    = a
getᵥ (ρ , a) (suc i) = getᵥ ρ i

-- (Tmᴺ)
eval : ∀ {Γ Ξ A} → Γ ⊩⋆ Ξ → Ξ ⊢ A → Γ ⊩ A
eval ρ (𝓋 i)   = getᵥ ρ i
eval ρ (ƛ M)   = λ η a → eval (ρ ⬖ η , a) M
eval ρ (M ∙ N) = eval ρ M idₑ (eval ρ N)

mutual
  -- (qᴺ)
  reify : ∀ {A Γ} → Γ ⊩ A → Γ ⊢ⁿᶠ A
  reify {⎵}      M = M
  reify {A ⇒ B} f = ƛ (reify (f (wkₑ idₑ) (reflect 0)))

  -- (uᴺ)
  reflect : ∀ {A Γ} → Γ ⊢ⁿᵉ A → Γ ⊩ A
  reflect {⎵}      M = ne M
  reflect {A ⇒ B} M = λ η a → reflect (renⁿᵉ η M ∙ reify a)

-- (uᶜᴺ)
idᵥ : ∀ {Γ} → Γ ⊩⋆ Γ
idᵥ {∅}     = ∅
idᵥ {Γ , A} = idᵥ ⬖ wkₑ idₑ , reflect 0

-- (nf)
nf : ∀ {Γ A} → Γ ⊢ A → Γ ⊢ⁿᶠ A
nf M = reify (eval idᵥ M)

--------------------------------------------------------------------------------


module UniverseCollapse
    (down : Set₁ -> Set)
    (up : Set → Set₁)
    (iso : ∀ {A} → down (up A) → A)
    (osi : ∀ {A} → up (down A) → A) where

anything : (A : Set) → A
anything = {!!}


module ImplicitRecordFields where

record R (X Y : Set) : Set₁ where
  field
    {A}         : Set
    f           : A → A
    {B C} D {E} : Set
    g           : B → C → E → X → Y

postulate A : Set

r : R A A
r = record
  { f = f
  ; B = A
  ; D = A
  ; g = λ (_ _ _ : _) → f
  }
  where
  f : A → A
  f x = x

data _≡_ {A : Set₁} (x : A) : A → Set where
  refl : x ≡ x

lemma₁ : r ≡ record {}
lemma₁ = refl

lemma₂ : R.B r ≡ A
lemma₂ = refl


open import Prelude

module Typed
  (Name   : Set)

  -- Data stuff
  (Datatype : Name -> List (List Name))

  -- Effect stuff
  (Effect : Set)
  (_⊆_    : Effect -> Effect -> Set)
  (Monad  : Effect -> Set -> Set)
  (return : forall {M A} -> A -> Monad M A)
  (map    : forall {M A B} -> (A -> B) -> Monad M A -> Monad M B)
  (join   : forall {M A} -> Monad M (Monad M A) -> Monad M A)
  (morph  : forall {M N} -> M ⊆ N -> (A : Set) -> Monad M A -> Monad N A)
  where

_=<<_ : forall {M A B} -> (A -> Monad M B) -> Monad M A -> Monad M B
k =<< m = join (map k m)

_>>=_ : forall {M A B} -> Monad M A -> (A -> Monad M B) -> Monad M B
m >>= k = k =<< m

infixl 50 _<*>_

_<*>_ : forall {M A B} -> Monad M (A -> B) -> Monad M A -> Monad M B
f <*> x = f >>= \f -> x >>= \x -> return (f x)

infixr 80 _⟶_
infix 100 [_]_

data VTy : Set

data CTy : Set where
  _⟶_  : VTy -> CTy -> CTy
  [_]_ : Effect -> VTy -> CTy

data VTy where
  ⟨_⟩   : CTy -> VTy
  TyCon : Name -> VTy

Cxt = List VTy

data ExC : Effect -> Cxt -> CTy -> Set
data InV : Effect -> Cxt -> VTy -> Set

data InC : Cxt -> CTy -> Set where

  ƛ_  : forall {V C Γ} ->
        InC (Γ ◄ V) C -> InC Γ (V ⟶ C)

  exC : forall {M N Γ V} ->
        ExC M Γ ([ N ] V) -> N ⊆ M -> InC Γ ([ M ] V)

  inV : forall {M Γ V} ->
        InV M Γ V -> InC Γ ([ M ] V)

InDs : Effect -> Cxt -> List Name -> Set

data InV where

  ⟪_⟫ : forall {M Γ C} -> InC Γ C -> InV M Γ ⟨ C ⟩

  ⟦_⟧ : forall {M Γ V} -> InC Γ ([ M ] V) -> InV M Γ V

  con : forall {M Γ D args} ->
        args ∈ Datatype D -> InDs M Γ args -> InV M Γ (TyCon D)

InDs M Γ = Box (\D -> InV M Γ (TyCon D))

data ExC where

  var : forall {M Γ V} -> V ∈ Γ -> ExC M Γ ([ M ] V)

  _•_ : forall {M Γ V C} ->
        ExC M Γ (V ⟶ C) -> InV M Γ V -> ExC M Γ C

Els : _

data El : Name -> Set where
  el : forall {args D} -> args ∈ Datatype D -> Els args -> El D

Els = Box El

VTy⟦_⟧ : VTy -> Set

CTy⟦_⟧ : CTy -> Set
CTy⟦ V ⟶ C   ⟧ = VTy⟦ V ⟧ -> CTy⟦ C ⟧
CTy⟦ [ M ] V ⟧ = Monad M VTy⟦ V ⟧

VTy⟦ ⟨ C ⟩   ⟧ = CTy⟦ C ⟧
VTy⟦ TyCon D ⟧ = El D

Env = Box VTy⟦_⟧

inC⟦_⟧ : forall {Γ C} -> InC Γ C -> Env Γ -> CTy⟦ C ⟧

inDs⟦_⟧ : forall {M Γ Ds} ->
          InDs M Γ Ds -> Env Γ -> Monad M (Els Ds)

inV⟦_⟧ : forall {M Γ V} -> InV M Γ V -> Env Γ -> Monad M VTy⟦ V ⟧
inV⟦ ⟪ c ⟫    ⟧ ρ = return (inC⟦ c ⟧ ρ)
inV⟦ ⟦ c ⟧    ⟧ ρ = inC⟦ c ⟧ ρ
inV⟦ con x Ds ⟧ ρ = return (el x) <*> inDs⟦ Ds ⟧ ρ

inDs⟦ ⟨⟩     ⟧ ρ = return ⟨⟩
inDs⟦ Ds ◃ v ⟧ ρ = return _◃_ <*> inDs⟦ Ds ⟧ ρ <*> inV⟦ v ⟧ ρ

exC⟦_⟧ : forall {M Γ C} -> ExC M Γ C -> Env Γ -> Monad M CTy⟦ C ⟧

inC⟦ ƛ c     ⟧ ρ = \v -> inC⟦ c ⟧ (ρ ◃ v)
inC⟦ exC c m ⟧ ρ = morph m _ =<< exC⟦ c ⟧ ρ
inC⟦ inV v   ⟧ ρ = inV⟦ v ⟧ ρ

exC⟦ var x ⟧ ρ = return (return (ρ ! x))
exC⟦ f • s ⟧ ρ = exC⟦ f ⟧ ρ <*> inV⟦ s ⟧ ρ


module UniDB.Spec where

open import UniDB.Core public

record Vr (T : STX) : Set where
  field
    vr     : {γ : Dom} → Ix γ → T γ
    vr-inj : {γ : Dom} → Inj (vr {γ})
open Vr {{...}} public

record Wk (X : STX) : Set where
  field
    wk₁     : {γ : Dom} (x : X γ) → X (suc γ)
    wk      : {γ : Dom} (δ : Dom) (x : X γ) → X (γ ∪ δ)
    wk-zero : {γ : Dom} (x : X γ) → wk 0 x ≡ x
    wk-suc  : {γ : Dom} (δ : Dom) (x : X γ) → wk (suc δ) x ≡ wk₁ (wk δ x)

  wk1-wk₁ : {γ : Dom} (x : X γ) →
    wk 1 x ≡ wk₁ x
  wk1-wk₁ x = trans (wk-suc 0 x) (cong wk₁ (wk-zero x))
open Wk {{...}} public

instance
  iVrIx : Vr Ix
  vr     {{iVrIx}} i = i
  vr-inj {{iVrIx}} p = p

  iWkIx : Wk Ix
  wk₁     {{iWkIx}}           = suc
  wk      {{iWkIx}} zero    i = i
  wk      {{iWkIx}} (suc δ) i = suc (wk δ i)
  wk-zero {{iWkIx}} x         = refl
  wk-suc  {{iWkIx}} δ x       = refl

--------------------------------------------------------------------------------

record WkVr (T : STX) {{vrT : Vr T}} {{wkT : Wk T}} : Set where
  field
    wk₁-vr  : {γ : Dom} (i : Ix γ) →
      wk₁ (vr {T} i) ≡ vr {T} (wk₁ i)
    wk-vr  : {γ : Dom} (δ : Dom) (i : Ix γ) →
      wk δ (vr {T} i) ≡ vr {T} (wk δ i)
open WkVr {{...}} public

instance
  iWkVrIx : WkVr Ix
  wk₁-vr {{iWkVrIx}} i = refl
  wk-vr {{iWkVrIx}} δ i = refl

--------------------------------------------------------------------------------

record Lk (T : STX) (Ξ : MOR) : Set where
  field
    lk : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (i : Ix γ₁) → T γ₂
open Lk {{...}} public

record Up (Ξ : MOR) : Set where
  infixl 9 _↑₁ _↑_
  field
    _↑₁ : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) → Ξ (suc γ₁) (suc γ₂)
    _↑_ : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (δ : Dom) → Ξ (γ₁ ∪ δ) (γ₂ ∪ δ)
    ↑-zero : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) → ξ ↑ zero ≡ ξ
    ↑-suc : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (δ : Dom) → ξ ↑ suc δ ≡ ξ ↑ δ ↑₁

record Comp (Ξ : MOR) : Set where
  infixl 8 _⊙_
  field
    _⊙_ : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Ξ γ₁ γ₂) (ξ₂ : Ξ γ₂ γ₃) → Ξ γ₁ γ₃

record Idm (Ξ : MOR) : Set where
  field
    idm : (γ : Dom) → Ξ γ γ

record Wkm (Ξ : MOR) : Set where
  field
    wkm : {γ : Dom} (δ : Dom) → Ξ γ (γ ∪ δ)

record Snoc (T : STX) (Ξ : MOR) : Set where
  field
    snoc : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (t : T γ₂) → Ξ (suc γ₁) γ₂

record Beta (T : STX) (Ξ : MOR) : Set where
  field
    beta : {γ : Dom} (t : T γ) → Ξ (suc γ) γ

open Idm {{...}} public
open Wkm {{...}} public
open Up {{...}} public
open Comp {{...}} public
open Snoc {{...}} public
open Beta {{...}} public

--------------------------------------------------------------------------------

record LkRen
  (T : STX) {{vrT : Vr T}}
  (Ξ : MOR) {{lkIxΞ : Lk Ix Ξ}} {{lkTΞ : Lk T Ξ}} : Set where
  field
    lk-ren : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (i : Ix γ₁) →
      lk {T} ξ i ≡ vr (lk ξ i)
open LkRen {{...}} public

record LkUp
  (T : STX) {{vrT : Vr T}} {{wkT : Wk T}}
  (Ξ : MOR) {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} : Set where
  field
    lk-↑₁-zero : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) →
      lk {T} (ξ ↑₁) zero ≡ vr zero
    lk-↑₁-suc : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (i : Ix γ₁) →
      lk {T} (ξ ↑₁) (suc i) ≡ wk₁ (lk ξ i)

  lk-↑-∪ : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (i : Ix γ₁) (δ : Dom) →
    lk {T} (ξ ↑ δ) (wk δ i) ≡ wk δ (lk ξ i)
  lk-↑-∪ ξ i zero    = begin
    lk (ξ ↑ 0) i                  ≡⟨ cong₂ lk ((↑-zero ξ)) refl ⟩
    lk ξ i                        ≡⟨ sym (wk-zero (lk ξ i)) ⟩
    wk 0 (lk ξ i)                 ∎
  lk-↑-∪ ξ i (suc δ) = begin
    lk (ξ ↑ suc δ) (suc (wk δ i)) ≡⟨ cong₂ lk (↑-suc ξ δ) refl ⟩
    lk (ξ ↑ δ ↑₁) (suc (wk δ i))  ≡⟨ lk-↑₁-suc (ξ ↑ δ) (wk δ i) ⟩
    wk₁ (lk (ξ ↑ δ) (wk δ i))     ≡⟨ cong wk₁ (lk-↑-∪ ξ i δ) ⟩
    wk₁ (wk δ (lk ξ i))           ≡⟨ sym (wk-suc δ (lk ξ i)) ⟩
    wk (suc δ) (lk ξ i)           ∎
open LkUp {{...}} public

record LkRenComp
  (T : STX) {{vrT : Vr T}}
  (Ξ : MOR) {{lkIxΞ : Lk Ix Ξ}} {{lkTΞ : Lk T Ξ}} {{compΞ : Comp Ξ}}
  {{lkRenTΞ : LkRen T Ξ}} : Set where
  field
    lk-ren-comp : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Ξ γ₁ γ₂) (ξ₂ : Ξ γ₂ γ₃)
      (i : Ix γ₁) → lk {T} (ξ₁ ⊙ ξ₂) i ≡ lk {T} ξ₂ (lk {Ix} ξ₁ i)
open LkRenComp {{...}} public

record LkIdm
  (T : STX) {{vrT : Vr T}}
  (Ξ : MOR) {{lkTΞ : Lk T Ξ}} {{idmΞ : Idm Ξ}} : Set where
  field
    lk-idm : {γ : Dom} (i : Ix γ) → lk {T} (idm {Ξ} γ) i ≡ vr i
open LkIdm {{...}} public

record LkWkm
  (T : STX) {{vrT : Vr T}}
  (Ξ : MOR) {{lkTΞ : Lk T Ξ}} {{wkmΞ : Wkm Ξ}} : Set where
  field
    lk-wkm : {γ : Dom} (δ : Dom) (i : Ix γ) →
      lk {T} (wkm {Ξ} δ) i ≡ vr (wk δ i)
open LkWkm {{...}} public

--------------------------------------------------------------------------------

record UpIdm (Ξ : MOR) {{upΞ : Up Ξ}} {{idmΞ : Idm Ξ}} : Set where
  field
    idm-↑₁ : {γ : Dom} → idm {Ξ} γ ↑₁ ≡ idm {Ξ} (suc γ)

  idm-↑ : {γ : Dom} (δ : Dom) → idm {Ξ} γ ↑ δ ≡ idm {Ξ} (γ ∪ δ)
  idm-↑ zero    = ↑-zero (idm {Ξ} _)
  idm-↑ (suc δ) = begin
    idm _ ↑ suc δ     ≡⟨ ↑-suc (idm _) δ ⟩
    idm _ ↑ δ ↑₁      ≡⟨ cong _↑₁ (idm-↑ δ) ⟩
    idm _ ↑₁          ≡⟨ idm-↑₁ ⟩
    idm (suc (_ ∪ δ)) ∎
open UpIdm {{...}} public

record UpComp (Ξ : MOR) {{upΞ : Up Ξ}} {{compΞ : Comp Ξ}} : Set where
  field
    ⊙-↑₁ : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Ξ γ₁ γ₂) (ξ₂ : Ξ γ₂ γ₃) →
      (ξ₁ ⊙ ξ₂) ↑₁ ≡ (ξ₁ ↑₁) ⊙ (ξ₂ ↑₁)

  ⊙-↑ : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Ξ γ₁ γ₂) (ξ₂ : Ξ γ₂ γ₃) (δ : Dom) →
    (ξ₁ ⊙ ξ₂) ↑ δ ≡ (ξ₁ ↑ δ) ⊙ (ξ₂ ↑ δ)
  ⊙-↑ ξ₁ ξ₂ zero    = begin
    (ξ₁ ⊙ ξ₂) ↑ 0       ≡⟨ ↑-zero (ξ₁ ⊙ ξ₂) ⟩
    ξ₁       ⊙ ξ₂       ≡⟨ sym (cong₂ _⊙_ (↑-zero ξ₁) (↑-zero ξ₂)) ⟩
    (ξ₁ ↑ 0) ⊙ (ξ₂ ↑ 0) ∎
  ⊙-↑ ξ₁ ξ₂ (suc δ) = begin
    (ξ₁ ⊙ ξ₂) ↑ suc δ           ≡⟨ ↑-suc (ξ₁ ⊙ ξ₂) δ ⟩
    (ξ₁ ⊙ ξ₂) ↑ δ ↑₁            ≡⟨ cong _↑₁ (⊙-↑ ξ₁ ξ₂ δ) ⟩
    ((ξ₁ ↑ δ) ⊙ (ξ₂ ↑ δ)) ↑₁    ≡⟨ ⊙-↑₁ (ξ₁ ↑ δ) (ξ₂ ↑ δ) ⟩
    (ξ₁ ↑ δ ↑₁) ⊙ (ξ₂ ↑ δ ↑₁)   ≡⟨ sym (cong₂ _⊙_ (↑-suc ξ₁ δ) (↑-suc ξ₂ δ)) ⟩
    (ξ₁ ↑ suc δ) ⊙ (ξ₂ ↑ suc δ) ∎
open UpComp {{...}} public

record CompIdm (Ξ : MOR) {{idmΞ : Idm Ξ}} {{compΞ : Comp Ξ}} : Set where
  field
    ⊙-idm : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) → ξ ⊙ idm {Ξ} γ₂ ≡ ξ
    idm-⊙ : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) → idm {Ξ} γ₁ ⊙ ξ ≡ ξ
open CompIdm {{...}} public

record CompAssoc (Ξ : MOR) {{compΞ : Comp Ξ}} : Set where
  field
    ⊙-assoc : {γ₁ γ₂ γ₃ γ₄ : Dom} (ξ₁ : Ξ γ₁ γ₂) (ξ₂ : Ξ γ₂ γ₃) (ξ₃ : Ξ γ₃ γ₄) →
      ξ₁ ⊙ (ξ₂ ⊙ ξ₃) ≡ (ξ₁ ⊙ ξ₂) ⊙ ξ₃
open CompAssoc {{...}} public

--------------------------------------------------------------------------------

record WkmBeta
  (T : STX) (Ξ : MOR) {{idmΞ : Idm Ξ}} {{wkmΞ : Wkm Ξ}}
  {{compΞ : Comp Ξ}} {{betaTΞ : Beta T Ξ}} : Set where
  field
    wkm-beta : {γ : Dom} (t : T γ) → wkm {Ξ} 1 ⊙ beta {T} {Ξ} t ≡ idm {Ξ} γ
open WkmBeta {{...}} public

record WkmHom
  (Ξ : MOR) {{idmΞ : Idm Ξ}} {{wkmΞ : Wkm Ξ}} {{compΞ : Comp Ξ}} : Set where
  field
    wkm-zero : {γ : Dom} → wkm {Ξ} 0 ≡ idm {Ξ} γ
    wkm-suc  : {γ : Dom} (δ : Dom) → wkm {Ξ} {γ} (suc δ) ≡ wkm {Ξ} δ ⊙ wkm {Ξ} 1
open WkmHom {{...}} public

record WkmComm
  (Ξ : MOR) {{upΞ : Up Ξ}} {{wkmΞ : Wkm Ξ}} {{compΞ : Comp Ξ}} : Set where
  field
    wkm₁-comm : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) →
      ξ ⊙ wkm {Ξ} 1 ≡ wkm {Ξ} 1 ⊙ ξ ↑₁

  wkm-comm : {{idmΞ : Idm Ξ}} {{wkmHomΞ : WkmHom Ξ}}
    {{compIdmΞ : CompIdm Ξ}} {{compAssocΞ : CompAssoc Ξ}}
    {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (δ : Dom) →
    ξ ⊙ wkm {Ξ} δ ≡ wkm {Ξ} δ ⊙ ξ ↑ δ
  wkm-comm {{iWkmCommReg}} ξ zero  = begin
    ξ ⊙ wkm 0       ≡⟨ cong (_⊙_ ξ) wkm-zero ⟩
    ξ ⊙ idm _       ≡⟨ ⊙-idm ξ ⟩
    ξ               ≡⟨ sym (idm-⊙ ξ) ⟩
    idm _ ⊙ ξ       ≡⟨ sym (cong₂ _⊙_ wkm-zero (↑-zero ξ)) ⟩
    wkm 0 ⊙ (ξ ↑ 0) ∎
  wkm-comm {{iWkmCommReg}} ξ (suc δ) = begin
    ξ ⊙ wkm (suc δ)                ≡⟨ cong (_⊙_ ξ) (wkm-suc δ) ⟩
    ξ ⊙ (wkm δ ⊙ wkm 1)           ≡⟨ ⊙-assoc ξ (wkm δ) (wkm 1) ⟩
    (ξ ⊙ wkm δ) ⊙ wkm 1           ≡⟨ cong (λ ξ → ξ ⊙ wkm 1) (wkm-comm ξ δ) ⟩
    (wkm δ ⊙ (ξ ↑ δ)) ⊙ wkm 1     ≡⟨ sym (⊙-assoc (wkm δ) (ξ ↑ δ) (wkm 1)) ⟩
    wkm δ ⊙ ((ξ ↑ δ) ⊙ wkm 1)     ≡⟨ cong (_⊙_ (wkm δ)) (wkm₁-comm (ξ ↑ δ)) ⟩
    wkm δ ⊙ (wkm 1 ⊙ (ξ ↑ δ ↑₁))  ≡⟨ ⊙-assoc (wkm δ) (wkm 1) (ξ ↑ δ ↑₁) ⟩
    (wkm δ ⊙ wkm 1) ⊙ (ξ ↑ δ ↑₁)  ≡⟨ cong (λ ρ → (wkm δ ⊙ wkm 1) ⊙ ρ) (sym (↑-suc ξ δ)) ⟩
    (wkm δ ⊙ wkm 1) ⊙ (ξ ↑ suc δ) ≡⟨ cong (λ ρ → ρ ⊙ (ξ ↑ suc δ)) (sym (wkm-suc δ)) ⟩
    wkm (suc δ) ⊙ (ξ ↑ suc δ) ∎
open WkmComm {{...}} public

--------------------------------------------------------------------------------

infix 1 [_]_≃_
record [_]_≃_
  (T : STX)
  {Ξ : MOR} {{lkTΞ : Lk T Ξ}}
  {Ζ : MOR} {{lkTΖ : Lk T Ζ}}
  {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₁ γ₂) : Set where
  field
    lk≃ : (i : Ix γ₁) → lk {T} {Ξ} ξ i ≡ lk {T} {Ζ} ζ i
open [_]_≃_ public

module _
  {T : STX} {{vrT : Vr T}} {{wkT : Wk T}}
  {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} {{lkUpTΞ : LkUp T Ξ}}
  {Ζ : MOR} {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}} {{lkUpTΖ : LkUp T Ζ}}
  where

  ≃-↑₁ : {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂}
    (hyp : [ T ] ξ ≃ ζ) → [ T ] ξ ↑₁ ≃ ζ ↑₁
  lk≃ (≃-↑₁ {γ₁} {γ₂} {ξ} {ζ} hyp) zero = begin
    lk (ξ ↑₁) zero     ≡⟨ lk-↑₁-zero ξ ⟩
    vr zero            ≡⟨ sym (lk-↑₁-zero ζ) ⟩
    lk (ζ ↑₁) zero     ∎
  lk≃ (≃-↑₁ {γ₁} {γ₂} {ξ} {ζ} hyp) (suc i) = begin
    lk (ξ ↑₁) (suc i)  ≡⟨ lk-↑₁-suc ξ i ⟩
    wk₁ (lk ξ i)       ≡⟨ cong wk₁ (lk≃ hyp i) ⟩
    wk₁ (lk ζ i)       ≡⟨ sym (lk-↑₁-suc ζ i) ⟩
    lk (ζ ↑₁) (suc i)  ∎

  ≃-↑ : {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂}
    (hyp : [ T ] ξ ≃ ζ) (δ : Dom) → [ T ] ξ ↑ δ ≃ ζ ↑ δ
  ≃-↑ {ξ = ξ} {ζ} hyp zero
    rewrite ↑-zero {Ξ} ξ | ↑-zero {Ζ} ζ = hyp
  ≃-↑ {ξ = ξ} {ζ} hyp (suc δ)
    rewrite ↑-suc {Ξ} ξ δ | ↑-suc {Ζ} ζ δ = ≃-↑₁ (≃-↑ hyp δ)

--------------------------------------------------------------------------------

infix 1 [_]_≅_
data [_]_≅_ (T : STX)
  {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}}
  {Ζ : MOR} {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}} :
  {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₁ γ₂) → Set where
  ≃-to-≅ : {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂}
    (hyp : (δ' : Dom) → [ T ] ξ ↑ δ' ≃ ζ ↑ δ') (δ : Dom) →
    [ T ] ξ ↑ δ ≅ ζ ↑ δ

module _
  {T : STX}
  {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}}
  {Ζ : MOR} {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}} where

  ≃-to-≅` : {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂}
    (hyp : (δ' : Dom) → [ T ] ξ ↑ δ' ≃ ζ ↑ δ') → [ T ] ξ ≅ ζ
  ≃-to-≅` {ξ = ξ} {ζ} hyp = lem₂
    where
      lem : [ T ] ξ ↑ 0 ≅ ζ ↑ 0
      lem = ≃-to-≅ hyp 0
      lem₂ : [ T ] ξ ≅ ζ
      lem₂ rewrite sym (↑-zero {Ξ} ξ) | sym (↑-zero {Ζ} ζ) = lem

  ≅-to-≃ : {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂}
    (hyp : [ T ] ξ ≅ ζ) → [ T ] ξ ≃ ζ
  ≅-to-≃ (≃-to-≅ hyp δ) = hyp δ

  ≅-↑₁ : {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂}
    (hyp : [ T ] ξ ≅ ζ) → [ T ] ξ ↑₁ ≅ ζ ↑₁
  ≅-↑₁ (≃-to-≅ {ξ = ξ} {ζ} hyp δ)
    rewrite sym (↑-suc {Ξ} ξ δ) | sym (↑-suc {Ζ} ζ δ)
    = ≃-to-≅ hyp (suc δ)

  ≅-↑ : {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂}
    (hyp : [ T ] ξ ≅ ζ) (δ : Dom) → [ T ] ξ ↑ δ ≅ ζ ↑ δ
  ≅-↑ {ξ = ξ} {ζ} hyp zero
    rewrite ↑-zero ξ | ↑-zero ζ
    = hyp
  ≅-↑ {ξ = ξ} {ζ} hyp (suc δ)
    rewrite ↑-suc ξ δ | ↑-suc ζ δ
    = ≅-↑₁ (≅-↑ hyp δ)

module _
  {T : STX} {{vrT : Vr T}}
  {Ξ : MOR} {{lkIxΞ : Lk Ix Ξ}} {{lkTΞ : Lk T Ξ}} {{lkRenTΞ : LkRen T Ξ}} {{upΞ : Up Ξ}}
  {Ζ : MOR} {{lkIxΖ : Lk Ix Ζ}} {{lkTΖ : Lk T Ζ}} {{lkRenTΖ : LkRen T Ζ}} {{upΖ : Up Ζ}} where

  Ix≅-to-≅ : {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂} → [ Ix ] ξ ≅ ζ → [ T ] ξ ≅ ζ
  Ix≅-to-≅ (≃-to-≅ {ξ = ξ} {ζ} hyp δ) = ≃-to-≅ (λ δ' → record { lk≃ = λ i → begin
    lk {T} (ξ ↑ δ') i       ≡⟨ lk-ren {T} {Ξ} (ξ ↑ δ') i ⟩
    vr (lk {Ix} (ξ ↑ δ') i) ≡⟨ cong vr (lk≃ (hyp δ') i) ⟩
    vr (lk {Ix} (ζ ↑ δ') i) ≡⟨ sym (lk-ren {T} {Ζ} (ζ ↑ δ') i) ⟩
    lk {T} (ζ ↑ δ') i ∎}) δ

--------------------------------------------------------------------------------

record HComp (Ξ Ζ Θ : MOR) : Set where
  infixl 8 _⊡_
  field
    _⊡_ : {γ₁ γ₂ γ₃ : Dom} (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₂ γ₃) → Θ γ₁ γ₃
open HComp {{...}} public

record UpHComp
  (Ξ : MOR) {{upΞ : Up Ξ}}
  (Ζ : MOR) {{upΖ : Up Ζ}}
  (Θ : MOR) {{upΘ : Up Θ}}
  {{hcompΞΖΘ : HComp Ξ Ζ Θ}} : Set where

  field
    ⊡-↑₁ : {γ₁ γ₂ γ₃ : Dom} (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₂ γ₃) →
      (_⊡_ {Θ = Θ} ξ ζ) ↑₁ ≡ (ξ ↑₁) ⊡ (ζ ↑₁)

  ⊡-↑ : {γ₁ γ₂ γ₃ : Dom} (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₂ γ₃) (δ : Dom) →
    _↑_ {Θ} (ξ ⊡ ζ) δ ≡ (ξ ↑ δ) ⊡ (ζ ↑ δ)
  ⊡-↑ ξ ζ zero = begin
    (ξ ⊡ ζ) ↑ 0           ≡⟨ ↑-zero {Θ} (_⊡_ {Ξ} {Ζ} {Θ} ξ ζ) ⟩
    (ξ ⊡ ζ)               ≡⟨ sym (cong₂ (_⊡_ {Ξ} {Ζ} {Θ}) (↑-zero ξ) (↑-zero ζ)) ⟩
    (ξ ↑ 0) ⊡ (ζ ↑ 0)     ∎
  ⊡-↑ ξ ζ (suc δ) = begin
    (ξ ⊡ ζ) ↑ suc δ       ≡⟨ ↑-suc (ξ ⊡ ζ) δ ⟩
    (ξ ⊡ ζ) ↑ δ ↑₁        ≡⟨ cong _↑₁ ((⊡-↑ ξ ζ δ)) ⟩
    (ξ ↑ δ ⊡ ζ ↑ δ) ↑₁    ≡⟨ ⊡-↑₁ (ξ ↑ δ) (ζ ↑ δ) ⟩
    ξ ↑ δ ↑₁ ⊡ ζ ↑ δ ↑₁   ≡⟨ sym (cong₂ (_⊡_ {Ξ} {Ζ} {Θ}) (↑-suc ξ δ) (↑-suc ζ δ)) ⟩
    ξ ↑ suc δ ⊡ ζ ↑ suc δ ∎
open UpHComp {{...}} public

record HCompIdmLeft
  (Ξ : MOR) {{idmΞ : Idm Ξ}}
  (Ζ : MOR) {{hcompΞΖΖ : HComp Ξ Ζ Ζ}} : Set where
  field
    idm-⊡ : {γ₁ γ₂ : Dom} (ζ : Ζ γ₁ γ₂) → idm {Ξ} γ₁ ⊡ ζ ≡ ζ
open HCompIdmLeft {{...}} public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some unit types
------------------------------------------------------------------------

-- The definitions in this file are reexported by Data.Unit.

module Data.Unit.Core where

open import Level

------------------------------------------------------------------------
-- A unit type defined as a data-type

-- The ⊤ type (see Data.Unit) comes with η-equality, which is often
-- nice to have, but sometimes it is convenient to be able to stop
-- unfolding (see "Hidden types" below).

data Unit : Set where
  unit : Unit

------------------------------------------------------------------------
-- Hidden types

-- "Hidden" values.

Hidden : ∀ {a} → Set a → Set a
Hidden A = Unit → A

-- The hide function can be used to hide function applications. Note
-- that the type-checker doesn't see that "hide f x" contains the
-- application "f x".

hide : ∀ {a b} {A : Set a} {B : A → Set b} →
       ((x : A) → B x) → ((x : A) → Hidden (B x))
hide f x unit = f x

-- Reveals a hidden value.

reveal : ∀ {a} {A : Set a} → Hidden A → A
reveal f = f unit


{- Formal verification of authenticated append-only skiplists in Agda, version 1.0.

   Copyright (c) 2020 Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import Data.Unit.NonEta
open import Data.Empty
open import Data.Sum
open import Data.Product
open import Data.Product.Properties
open import Data.Fin
open import Data.Fin.Properties renaming (_≟_ to _≟Fin_)
open import Data.Nat renaming (_≟_ to _≟ℕ_; _≤?_ to _≤?ℕ_)
open import Data.Nat.Divisibility
open import Data.List renaming (map to List-map)
open import Data.List.Properties using (∷-injective)
open import Data.List.Relation.Unary.Any
open import Data.List.Relation.Unary.All renaming (map to All-map)
open import Data.List.Relation.Unary.All.Properties hiding (All-map)
open import Data.List.Relation.Unary.Any.Properties
open import Data.List.Relation.Binary.Pointwise using (decidable-≡)
open import Data.Bool
open import Data.Maybe renaming (map to Maybe-map)

open import Function

open import Relation.Binary.PropositionalEquality
open import Relation.Binary.Core
open import Relation.Nullary

-- This module provides an injective way to encode natural numbers

module Data.Nat.Encode where

 -- Represents a list of binary digits with
 -- a leading one in reverse order.
 --
 -- 9, in binary: 1001
 --
 -- remove leading 1: 001,
 -- reverse: 100
 --
 -- as 𝔹+1: I O O ε
 --
 data 𝔹+1 : Set where
   ε  : 𝔹+1
   O_ : 𝔹+1 → 𝔹+1
   I_ : 𝔹+1 → 𝔹+1

 from𝔹+1 : 𝔹+1 → ℕ
 from𝔹+1 ε     = 1
 from𝔹+1 (O b) = 2 * from𝔹+1 b
 from𝔹+1 (I b) = suc (2 * from𝔹+1 b)

 -- Adds zero to our representation
 data 𝔹 : Set where
   z : 𝔹
   s : 𝔹+1 → 𝔹

 from𝔹 : 𝔹 → ℕ
 from𝔹 z = 0
 from𝔹 (s b) = from𝔹+1 b

 inc : 𝔹+1 → 𝔹+1
 inc ε     = O ε
 inc (O x) = I x
 inc (I x) = O (inc x)

 inc-ε-⊥ : ∀{b} → inc b ≡ ε → ⊥
 inc-ε-⊥ {ε}   ()
 inc-ε-⊥ {O b} ()
 inc-ε-⊥ {I b} ()

 to𝔹+1 : ℕ → 𝔹+1
 to𝔹+1 zero    = ε
 to𝔹+1 (suc n) = inc (to𝔹+1 n)

 to𝔹 : ℕ → 𝔹
 to𝔹 zero    = z
 to𝔹 (suc n) = s (to𝔹+1 n)

 toBitString+1 : 𝔹+1 → List Bool
 toBitString+1 ε = []
 toBitString+1 (I x) = true ∷ toBitString+1 x
 toBitString+1 (O x) = false ∷ toBitString+1 x

 toBitString : 𝔹 → List Bool
 toBitString z = []
 -- For an actual binary number as we know, we need
 -- to reverse the result of toBitString+1; for the sake of encoding
 -- a number as a list of booleans, this works just fine
 toBitString (s x) = true ∷ toBitString+1 x

 encodeℕ : ℕ → List Bool
 encodeℕ = toBitString ∘ to𝔹

 ---------------------
 -- Injectivity proofs

 O-inj : ∀{b1 b2} → O b1 ≡ O b2 → b1 ≡ b2
 O-inj refl = refl

 I-inj : ∀{b1 b2} → I b1 ≡ I b2 → b1 ≡ b2
 I-inj refl = refl

 s-inj : ∀{b1 b2} → s b1 ≡ s b2 → b1 ≡ b2
 s-inj refl = refl

 inc-inj : ∀ b1 b2 → inc b1 ≡ inc b2 → b1 ≡ b2
 inc-inj ε ε hip = refl
 inc-inj ε (I b2) hip = ⊥-elim (inc-ε-⊥ (sym (O-inj hip)))
 inc-inj (I b1) ε hip = ⊥-elim (inc-ε-⊥ (O-inj hip))
 inc-inj (O b1) (O b2) hip = cong O_ (I-inj hip)
 inc-inj (I b1) (I b2) hip = cong I_ (inc-inj b1 b2 (O-inj hip))

 to𝔹+1-inj : ∀ n m → to𝔹+1 n ≡ to𝔹+1 m → n ≡ m
 to𝔹+1-inj zero zero hip = refl
 to𝔹+1-inj zero (suc m) hip = ⊥-elim (inc-ε-⊥ (sym hip))
 to𝔹+1-inj (suc n) zero hip = ⊥-elim (inc-ε-⊥ hip)
 to𝔹+1-inj (suc n) (suc m) hip = cong suc (to𝔹+1-inj n m (inc-inj _ _ hip))

 to𝔹-inj : ∀ n m → to𝔹 n ≡ to𝔹 m → n ≡ m
 to𝔹-inj zero zero hip = refl
 to𝔹-inj (suc n) (suc m) hip = cong suc (to𝔹+1-inj n m (s-inj hip))

 toBitString+1-inj : ∀ b1 b2 → toBitString+1 b1 ≡ toBitString+1 b2
                   → b1 ≡ b2
 toBitString+1-inj ε ε hip = refl
 toBitString+1-inj (O b1) (O b2) hip
   = cong O_ (toBitString+1-inj b1 b2 (proj₂ (∷-injective hip)))
 toBitString+1-inj (I b1) (I b2) hip
   = cong I_ (toBitString+1-inj b1 b2 (proj₂ (∷-injective hip)))

 toBitString-inj : ∀ b1 b2 → toBitString b1 ≡ toBitString b2
                 → b1 ≡ b2
 toBitString-inj z z hip = refl
 toBitString-inj (s x) (s x₁) hip
   = cong s (toBitString+1-inj x x₁ (proj₂ (∷-injective hip)))

 encodeℕ-inj : ∀ n m → encodeℕ n ≡ encodeℕ m → n ≡ m
 encodeℕ-inj n m hip = to𝔹-inj n m (toBitString-inj (to𝔹 n) (to𝔹 m) hip)


------------------------------------------------------------------------------
-- Bisimulation on unbounded lists
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

-- In FOTC, we won't use the bisimulation functional on unbounded
-- lists. This module is only for illustrative purposes.

module FOTC.Relation.Binary.Bisimilarity.Bisimulation where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Relation.Binary.Bisimilarity.Type
open import FOTC.Relation.Binary.Bisimilarity.PropertiesI

----------------------------------------------------------------------------
-- The bisimilarity relation _≈_ on unbounded lists is the greatest
-- post-fixed point of Bisimulation (by post-fp and gpfp).

-- The bisimulation functional on unbounded lists (adapted from Dybjer
-- and Sander 1989, p. 310 and Jacobs and Rutten 1997, p. 30).
BisimulationF : (D → D → Set) → D → D → Set
BisimulationF B xs ys =
  ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys' ∧ B xs' ys'

-- The bisimilarity relation _≈_ on unbounded lists is a post-fixed
-- point of Bisimulation, i.e.
--
-- _≈_ ≤ Bisimulation _≈_.
post-fp : ∀ {xs ys} → xs ≈ ys → BisimulationF _≈_ xs ys
post-fp = ≈-out

-- The bisimilarity relation _≈_ on unbounded lists is the greatest
-- post-fixed point of Bisimulation, i.e.
 --
-- ∀ B. B ≤ Bisimulation B ⇒ B ≤ _≈_.
greatest-post-fp :
  (B : D → D → Set) →
  -- B is a post-fixed point of Bisimulation.
  (∀ {xs} {ys} → B xs ys → BisimulationF B xs ys) →
  -- _≈_ is greater than B.
  ∀ {xs} {ys} → B xs ys → xs ≈ ys
greatest-post-fp = ≈-coind

-- Because a greatest post-fixed point is a fixed-point, the
-- bisimilarity relation _≈_ on unbounded lists is also a pre-fixed
-- point of Bisimulation, i.e.
--
-- Bisimulation _≈_ ≤ _≈_.
pre-fp : ∀ {xs} {ys} → BisimulationF _≈_ xs ys → xs ≈ ys
pre-fp = ≈-in

----------------------------------------------------------------------------
-- References
--
-- Dybjer, Peter and Sander, Herbert P. (1989). A Functional
-- Programming Approach to the Specification and Verification of
-- Concurrent Systems. Formal Aspects of Computing 1, pp. 303–319.
--
-- Jacobs, Bart and Rutten, Jan (1997). A Tutorial on (Co)Algebras and
-- (Co)Induction. EATCS Bulletin 62, pp. 222–259.


-- Andreas, 2016-10-03, re issue #2231
-- Termination checking a corecursive definition in abstract mode.

{-# OPTIONS --guardedness #-}

infix 1000 ♯_

{-# BUILTIN INFINITY ∞  #-}
{-# BUILTIN SHARP    ♯_ #-}
{-# BUILTIN FLAT     ♭  #-}

abstract
  data Functor : Set where
    Id : Functor

  _·_ : Functor → Set → Set
  Id · A = A

  data ν (F : Functor) : Set where
    inn : ∞ (F · ν F) → ν F

  -- Evaluation is required to see that Id · ν Id is a coinductive type.

  foo : ∀ F → F · ν F
  foo Id = inn (♯ foo Id)

-- The termination checker needs to treat the generated #-foo function
-- in abstract mode, to have constructor Id in scope.


module ElaborateGive where

open import Agda.Builtin.List
open import Agda.Builtin.Nat
open import Agda.Builtin.Reflection
open import Agda.Builtin.String
open import Agda.Builtin.Unit

five : Nat
five = {!!}

five' : Nat
five' = {!!}

five'' : Nat
five'' = {!!}

macro
  addUnknown : Term → TC ⊤
  addUnknown goal = unify goal
                          (def (quote _+_)
                            (arg (arg-info visible relevant) unknown ∷
                            arg (arg-info visible relevant) unknown ∷ []))

unknownPlus : Nat
unknownPlus = {!!} + {!!}

macro
  literalNat : Nat → Term → TC ⊤
  literalNat n hole = unify hole (lit (nat n))

macro
  literalString : String → Term → TC ⊤
  literalString s hole = unify hole (lit (string s))

seven : Nat
seven = {!!}

seven' : Nat
seven' = {!!}

hello : String
hello = {!!}

hello' : String
hello' = {!!}

hi : String
hi = {!!}