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

-- Monoidal natural isomorphisms between lax and strong symmetric
-- monoidal functors.
--
-- NOTE. Symmetric monoidal natural isomorphisms are really just
-- monoidal natural isomorphisms that happen to go between symmetric
-- monoidal functors.  No additional conditions are necessary.
-- Nevertheless, the definitions in this module are useful when one is
-- working in a symmetric monoidal setting.  They also help Agda's
-- type checker by bundling the (symmetric monoidal) categories and
-- functors involved.

module Categories.NaturalTransformation.NaturalIsomorphism.Monoidal.Symmetric
  where

open import Level
open import Relation.Binary using (IsEquivalence)

open import Categories.Category.Monoidal using (SymmetricMonoidalCategory)
import Categories.Functor.Monoidal.Symmetric as BMF
open import Categories.Functor.Monoidal.Properties using () renaming
  ( idF-SymmetricMonoidal to idFˡ  ; idF-StrongSymmetricMonoidal to idFˢ
  ; ∘-SymmetricMonoidal   to _∘Fˡ_ ; ∘-StrongSymmetricMonoidal   to _∘Fˢ_
  )
open import Categories.NaturalTransformation.NaturalIsomorphism as NI
  using (NaturalIsomorphism)
import Categories.NaturalTransformation.NaturalIsomorphism.Monoidal as MNI

module Lax where
  open BMF.Lax using (SymmetricMonoidalFunctor)
  open MNI.Lax using (IsMonoidalNaturalIsomorphism)
  open SymmetricMonoidalFunctor using ()
    renaming (F to UF; monoidalFunctor to MF)
  private module U = MNI.Lax

  module _ {o ℓ e o′ ℓ′ e′}
           {C : SymmetricMonoidalCategory o ℓ e}
           {D : SymmetricMonoidalCategory o′ ℓ′ e′} where

    -- Monoidal natural isomorphisms between lax symmetric monoidal functors.

    record SymmetricMonoidalNaturalIsomorphism
           (F G : SymmetricMonoidalFunctor C D) : Set (o ⊔ ℓ ⊔ ℓ′ ⊔ e′) where

      field
        U              : NaturalIsomorphism (UF F) (UF G)
        F⇒G-isMonoidal : IsMonoidalNaturalIsomorphism (MF F) (MF G) U

      ⌊_⌋ : U.MonoidalNaturalIsomorphism (MF F) (MF G)
      ⌊_⌋ = record { U = U ; F⇒G-isMonoidal = F⇒G-isMonoidal }

      open U.MonoidalNaturalIsomorphism ⌊_⌋ public hiding (U; F⇒G-isMonoidal)

    infix 4 _≃_

    _≃_ = SymmetricMonoidalNaturalIsomorphism

    -- "Strengthening"

    ⌈_⌉ : {F G : SymmetricMonoidalFunctor C D} →
          U.MonoidalNaturalIsomorphism (MF F) (MF G) → F ≃ G
    ⌈ α ⌉ = record { U = U ; F⇒G-isMonoidal = F⇒G-isMonoidal }
      where open U.MonoidalNaturalIsomorphism α

    open SymmetricMonoidalNaturalIsomorphism

    -- Identity and compositions

    infixr 9 _ⓘᵥ_

    id : {F : SymmetricMonoidalFunctor C D} → F ≃ F
    id = ⌈ U.id ⌉

    _ⓘᵥ_ : {F G H : SymmetricMonoidalFunctor C D} → G ≃ H → F ≃ G → F ≃ H
    α ⓘᵥ β   = ⌈ ⌊ α ⌋ U.ⓘᵥ ⌊ β ⌋ ⌉

    isEquivalence : IsEquivalence _≃_
    isEquivalence = record
      { refl  = id
      ; sym   = λ α → record
        { U              = NI.sym (U α)
        ; F⇒G-isMonoidal = F⇐G-isMonoidal α
        }
      ; trans = λ α β → β ⓘᵥ α
      }
      where

  open SymmetricMonoidalNaturalIsomorphism

  module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″}
           {C : SymmetricMonoidalCategory o ℓ e}
           {D : SymmetricMonoidalCategory o′ ℓ′ e′}
           {E : SymmetricMonoidalCategory o″ ℓ″ e″} where

    infixr 9 _ⓘₕ_ _ⓘˡ_ _ⓘʳ_

    _ⓘₕ_ : {F G : SymmetricMonoidalFunctor C D}
           {H I : SymmetricMonoidalFunctor D E} →
           H ≃ I → F ≃ G → (H ∘Fˡ F) ≃ (I ∘Fˡ G)
    -- NOTE: this definition is clearly equivalent to
    --
    --   α ⓘₕ β = ⌈ ⌊ α ⌋ U.ⓘₕ ⌊ β ⌋ ⌉
    --
    -- but the latter takes an unreasonably long time to typecheck,
    -- while the unfolded version typechecks almost immediately.
    α ⓘₕ β = record
      { U               = C.U
      ; F⇒G-isMonoidal  = record
        { ε-compat      = C.ε-compat
        ; ⊗-homo-compat = C.⊗-homo-compat }
        }
      where module C = U.MonoidalNaturalIsomorphism (⌊ α ⌋ U.ⓘₕ ⌊ β ⌋)

    _ⓘˡ_ : {F G : SymmetricMonoidalFunctor C D}
           (H : SymmetricMonoidalFunctor D E) → F ≃ G → (H ∘Fˡ F) ≃ (H ∘Fˡ G)
    H ⓘˡ α = id {F = H} ⓘₕ α

    _ⓘʳ_ : {G H : SymmetricMonoidalFunctor D E} →
           G ≃ H → (F : SymmetricMonoidalFunctor C D) → (G ∘Fˡ F) ≃ (H ∘Fˡ F)
    α ⓘʳ F = α ⓘₕ id {F = F}

  -- Left and right unitors.

  module _ {o ℓ e o′ ℓ′ e′}
           {C : SymmetricMonoidalCategory o ℓ e}
           {D : SymmetricMonoidalCategory o′ ℓ′ e′}
           {F : SymmetricMonoidalFunctor C D} where

    -- NOTE: Again, manual expansion seems necessary to type check in
    -- reasonable time.

    unitorˡ : idFˡ D ∘Fˡ F ≃ F
    unitorˡ = record
      { U               = LU.U
      ; F⇒G-isMonoidal  = record
        { ε-compat      = LU.ε-compat
        ; ⊗-homo-compat = LU.⊗-homo-compat
        }
      }
      where module LU = U.MonoidalNaturalIsomorphism (U.unitorˡ {F = MF F})

    unitorʳ : F ∘Fˡ idFˡ C ≃ F
    unitorʳ = record
      { U               = RU.U
      ; F⇒G-isMonoidal  = record
        { ε-compat      = RU.ε-compat
        ; ⊗-homo-compat = RU.⊗-homo-compat
        }
      }
      where module RU = U.MonoidalNaturalIsomorphism (U.unitorʳ {F = MF F})

  -- Associator.

  module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″ o‴ ℓ‴ e‴}
           {B : SymmetricMonoidalCategory o ℓ e}
           {C : SymmetricMonoidalCategory o′ ℓ′ e′}
           {D : SymmetricMonoidalCategory o″ ℓ″ e″}
           {E : SymmetricMonoidalCategory o‴ ℓ‴ e‴}
           {F : SymmetricMonoidalFunctor B C}
           {G : SymmetricMonoidalFunctor C D}
           {H : SymmetricMonoidalFunctor D E} where

    -- NOTE: Again, manual expansion seems necessary to type check in
    -- reasonable time.

    associator : (H ∘Fˡ G) ∘Fˡ F ≃ H ∘Fˡ (G ∘Fˡ F)
    associator = record
      { U               = AU.U
      ; F⇒G-isMonoidal  = record
        { ε-compat      = AU.ε-compat
        ; ⊗-homo-compat = AU.⊗-homo-compat
        }
      }
      where
        module AU =
          U.MonoidalNaturalIsomorphism (U.associator {F = MF F} {MF G} {MF H})

module Strong where
  open BMF.Strong using (SymmetricMonoidalFunctor)
  open MNI.Strong using (IsMonoidalNaturalIsomorphism)
  open SymmetricMonoidalFunctor using () renaming
    ( F                         to UF
    ; monoidalFunctor           to MF
    ; laxSymmetricMonoidalFunctor to laxBMF
    )
  private module U = MNI.Strong

  module _ {o ℓ e o′ ℓ′ e′}
           {C : SymmetricMonoidalCategory o ℓ e}
           {D : SymmetricMonoidalCategory o′ ℓ′ e′} where

    -- Monoidal natural isomorphisms between strong symmetric monoidal functors.

    record SymmetricMonoidalNaturalIsomorphism
           (F G : SymmetricMonoidalFunctor C D) : Set (o ⊔ ℓ ⊔ ℓ′ ⊔ e′) where

      field
        U              : NaturalIsomorphism (UF F) (UF G)
        F⇒G-isMonoidal : IsMonoidalNaturalIsomorphism (MF F) (MF G) U

      ⌊_⌋ : U.MonoidalNaturalIsomorphism (MF F) (MF G)
      ⌊_⌋ = record { U = U ; F⇒G-isMonoidal = F⇒G-isMonoidal }

      laxBNI : Lax.SymmetricMonoidalNaturalIsomorphism (laxBMF F) (laxBMF G)
      laxBNI = record { U = U ; F⇒G-isMonoidal = F⇒G-isMonoidal }

      open Lax.SymmetricMonoidalNaturalIsomorphism laxBNI public
        hiding (U; F⇒G-isMonoidal; ⌊_⌋)

    infix 4 _≃_

    _≃_ = SymmetricMonoidalNaturalIsomorphism

    -- "Strengthening"

    ⌈_⌉ : {F G : SymmetricMonoidalFunctor C D} →
          U.MonoidalNaturalIsomorphism (MF F) (MF G) → F ≃ G
    ⌈ α ⌉ = record { U = U ; F⇒G-isMonoidal = F⇒G-isMonoidal }
      where open U.MonoidalNaturalIsomorphism α

    open SymmetricMonoidalNaturalIsomorphism

    -- Identity and compositions

    infixr 9 _ⓘᵥ_

    id : {F : SymmetricMonoidalFunctor C D} → F ≃ F
    id = ⌈ U.id ⌉

    _ⓘᵥ_ : {F G H : SymmetricMonoidalFunctor C D} → G ≃ H → F ≃ G → F ≃ H
    α ⓘᵥ β   = ⌈ ⌊ α ⌋ U.ⓘᵥ ⌊ β ⌋ ⌉

    isEquivalence : IsEquivalence _≃_
    isEquivalence = record
      { refl  = id
      ; sym   = λ α → record
        { U              = NI.sym (U α)
        ; F⇒G-isMonoidal = F⇐G-isMonoidal α
        }
      ; trans = λ α β → β ⓘᵥ α
      }
      where

  open SymmetricMonoidalNaturalIsomorphism

  module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″}
           {C : SymmetricMonoidalCategory o ℓ e}
           {D : SymmetricMonoidalCategory o′ ℓ′ e′}
           {E : SymmetricMonoidalCategory o″ ℓ″ e″} where

    infixr 9 _ⓘₕ_ _ⓘˡ_ _ⓘʳ_

    _ⓘₕ_ : {F G : SymmetricMonoidalFunctor C D}
           {H I : SymmetricMonoidalFunctor D E} →
           H ≃ I → F ≃ G → (H ∘Fˢ F) ≃ (I ∘Fˢ G)
    -- NOTE: this definition is clearly equivalent to
    --
    --   α ⓘₕ β = ⌈ ⌊ α ⌋ U.ⓘₕ ⌊ β ⌋ ⌉
    --
    -- but the latter takes an unreasonably long time to typecheck,
    -- while the unfolded version typechecks almost immediately.
    α ⓘₕ β = record
      { U               = C.U
      ; F⇒G-isMonoidal  = record
        { ε-compat      = C.ε-compat
        ; ⊗-homo-compat = C.⊗-homo-compat }
        }
      where module C = U.MonoidalNaturalIsomorphism (⌊ α ⌋ U.ⓘₕ ⌊ β ⌋)

    _ⓘˡ_ : {F G : SymmetricMonoidalFunctor C D}
           (H : SymmetricMonoidalFunctor D E) → F ≃ G → (H ∘Fˢ F) ≃ (H ∘Fˢ G)
    H ⓘˡ α = id {F = H} ⓘₕ α

    _ⓘʳ_ : {G H : SymmetricMonoidalFunctor D E} →
           G ≃ H → (F : SymmetricMonoidalFunctor C D) → (G ∘Fˢ F) ≃ (H ∘Fˢ F)
    α ⓘʳ F = α ⓘₕ id {F = F}

  -- Left and right unitors.

  module _ {o ℓ e o′ ℓ′ e′}
           {C : SymmetricMonoidalCategory o ℓ e}
           {D : SymmetricMonoidalCategory o′ ℓ′ e′}
           {F : SymmetricMonoidalFunctor C D} where

    -- NOTE: Again, manual expansion seems necessary to type check in
    -- reasonable time.

    unitorˡ : idFˢ D ∘Fˢ F ≃ F
    unitorˡ = record
      { U               = LU.U
      ; F⇒G-isMonoidal  = record
        { ε-compat      = LU.ε-compat
        ; ⊗-homo-compat = LU.⊗-homo-compat
        }
      }
      where module LU = U.MonoidalNaturalIsomorphism (U.unitorˡ {F = MF F})

    unitorʳ : F ∘Fˢ idFˢ C ≃ F
    unitorʳ = record
      { U               = RU.U
      ; F⇒G-isMonoidal  = record
        { ε-compat      = RU.ε-compat
        ; ⊗-homo-compat = RU.⊗-homo-compat
        }
      }
      where module RU = U.MonoidalNaturalIsomorphism (U.unitorʳ {F = MF F})

  -- Associator.

  module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″ o‴ ℓ‴ e‴}
           {B : SymmetricMonoidalCategory o ℓ e}
           {C : SymmetricMonoidalCategory o′ ℓ′ e′}
           {D : SymmetricMonoidalCategory o″ ℓ″ e″}
           {E : SymmetricMonoidalCategory o‴ ℓ‴ e‴}
           {F : SymmetricMonoidalFunctor B C}
           {G : SymmetricMonoidalFunctor C D}
           {H : SymmetricMonoidalFunctor D E} where

    -- NOTE: Again, manual expansion seems necessary to type check in
    -- reasonable time.

    associator : (H ∘Fˢ G) ∘Fˢ F ≃ H ∘Fˢ (G ∘Fˢ F)
    associator = record
      { U               = AU.U
      ; F⇒G-isMonoidal  = record
        { ε-compat      = AU.ε-compat
        ; ⊗-homo-compat = AU.⊗-homo-compat
        }
      }
      where
        module AU =
          U.MonoidalNaturalIsomorphism (U.associator {F = MF F} {MF G} {MF H})


{-

Properties and Formulae about Cardinality

This file contains:
- Relation between abstract properties and cardinality in special cases;
- Combinatorial formulae, namely, cardinality of A+B, A×B, ΣAB, ΠAB, etc;
- A general form of Pigeonhole Principle;
- Maximal value of numerical function on finite sets;
- Set truncation of FinSet is equivalent to ℕ;
- FinProp is equivalent to Bool.

-}
{-# OPTIONS --safe #-}

module Cubical.Data.FinSet.Cardinality where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Equiv renaming (_∙ₑ_ to _⋆_)
open import Cubical.Foundations.Equiv.Properties
open import Cubical.Foundations.Transport

open import Cubical.HITs.PropositionalTruncation as Prop
open import Cubical.HITs.SetTruncation as Set

open import Cubical.Data.Nat
open import Cubical.Data.Nat.Order
open import Cubical.Data.Unit
open import Cubical.Data.Empty as Empty
open import Cubical.Data.Bool hiding (_≟_)
open import Cubical.Data.Sum
open import Cubical.Data.Sigma

open import Cubical.Data.Fin using (Fin-inj)
open import Cubical.Data.Fin.LehmerCode as LehmerCode
open import Cubical.Data.SumFin
open import Cubical.Data.FinSet.Base
open import Cubical.Data.FinSet.Properties
open import Cubical.Data.FinSet.FiniteChoice
open import Cubical.Data.FinSet.Constructors
open import Cubical.Data.FinSet.Induction hiding (_+_)

open import Cubical.Relation.Nullary

open import Cubical.Functions.Fibration
open import Cubical.Functions.Embedding
open import Cubical.Functions.Surjection

private
  variable
    ℓ ℓ' ℓ'' : Level
    n : ℕ
    X : FinSet ℓ
    Y : FinSet ℓ'

-- cardinality of finite sets

∣≃card∣ : (X : FinSet ℓ) → ∥ X .fst ≃ Fin (card X) ∥
∣≃card∣ X = X .snd .snd

-- cardinality is invariant under equivalences

cardEquiv : (X : FinSet ℓ)(Y : FinSet ℓ') → ∥ X .fst ≃ Y .fst ∥ → card X ≡ card Y
cardEquiv X Y e =
  Prop.rec (isSetℕ _ _) (λ p → Fin-inj _ _ (ua p))
    (∣ invEquiv (SumFin≃Fin _) ∣ ⋆̂ ∣invEquiv∣ (∣≃card∣ X) ⋆̂ e ⋆̂ ∣≃card∣ Y ⋆̂ ∣ SumFin≃Fin _ ∣)

cardInj : card X ≡ card Y → ∥ X .fst ≃ Y .fst ∥
cardInj {X = X} {Y = Y} p =
  ∣≃card∣ X ⋆̂ ∣ pathToEquiv (cong Fin p) ∣ ⋆̂ ∣invEquiv∣ (∣≃card∣ Y)

cardReflection : card X ≡ n → ∥ X .fst ≃ Fin n ∥
cardReflection {X = X} = cardInj {X = X} {Y = _ , isFinSetFin}

card≡MereEquiv : (card X ≡ card Y) ≡ ∥ X .fst ≃ Y .fst ∥
card≡MereEquiv {X = X} {Y = Y} =
  hPropExt (isSetℕ _ _) isPropPropTrunc (cardInj {X = X} {Y = Y}) (cardEquiv X Y)

-- special properties about specific cardinality

module _
  {X : FinSet ℓ} where

  card≡0→isEmpty : card X ≡ 0 → ¬ X .fst
  card≡0→isEmpty p x =
    Prop.rec isProp⊥ (λ e → subst Fin p (e .fst x)) (∣≃card∣ X)

  card>0→isInhab : card X > 0 → ∥ X .fst ∥
  card>0→isInhab p =
    Prop.map (λ e → invEq e (Fin>0→isInhab _ p)) (∣≃card∣ X)

  card>1→hasNonEqualTerm : card X > 1 → ∥ Σ[ a ∈ X .fst ] Σ[ b ∈ X .fst ] ¬ a ≡ b ∥
  card>1→hasNonEqualTerm p =
    Prop.map
      (λ e →
        e .fst (Fin>1→hasNonEqualTerm _ p .fst) ,
        e .fst (Fin>1→hasNonEqualTerm _ p .snd .fst) ,
        Fin>1→hasNonEqualTerm _ p .snd .snd ∘ invEq (congEquiv e))
      (∣invEquiv∣ (∣≃card∣ X))

  card≡1→isContr : card X ≡ 1 → isContr (X .fst)
  card≡1→isContr p =
    Prop.rec isPropIsContr
        (λ e → isOfHLevelRespectEquiv 0 (invEquiv (e ⋆ substEquiv Fin p)) isContrSumFin1) (∣≃card∣ X)

  card≤1→isProp : card X ≤ 1 → isProp (X .fst)
  card≤1→isProp p =
    Prop.rec isPropIsProp (λ e → isOfHLevelRespectEquiv 1 (invEquiv e) (Fin≤1→isProp (card X) p)) (∣≃card∣ X)

  card≡n : card X ≡ n → ∥ X ≡ 𝔽in n ∥
  card≡n {n = n} p =
    Prop.map
        (λ e →
          (λ i →
            ua e i ,
            isProp→PathP {B = λ j → isFinSet (ua e j)}
              (λ _ → isPropIsFinSet) (X .snd) (𝔽in n .snd) i ))
        (∣≃card∣ X ⋆̂ ∣ pathToEquiv (cong Fin p) ⋆ invEquiv (𝔽in≃Fin n) ∣)

  card≡0 : card X ≡ 0 → X ≡ 𝟘
  card≡0 p =
    propTruncIdempotent≃
      (isOfHLevelRespectEquiv
        1 (FinSet≡ X 𝟘)
          (isOfHLevel≡ 1
            (card≤1→isProp (subst (λ a → a ≤ 1) (sym p) (≤-solver 0 1))) (isProp⊥*))) .fst
      (card≡n p)

  card≡1 : card X ≡ 1 → X ≡ 𝟙
  card≡1 p =
    propTruncIdempotent≃
      (isOfHLevelRespectEquiv
        1 (FinSet≡ X 𝟙)
          (isOfHLevel≡ 1
            (card≤1→isProp (subst (λ a → a ≤ 1) (sym p) (≤-solver 1 1))) (isPropUnit*))) .fst
      (Prop.map (λ q → q ∙ 𝔽in1≡𝟙) (card≡n p))

module _
  (X : FinSet ℓ) where

  isEmpty→card≡0 : ¬ X .fst → card X ≡ 0
  isEmpty→card≡0 p =
    Prop.rec (isSetℕ _ _) (λ e → sym (isEmpty→Fin≡0 _ (p ∘ invEq e))) (∣≃card∣ X)

  isInhab→card>0 : ∥ X .fst ∥ → card X > 0
  isInhab→card>0 = Prop.rec2 m≤n-isProp (λ p x → isInhab→Fin>0 _ (p .fst x)) (∣≃card∣ X)

  hasNonEqualTerm→card>1 : {a b : X. fst} → ¬ a ≡ b → card X > 1
  hasNonEqualTerm→card>1 {a = a} {b = b} q =
    Prop.rec m≤n-isProp (λ p → hasNonEqualTerm→Fin>1 _ (p .fst a) (p .fst b) (q ∘ invEq (congEquiv p))) (∣≃card∣ X)

  isContr→card≡1 : isContr (X .fst) → card X ≡ 1
  isContr→card≡1 p = cardEquiv X (_ , isFinSetUnit) ∣ isContr→≃Unit p ∣

  isProp→card≤1 : isProp (X .fst) → card X ≤ 1
  isProp→card≤1 p = isProp→Fin≤1 (card X) (Prop.rec isPropIsProp (λ e → isOfHLevelRespectEquiv 1 e p) (∣≃card∣ X))

{- formulae about cardinality -}

-- results to be used in direct induction on FinSet

card𝟘 : card (𝟘 {ℓ}) ≡ 0
card𝟘 {ℓ = ℓ} = isEmpty→card≡0 (𝟘 {ℓ}) (Empty.rec*)

card𝟙 : card (𝟙 {ℓ}) ≡ 1
card𝟙 {ℓ = ℓ} = isContr→card≡1 (𝟙 {ℓ}) isContrUnit*

card𝔽in : (n : ℕ) → card (𝔽in {ℓ} n) ≡ n
card𝔽in {ℓ = ℓ} n =  cardEquiv (𝔽in {ℓ} n) (_ , isFinSetFin) ∣ 𝔽in≃Fin n ∣

-- addition/product formula

module _
  (X : FinSet ℓ )
  (Y : FinSet ℓ') where

  card+ : card (_ , isFinSet⊎ X Y) ≡ card X + card Y
  card+ = refl

  card× : card (_ , isFinSet× X Y) ≡ card X · card Y
  card× = refl

-- total summation/product of numerical functions from finite sets

module _
  (X : FinSet ℓ)
  (f : X .fst → ℕ) where

  sum : ℕ
  sum = card (_ , isFinSetΣ X (λ x → Fin (f x) , isFinSetFin))

  prod : ℕ
  prod = card (_ , isFinSetΠ X (λ x → Fin (f x) , isFinSetFin))

module _
  (f : 𝟘 {ℓ} .fst → ℕ) where

  sum𝟘 : sum 𝟘 f ≡ 0
  sum𝟘 =
    isEmpty→card≡0 (_ , isFinSetΣ 𝟘 (λ x → Fin (f x) , isFinSetFin))
                   ((invEquiv (Σ-cong-equiv-fst (invEquiv 𝟘≃Empty)) ⋆ ΣEmpty _) .fst)

  prod𝟘 : prod 𝟘 f ≡ 1
  prod𝟘 =
    isContr→card≡1 (_ , isFinSetΠ 𝟘 (λ x → Fin (f x) , isFinSetFin))
                   (isContrΠ⊥*)

module _
  (f : 𝟙 {ℓ} .fst → ℕ) where

  sum𝟙 : sum 𝟙 f ≡ f tt*
  sum𝟙 =
    cardEquiv (_ , isFinSetΣ 𝟙 (λ x → Fin (f x) , isFinSetFin))
              (Fin (f tt*) , isFinSetFin) ∣ Σ-contractFst isContrUnit* ∣

  prod𝟙 : prod 𝟙 f ≡ f tt*
  prod𝟙 =
    cardEquiv (_ , isFinSetΠ 𝟙 (λ x → Fin (f x) , isFinSetFin))
              (Fin (f tt*) , isFinSetFin) ∣ ΠUnit* _ ∣

module _
  (X : FinSet ℓ )
  (Y : FinSet ℓ')
  (f : X .fst ⊎ Y .fst → ℕ) where

  sum⊎ : sum (_ , isFinSet⊎ X Y) f ≡ sum X (f ∘ inl) + sum Y (f ∘ inr)
  sum⊎ =
    cardEquiv (_ , isFinSetΣ (_ , isFinSet⊎ X Y) (λ x → Fin (f x) , isFinSetFin))
              (_ , isFinSet⊎ (_ , isFinSetΣ X (λ x → Fin (f (inl x)) , isFinSetFin))
                             (_ , isFinSetΣ Y (λ y → Fin (f (inr y)) , isFinSetFin))) ∣ Σ⊎≃ ∣
    ∙ card+ (_ , isFinSetΣ X (λ x → Fin (f (inl x)) , isFinSetFin))
            (_ , isFinSetΣ Y (λ y → Fin (f (inr y)) , isFinSetFin))

  prod⊎ : prod (_ , isFinSet⊎ X Y) f ≡ prod X (f ∘ inl) · prod Y (f ∘ inr)
  prod⊎ =
    cardEquiv (_ , isFinSetΠ (_ , isFinSet⊎ X Y) (λ x → Fin (f x) , isFinSetFin))
              (_ , isFinSet× (_ , isFinSetΠ X (λ x → Fin (f (inl x)) , isFinSetFin))
                             (_ , isFinSetΠ Y (λ y → Fin (f (inr y)) , isFinSetFin))) ∣ Π⊎≃ ∣
    ∙ card× (_ , isFinSetΠ X (λ x → Fin (f (inl x)) , isFinSetFin))
            (_ , isFinSetΠ Y (λ y → Fin (f (inr y)) , isFinSetFin))

-- technical lemma
module _
  (n : ℕ)(f : 𝔽in {ℓ} (1 + n) .fst → ℕ) where

  sum𝔽in1+n : sum (𝔽in (1 + n)) f ≡ f (inl tt*) + sum (𝔽in n) (f ∘ inr)
  sum𝔽in1+n = sum⊎ 𝟙 (𝔽in n) f ∙ (λ i → sum𝟙 (f ∘ inl) i + sum (𝔽in n) (f ∘ inr))

  prod𝔽in1+n : prod (𝔽in (1 + n)) f ≡ f (inl tt*) · prod (𝔽in n) (f ∘ inr)
  prod𝔽in1+n = prod⊎ 𝟙 (𝔽in n) f ∙ (λ i → prod𝟙 (f ∘ inl) i · prod (𝔽in n) (f ∘ inr))

sumConst𝔽in : (n : ℕ)(f : 𝔽in {ℓ} n .fst → ℕ)(c : ℕ)(h : (x : 𝔽in n .fst) → f x ≡ c) → sum (𝔽in n) f ≡ c · n
sumConst𝔽in 0 f c _ = sum𝟘 f ∙ 0≡m·0 c
sumConst𝔽in (suc n) f c h =
    sum𝔽in1+n n f
  ∙ (λ i → h (inl tt*) i + sumConst𝔽in n (f ∘ inr) c (h ∘ inr) i)
  ∙ sym (·-suc c n)

prodConst𝔽in : (n : ℕ)(f : 𝔽in {ℓ} n .fst → ℕ)(c : ℕ)(h : (x : 𝔽in n .fst) → f x ≡ c) → prod (𝔽in n) f ≡ c ^ n
prodConst𝔽in 0 f c _ = prod𝟘 f
prodConst𝔽in (suc n) f c h =
    prod𝔽in1+n n f
  ∙ (λ i → h (inl tt*) i · prodConst𝔽in n (f ∘ inr) c (h ∘ inr) i)

module _
  (X : FinSet ℓ)
  (f : X .fst → ℕ)
  (c : ℕ)(h : (x : X .fst) → f x ≡ c) where

  sumConst : sum X f ≡ c · card X
  sumConst =
    elimProp
      (λ X → (f : X .fst → ℕ)(c : ℕ)(h : (x : X .fst) → f x ≡ c) → sum X f ≡ c · (card X))
      (λ X → isPropΠ3 (λ _ _ _ → isSetℕ _ _))
      (λ n f c h → sumConst𝔽in n f c h ∙ (λ i → c · card𝔽in {ℓ = ℓ} n (~ i))) X f c h

  prodConst : prod X f ≡ c ^ card X
  prodConst =
    elimProp
      (λ X → (f : X .fst → ℕ)(c : ℕ)(h : (x : X .fst) → f x ≡ c) → prod X f ≡ c ^ (card X))
      (λ X → isPropΠ3 (λ _ _ _ → isSetℕ _ _))
      (λ n f c h → prodConst𝔽in n f c h ∙ (λ i → c ^ card𝔽in {ℓ = ℓ} n (~ i))) X f c h

private
  ≡≤ : {m n l k r s : ℕ} → m ≤ n → l ≤ k → r ≡ m + l → s ≡ n + k → r ≤ s
  ≡≤ {m = m} {l = l} {k = k} p q u v = subst2 (_≤_) (sym u) (sym v) (≤-+-≤ p q)

  ≡< : {m n l k r s : ℕ} → m < n → l ≤ k → r ≡ m + l → s ≡ n + k → r < s
  ≡< {m = m} {l = l} {k = k} p q u v = subst2 (_<_) (sym u) (sym v) (<-+-≤ p q)

sum≤𝔽in : (n : ℕ)(f g : 𝔽in {ℓ} n .fst → ℕ)(h : (x : 𝔽in n .fst) → f x ≤ g x) → sum (𝔽in n) f ≤ sum (𝔽in n) g
sum≤𝔽in 0 f g _ = subst2 (_≤_) (sym (sum𝟘 f)) (sym (sum𝟘 g)) ≤-refl
sum≤𝔽in (suc n) f g h =
  ≡≤ (h (inl tt*)) (sum≤𝔽in n (f ∘ inr) (g ∘ inr) (h ∘ inr)) (sum𝔽in1+n n f) (sum𝔽in1+n n g)

sum<𝔽in : (n : ℕ)(f g : 𝔽in {ℓ} n .fst → ℕ)(t : ∥ 𝔽in {ℓ} n .fst ∥)(h : (x : 𝔽in n .fst) → f x < g x)
  → sum (𝔽in n) f < sum (𝔽in n) g
sum<𝔽in {ℓ = ℓ} 0 _ _ t _ = Empty.rec (<→≢ (isInhab→card>0 (𝔽in 0) t) (card𝟘 {ℓ = ℓ}))
sum<𝔽in (suc n) f g t h =
  ≡< (h (inl tt*)) (sum≤𝔽in n (f ∘ inr) (g ∘ inr) (<-weaken ∘ h ∘ inr)) (sum𝔽in1+n n f) (sum𝔽in1+n n g)

module _
  (X : FinSet ℓ)
  (f g : X .fst → ℕ) where

    module _
      (h : (x : X .fst) → f x ≡ g x) where

      sum≡ : sum X f ≡ sum X g
      sum≡ i = sum X (λ x → h x i)

      prod≡ : prod X f ≡ prod X g
      prod≡ i = prod X (λ x → h x i)

    module _
      (h : (x : X .fst) → f x ≤ g x) where

      sum≤ : sum X f ≤ sum X g
      sum≤ =
        elimProp
          (λ X → (f g : X .fst → ℕ)(h : (x : X .fst) → f x ≤ g x) → sum X f ≤ sum X g)
          (λ X → isPropΠ3 (λ _ _ _ → m≤n-isProp)) sum≤𝔽in X f g h

    module _
      (t : ∥ X .fst ∥)
      (h : (x : X .fst) → f x < g x) where

      sum< : sum X f < sum X g
      sum< =
        elimProp
          (λ X → (f g : X .fst → ℕ)(t : ∥ X .fst ∥)(h : (x : X .fst) → f x < g x) → sum X f < sum X g)
          (λ X → isPropΠ4 (λ _ _ _ _ → m≤n-isProp)) sum<𝔽in X f g t h

module _
  (X : FinSet ℓ)
  (f : X .fst → ℕ) where

  module _
    (c : ℕ)(h : (x : X .fst) → f x ≤ c) where

    sumBounded : sum X f ≤ c · card X
    sumBounded = subst (λ a → sum X f ≤ a) (sumConst X (λ _ → c) c (λ _ → refl)) (sum≤ X f (λ _ → c) h)

  module _
    (c : ℕ)(h : (x : X .fst) → f x ≥ c) where

    sumBoundedBelow : sum X f ≥ c · card X
    sumBoundedBelow = subst (λ a → sum X f ≥ a) (sumConst X (λ _ → c) c (λ _ → refl)) (sum≤ X (λ _ → c) f h)

-- some combinatorial identities

module _
  (X : FinSet ℓ )
  (Y : X .fst → FinSet ℓ') where

  cardΣ : card (_ , isFinSetΣ X Y) ≡ sum X (λ x → card (Y x))
  cardΣ =
    cardEquiv (_ , isFinSetΣ X Y) (_ , isFinSetΣ X (λ x → Fin (card (Y x)) , isFinSetFin))
              (Prop.map Σ-cong-equiv-snd
                (choice X (λ x → Y x .fst ≃ Fin (card (Y x))) (λ x → ∣≃card∣ (Y x))))

  cardΠ : card (_ , isFinSetΠ X Y) ≡ prod X (λ x → card (Y x))
  cardΠ =
    cardEquiv (_ , isFinSetΠ X Y) (_ , isFinSetΠ X (λ x → Fin (card (Y x)) , isFinSetFin))
              (Prop.map equivΠCod
                (choice X (λ x → Y x .fst ≃ Fin (card (Y x))) (λ x → ∣≃card∣ (Y x))))

module _
  (X : FinSet ℓ )
  (Y : FinSet ℓ') where

  card→ : card (_ , isFinSet→ X Y) ≡ card Y ^ card X
  card→ = cardΠ X (λ _ → Y) ∙ prodConst X (λ _ → card Y) (card Y) (λ _ → refl)

module _
  (X : FinSet ℓ ) where

  cardAut : card (_ , isFinSetAut X) ≡ LehmerCode.factorial (card X)
  cardAut = refl

module _
  (X : FinSet ℓ )
  (Y : FinSet ℓ')
  (f : X .fst → Y .fst) where

  sumCardFiber : card X ≡ sum Y (λ y → card (_ , isFinSetFiber X Y f y))
  sumCardFiber =
      cardEquiv X (_ , isFinSetΣ Y (λ y → _ , isFinSetFiber X Y f y)) ∣ totalEquiv f ∣
    ∙ cardΣ Y (λ y → _ , isFinSetFiber X Y f y)

-- the pigeonhole priniple

-- a logical lemma
private
  ¬ΠQ→¬¬ΣP : (X : Type ℓ)
      (P : X → Type ℓ' )
      (Q : X → Type ℓ'')
      (r : (x : X) → ¬ (P x) → Q x)
    → ¬ ((x : X) → Q x) → ¬ ¬ (Σ X P)
  ¬ΠQ→¬¬ΣP _ _ _ r g f = g (λ x → r x (λ p → f (x , p)))

module _
  (f : X .fst → Y .fst)
  (n : ℕ) where

  fiberCount : ((y : Y .fst) → card (_ , isFinSetFiber X Y f y) ≤ n) → card X ≤ n · card Y
  fiberCount h =
    subst (λ a → a ≤ _) (sym (sumCardFiber X Y f))
          (sumBounded Y (λ y → card (_ , isFinSetFiber X Y f y)) n h)

  module _
    (p : card X > n · card Y) where

    ¬¬pigeonHole : ¬ ¬ (Σ[ y ∈ Y .fst ] card (_ , isFinSetFiber X Y f y) > n)
    ¬¬pigeonHole =
      ¬ΠQ→¬¬ΣP (Y .fst) (λ y → _ > n) (λ y → _ ≤ n)
               (λ y → <-asym') (λ h → <-asym p (fiberCount h))

    pigeonHole : ∥ Σ[ y ∈ Y .fst ] card (_ , isFinSetFiber X Y f y) > n ∥
    pigeonHole = PeirceLaw (isFinSetΣ Y (λ _ → _ , isDecProp→isFinSet m≤n-isProp (≤Dec _ _))) ¬¬pigeonHole

-- a special case, proved in Cubical.Data.Fin.Properties

-- a technical lemma
private
  Σ∥P∥→∥ΣP∥ : (X : Type ℓ)(P : X → Type ℓ')
    → Σ X (λ x → ∥ P x ∥) → ∥ Σ X P ∥
  Σ∥P∥→∥ΣP∥ _ _ (x , p) = Prop.map (λ q → x , q) p

module _
  (f : X .fst → Y .fst)
  (p : card X > card Y) where

  fiberNonEqualTerm : Σ[ y ∈ Y .fst ] card (_ , isFinSetFiber X Y f y) > 1
    → ∥ Σ[ y ∈ Y .fst ] Σ[ a ∈ fiber f y ] Σ[ b ∈ fiber f y ] ¬ a ≡ b ∥
  fiberNonEqualTerm (y , p) = Σ∥P∥→∥ΣP∥ _ _ (y , card>1→hasNonEqualTerm {X = _ , isFinSetFiber X Y f y} p)

  nonInj : Σ[ y ∈ Y .fst ] Σ[ a ∈ fiber f y ] Σ[ b ∈ fiber f y ] ¬ a ≡ b
    → Σ[ x ∈ X .fst ] Σ[ x' ∈ X .fst ] (¬ x ≡ x') × (f x ≡ f x')
  nonInj (y , (x , p) , (x' , q) , t) .fst = x
  nonInj (y , (x , p) , (x' , q) , t) .snd .fst = x'
  nonInj (y , (x , p) , (x' , q) , t) .snd .snd .fst u =
    t (λ i → u i , isSet→SquareP (λ i j → isFinSet→isSet (Y .snd)) p q (cong f u) refl i)
  nonInj (y , (x , p) , (x' , q) , t) .snd .snd .snd = p ∙ sym q

  pigeonHole' : ∥ Σ[ x ∈ X .fst ] Σ[ x' ∈ X .fst ] (¬ x ≡ x') × (f x ≡ f x') ∥
  pigeonHole' =
    Prop.map nonInj
      (Prop.rec isPropPropTrunc fiberNonEqualTerm
        (pigeonHole {X = X} {Y = Y} f 1 (subst (λ a → _ > a) (sym (·-identityˡ _)) p)))

-- cardinality and injection/surjection

module _
  (X : FinSet ℓ )
  (Y : FinSet ℓ') where

  module _
    (f : X .fst → Y .fst) where

    card↪Inequality' : isEmbedding f → card X ≤ card Y
    card↪Inequality' p =
      subst2 (_≤_)
        (sym (sumCardFiber X Y f))
        (·-identityˡ _)
        (sumBounded Y (λ y → card (_ , isFinSetFiber X Y f y)) 1
          (λ y → isProp→card≤1 (_ , isFinSetFiber X Y f y)
            (isEmbedding→hasPropFibers p y)))

    card↠Inequality' : isSurjection f → card X ≥ card Y
    card↠Inequality' p =
      subst2 (_≥_)
        (sym (sumCardFiber X Y f))
        (·-identityˡ _)
        (sumBoundedBelow Y (λ y → card (_ , isFinSetFiber X Y f y)) 1
          (λ y → isInhab→card>0 (_ , isFinSetFiber X Y f y) (p y)))

  card↪Inequality : ∥ X .fst ↪ Y .fst ∥ → card X ≤ card Y
  card↪Inequality = Prop.rec m≤n-isProp (λ (f , p) → card↪Inequality' f p)

  card↠Inequality : ∥ X .fst ↠ Y .fst ∥ → card X ≥ card Y
  card↠Inequality = Prop.rec m≤n-isProp (λ (f , p) → card↠Inequality' f p)

-- maximal value of numerical functions

module _
  (X : Type ℓ)
  (f : X → ℕ) where

  module _
    (x : X) where

    isMax : Type ℓ
    isMax = (x' : X) → f x' ≤ f x

    isPropIsMax : isProp isMax
    isPropIsMax = isPropΠ (λ _ → m≤n-isProp)

  uniqMax : (x x' : X) → isMax x → isMax x' → f x ≡ f x'
  uniqMax x x' p q = ≤-antisym (q x) (p x')

  ΣMax : Type ℓ
  ΣMax = Σ[ x ∈ X ] isMax x

  ∃Max : Type ℓ
  ∃Max = ∥ ΣMax ∥

  ∃Max→maxValue : ∃Max → ℕ
  ∃Max→maxValue =
    SetElim.rec→Set
      isSetℕ (λ (x , p) → f x)
             (λ (x , p) (x' , q) → uniqMax x x' p q)

-- lemma about maximal value on sum type
module _
  (X : Type ℓ )
  (Y : Type ℓ')
  (f : X ⊎ Y → ℕ) where

  ΣMax⊎-case : ((x , p) : ΣMax X (f ∘ inl))((y , q) : ΣMax Y (f ∘ inr))
    → Trichotomy (f (inl x)) (f (inr y)) → ΣMax (X ⊎ Y) f
  ΣMax⊎-case (x , p) (y , q) (lt r) .fst = inr y
  ΣMax⊎-case (x , p) (y , q) (lt r) .snd (inl x') = ≤-trans (p x') (<-weaken r)
  ΣMax⊎-case (x , p) (y , q) (lt r) .snd (inr y') = q y'
  ΣMax⊎-case (x , p) (y , q) (eq r) .fst = inr y
  ΣMax⊎-case (x , p) (y , q) (eq r) .snd (inl x') = ≤-trans (p x') (_ , r)
  ΣMax⊎-case (x , p) (y , q) (eq r) .snd (inr y') = q y'
  ΣMax⊎-case (x , p) (y , q) (gt r) .fst = inl x
  ΣMax⊎-case (x , p) (y , q) (gt r) .snd (inl x') = p x'
  ΣMax⊎-case (x , p) (y , q) (gt r) .snd (inr y') = ≤-trans (q y') (<-weaken r)

  ∃Max⊎ : ∃Max X (f ∘ inl) → ∃Max Y (f ∘ inr) → ∃Max (X ⊎ Y) f
  ∃Max⊎ = Prop.map2 (λ p q → ΣMax⊎-case p q (_≟_ _ _))

ΣMax𝟙 : (f : 𝟙 {ℓ} .fst → ℕ) → ΣMax _ f
ΣMax𝟙 f .fst = tt*
ΣMax𝟙 f .snd x = _ , cong f (sym (isContrUnit* .snd x))

∃Max𝟙 : (f : 𝟙 {ℓ} .fst → ℕ) → ∃Max _ f
∃Max𝟙 f = ∣ ΣMax𝟙 f ∣

∃Max𝔽in : (n : ℕ)(f : 𝔽in {ℓ} n .fst → ℕ)(x : ∥ 𝔽in {ℓ} n .fst ∥) → ∃Max _ f
∃Max𝔽in {ℓ = ℓ} 0 _ x = Empty.rec (<→≢ (isInhab→card>0 (𝔽in 0) x) (card𝟘 {ℓ = ℓ}))
∃Max𝔽in 1 f _ =
  subst (λ X → (f : X .fst → ℕ) → ∃Max _ f) (sym 𝔽in1≡𝟙) ∃Max𝟙 f
∃Max𝔽in (suc (suc n)) f _ =
  ∃Max⊎ (𝟙 .fst) (𝔽in (suc n) .fst) f (∃Max𝟙 (f ∘ inl)) (∃Max𝔽in (suc n) (f ∘ inr) ∣ * {n = n} ∣)

module _
  (X : FinSet ℓ)
  (f : X .fst → ℕ)
  (x : ∥ X .fst ∥) where

  ∃MaxFinSet : ∃Max _ f
  ∃MaxFinSet =
    elimProp
      (λ X → (f : X .fst → ℕ)(x : ∥ X .fst ∥) → ∃Max _ f)
      (λ X → isPropΠ2 (λ _ _ → isPropPropTrunc)) ∃Max𝔽in X f x

  maxValue : ℕ
  maxValue = ∃Max→maxValue _ _ ∃MaxFinSet

{- some formal consequences of card -}

-- card induces equivalence from set truncation of FinSet to natural numbers

open Iso

Iso-∥FinSet∥₂-ℕ : Iso ∥ FinSet ℓ ∥₂ ℕ
Iso-∥FinSet∥₂-ℕ .fun = Set.rec isSetℕ card
Iso-∥FinSet∥₂-ℕ .inv n = ∣ 𝔽in n ∣₂
Iso-∥FinSet∥₂-ℕ .rightInv n = card𝔽in n
Iso-∥FinSet∥₂-ℕ {ℓ = ℓ} .leftInv =
  Set.elim {B = λ X → ∣ 𝔽in (Set.rec isSetℕ card X) ∣₂ ≡ X}
    (λ X → isSetPathImplicit)
    (elimProp (λ X → ∣ 𝔽in (card X) ∣₂ ≡ ∣ X ∣₂) (λ X → squash₂ _ _)
      (λ n i → ∣ 𝔽in (card𝔽in {ℓ = ℓ} n i) ∣₂))

-- this is the definition of natural numbers you learned from school
∥FinSet∥₂≃ℕ : ∥ FinSet ℓ ∥₂ ≃ ℕ
∥FinSet∥₂≃ℕ = isoToEquiv Iso-∥FinSet∥₂-ℕ

-- FinProp is equivalent to Bool

Bool→FinProp : Bool → FinProp ℓ
Bool→FinProp true = 𝟙 , isPropUnit*
Bool→FinProp false = 𝟘 , isProp⊥*

injBool→FinProp : (x y : Bool) → Bool→FinProp {ℓ = ℓ} x ≡ Bool→FinProp y → x ≡ y
injBool→FinProp true true _ = refl
injBool→FinProp false false _ = refl
injBool→FinProp true false p = Empty.rec (snotz (cong (card ∘ fst) p))
injBool→FinProp false true p = Empty.rec (znots (cong (card ∘ fst) p))

isEmbeddingBool→FinProp : isEmbedding (Bool→FinProp {ℓ = ℓ})
isEmbeddingBool→FinProp = injEmbedding isSetBool isSetFinProp (λ {x} {y} → injBool→FinProp x y)

card-case : (P : FinProp ℓ) → {n : ℕ} → card (P .fst) ≡ n → Σ[ x ∈ Bool ] Bool→FinProp x ≡ P
card-case P {n = 0} p = false , FinProp≡ (𝟘 , isProp⊥*) P .fst (cong fst (sym (card≡0 {X = P .fst} p)))
card-case P {n = 1} p = true , FinProp≡ (𝟙 , isPropUnit*) P .fst (cong fst (sym (card≡1 {X = P .fst} p)))
card-case P {n = suc (suc n)} p =
  Empty.rec (¬-<-zero (pred-≤-pred (subst (λ a → a ≤ 1) p (isProp→card≤1 (P .fst) (P .snd)))))

isSurjectionBool→FinProp : isSurjection (Bool→FinProp {ℓ = ℓ})
isSurjectionBool→FinProp P = ∣ card-case P refl ∣

FinProp≃Bool : FinProp ℓ ≃ Bool
FinProp≃Bool =
  invEquiv (Bool→FinProp ,
    isEmbedding×isSurjection→isEquiv (isEmbeddingBool→FinProp  , isSurjectionBool→FinProp))

isFinSetFinProp : isFinSet (FinProp ℓ)
isFinSetFinProp = EquivPresIsFinSet (invEquiv FinProp≃Bool) isFinSetBool

-- a more computationally efficient version of equivalence type

module _
  (X : FinSet ℓ )
  (Y : FinSet ℓ') where

  isFinSet≃Eff' : Dec (card X ≡ card Y) → isFinSet (X .fst ≃ Y .fst)
  isFinSet≃Eff' (yes p) = factorial (card Y) ,
    Prop.elim2 (λ _ _ → isPropPropTrunc {A = _ ≃ Fin _})
      (λ p1 p2
        → ∣ equivComp (p1 ⋆ pathToEquiv (cong Fin p) ⋆ SumFin≃Fin _) (p2 ⋆ SumFin≃Fin _)
          ⋆ lehmerEquiv ⋆ lehmerFinEquiv
          ⋆ invEquiv (SumFin≃Fin _) ∣)
      (∣≃card∣ X) (∣≃card∣ Y)
  isFinSet≃Eff' (no ¬p) = 0 , ∣ uninhabEquiv (¬p ∘ cardEquiv X Y ∘ ∣_∣) (idfun _) ∣

  isFinSet≃Eff : isFinSet (X .fst ≃ Y .fst)
  isFinSet≃Eff = isFinSet≃Eff' (discreteℕ _ _)

module _
  (X Y : FinSet ℓ) where

  isFinSetType≡Eff : isFinSet (X .fst ≡ Y .fst)
  isFinSetType≡Eff = EquivPresIsFinSet (invEquiv univalence) (isFinSet≃Eff X Y)


module sbconst2 where

open import Level renaming ( suc to succ ; zero to Zero )
open import Data.Nat
open import Data.Fin
open import Data.List

open import automaton
open import nfa
open import logic
open NAutomaton
open Automaton
open import  Relation.Binary.PropositionalEquality hiding ( [_] )

open Bool

δconv : { Q : Set } { Σ : Set  } → ( ( Q → Bool ) → Bool ) →  ( nδ : Q → Σ → Q → Bool ) → (f : Q → Bool) → (i : Σ) → (Q → Bool)
δconv {Q} { Σ} exists nδ f i q =  exists ( λ r → f r /\ nδ r i q )

subset-construction : { Q : Set } { Σ : Set  } →
    ( ( Q → Bool ) → Bool ) →
    (NAutomaton Q  Σ ) → (Automaton (Q → Bool)  Σ )
subset-construction {Q} { Σ}  exists NFA = record {
        δ = λ q x → δconv exists ( Nδ NFA ) q x
     ;  aend = λ f → exists ( λ q → f q /\ Nend NFA q )
   }

test4 = subset-construction existsS1 am2

test51 = accept test4 start1 ( i0  ∷ i1  ∷ i0  ∷ [] )
test61 = accept test4 start1 ( i1  ∷ i1  ∷ i1  ∷ [] )

subset-construction-lemma→ : { Q : Set } { Σ : Set  } → (exists : ( Q → Bool ) → Bool ) →
    (NFA : NAutomaton Q  Σ ) → (astart : Q → Bool )
    → (x : List Σ)
    → Naccept NFA exists astart  x ≡ true
    → accept (  subset-construction exists NFA ) astart  x ≡ true
subset-construction-lemma→ {Q} {Σ}  exists NFA astart x naccept = lemma1 x astart naccept where
    lemma1 :  (x : List Σ) → ( states : Q → Bool )
       → Naccept NFA exists states x ≡ true
       → accept (  subset-construction exists NFA ) states x ≡ true
    lemma1 [] states naccept = naccept
    lemma1 (h ∷ t ) states naccept = lemma1 t (δconv exists (Nδ NFA) states h) naccept

subset-construction-lemma← : { Q : Set } { Σ : Set  }   → (exists : ( Q → Bool ) → Bool ) →
    (NFA : NAutomaton Q  Σ ) → (astart : Q → Bool )
    → (x : List Σ)
    → accept (  subset-construction exists NFA ) astart x ≡ true
    → Naccept NFA exists astart x ≡ true
subset-construction-lemma← {Q} {Σ}  exists NFA astart x saccept = lemma2 x astart saccept where
    lemma2 :  (x : List Σ) → ( states : Q → Bool )
       → accept (  subset-construction exists NFA ) states x ≡ true
       → Naccept NFA exists states x ≡ true
    lemma2 [] states saccept = saccept
    lemma2 (h ∷ t ) states saccept = lemma2 t (δconv exists (Nδ NFA) states h) saccept


-- Category of indexed families
module SOAS.Families.Core {T : Set} where

open import SOAS.Common
open import SOAS.Context {T}
open import SOAS.Sorting {T}

-- | Unsorted

-- Sets indexed by a context
Family : Set₁
Family = Ctx → Set

-- Indexed functions between families
_⇾_ : Family → Family → Set
X ⇾ Y = ∀{Γ : Ctx} → X Γ → Y Γ
infixr 10 _⇾_

-- Category of indexed families of sets and indexed functions between them
𝔽amilies : Category 1ℓ 0ℓ 0ℓ
𝔽amilies = categoryHelper record
  { Obj = Family
  ; _⇒_ = _⇾_
  ; _≈_ = λ {X}{Y} f g → ∀{Γ : Ctx}{x : X Γ} → f x ≡ g x
  ; id = id
  ; _∘_ = λ g f → g ∘ f
  ; assoc = refl
  ; identityˡ = refl
  ; identityʳ = refl
  ; equiv = record { refl = refl ; sym = λ p → sym p ; trans = λ p q → trans p q }
  ; ∘-resp-≈ = λ where {f = f} p q → trans (cong f q) p
  }
module 𝔽am = Category 𝔽amilies

-- | Sorted

-- Category of sorted families
𝔽amiliesₛ : Category 1ℓ 0ℓ 0ℓ
𝔽amiliesₛ = 𝕊orted 𝔽amilies
module 𝔽amₛ = Category 𝔽amiliesₛ

-- Type of sorted families
Familyₛ : Set₁
Familyₛ = 𝔽amₛ.Obj

-- Maps between sorted families
_⇾̣_ : Familyₛ → Familyₛ → Set
_⇾̣_ = 𝔽amₛ._⇒_
infixr 10 _⇾̣_

-- Turn sorted family into unsorted by internally quantifying over the sort
∀[_] : Familyₛ → Family
∀[ 𝒳 ] Γ = {τ : T} → 𝒳 τ Γ

-- Maps between Familyₛ functors
_⇾̣₂_ : (Familyₛ → Familyₛ) → (Familyₛ → Familyₛ) → Set₁
(𝓧 ⇾̣₂ 𝓨) = {𝒵 : Familyₛ} → 𝓧 𝒵 ⇾̣ 𝓨 𝒵


module WeakArrows where

open import Library
open import Categories

record Arrow {l m}(J : Cat {l}{m}) : Set (lsuc (l ⊔ m)) where
  constructor arrow
  open Cat J
  field R      : Obj → Obj → Set m
        pure   : ∀{X Y} -> Hom X Y -> R X Y
        _<<<_  : ∀{X Y Z} → R Y Z -> R X Y -> R X Z
        alaw1  : ∀{X Y Z}(g : Hom Y Z)(f : Hom X Y) ->
                 pure (comp g f) ≅ pure g <<< pure f
        alaw2  : ∀{X Y}(s : R X Y) -> s <<< pure iden ≅ s
        alaw3  : ∀{X Y}(r : R X Y) -> pure iden <<< r ≅ r
        alaw4  : ∀{W X Y Z}(t : R Y Z)(s : R X Y)(r : R W X) ->
                 t <<< (s <<< r) ≅ (t <<< s) <<< r

open import Functors
open import Naturals
open import Categories.Sets
open import YonedaLemma
open import RMonads

module Arrow2RMonad {l m}(C : Cat {l}{m})(A : Arrow C) where
  open Cat C
  open Arrow A

  T : Cat.Obj C -> Fun (C Op) (Sets {m})
  T X = functor
    (λ Y -> R Y X)
    (λ f s -> s <<< pure f)
    (ext alaw2)
    (ext (λ s -> trans (cong (s <<<_) (alaw1 _ _)) (alaw4 _ _ _)))

  η : {X : Obj} -> NatT HomF[-, X ] (T X)
  η = natural pure (ext λ _ -> sym (alaw1 _ _))

  bind : {X Y : Obj} ->
         NatT HomF[-, X ] (T Y) -> NatT (T X) (T Y)
  bind α = natural (λ s -> cmp iden <<< s) (ext λ _ -> sym (alaw4 _ _ _))
    where open NatT α
  -- cmp iden is one direction of the yoneda lemma

  law1 : {X : Obj} → bind (η {X}) ≅ idNat {F = T X}
  law1 = NatTEq (iext (\ _ -> ext alaw3))

  law2 : {X Y : Obj}{f : NatT HomF[-, X ] (T Y)} →
         compNat (bind f) η ≅ f
  law2 {f = f} = NatTEq
    (iext \ _ -> ext \ s -> trans (fcong iden (nat {f = s})) (cong cmp idl))
    where open NatT f

  law3 : {X Y Z : Obj}
         {f : NatT HomF[-, X ] (T Y)} →
         {g : NatT HomF[-, Y ] (T Z)} →
         bind (compNat (bind g) f) ≅ compNat (bind g) (bind f)
  law3 = NatTEq (iext \ W -> ext (\ s -> sym (alaw4 _ _ s)))

  ArrowRMonad : RMonad (y C)
  ArrowRMonad = rmonad
    T
    η
    bind
    law1
    law2
    (λ {_ _ _ f g} -> law3 {f = f}{g = g})

module RMonad2Arrow {l m}(C : Cat {l}{m})(M : RMonad (y C)) where
  open Cat C
  open RMonad M
  open Fun
  open NatT

  R : Obj → Obj → Set m
  R X Y = OMap (T Y) X

  pure : {X Y : Obj} → Hom X Y → R X Y
  pure f = cmp η f

  _<<<_ : ∀{X Y Z} → R Y Z → R X Y → R X Z
  s <<< t = cmp (bind (ylem C (T _) _ s)) t

  alaw1 : ∀{X Y Z}(g : Hom Y Z)(f : Hom X Y) →
          pure (comp g f) ≅ (pure g <<< pure f)
  alaw1 g f = trans
    (sym (fcong g (nat η)))
    (sym (fcong f (ifcong _ (cong cmp law2))))

  alaw2 : ∀{X Y} -> (s : R X Y) → (s <<< pure iden) ≅ s
  alaw2 s = trans
    (fcong iden (ifcong _ (cong cmp law2)))
    (fcong s (fid (T _)))

  alaw3 : ∀{X Y}(r : R X Y) → (pure iden <<< r) ≅ r
  alaw3 r = trans
    (cong (\ α -> cmp (bind α) r)
          (NatTEq (iext \ Z -> ext \ f -> trans
            (fcong iden (nat η))
            (cong (cmp η) idl))))
    (fcong r (ifcong _ (cong cmp law1)))

  alaw4 : ∀{W X Y Z}(t : R Y Z)(s : R X Y)(r : R W X) →
          (t <<< (s <<< r)) ≅ ((t <<< s) <<< r)
  alaw4 t s r = trans
    (sym (fcong r (ifcong _ (cong cmp law3))))
    (cong (\ α -> cmp (bind α) r)
          (NatTEq (iext \ _ -> ext \ _ ->
            sym (fcong s (nat (bind (ylem C (T _) _ t)))))))

  RMonadArrow : Arrow C
  RMonadArrow = arrow
    R
    pure
    _<<<_
    alaw1
    alaw2
    alaw3
    alaw4


module IPC.Metatheory.Hilbert-BasicTarski where

open import IPC.Syntax.Hilbert public
open import IPC.Semantics.BasicTarski public

-- Soundness with respect to all models, or evaluation.

eval : ∀ {A Γ} → Γ ⊢ A → Γ ⊨ A
eval (var i)   γ = lookup i γ
eval (app t u) γ = (eval t γ) (eval u γ)
eval ci        γ = I
eval ck        γ = K
eval cs        γ = S
eval cpair     γ = _,_
eval cfst      γ = π₁
eval csnd      γ = π₂
eval unit      γ = ∙
eval cboom     γ = elim𝟘
eval cinl      γ = ι₁
eval cinr      γ = ι₂
eval ccase     γ = elim⊎

-- Correctness of evaluation with respect to conversion.

eval✓ : ∀ {{_ : Model}} {A Γ} {t t′ : Γ ⊢ A} → t ⋙ t′ → eval t ≡ eval t′
eval✓ refl⋙                         = refl
eval✓ (trans⋙ p q)                  = trans (eval✓ p) (eval✓ q)
eval✓ (sym⋙ p)                      = sym (eval✓ p)
eval✓ (congapp⋙ {A} {B} p q)        = cong² (_⟦$⟧_ {A} {B}) (eval✓ p) (eval✓ q)
eval✓ (congi⋙ p)                    = cong I (eval✓ p)
eval✓ (congk⋙ p q)                  = cong² K (eval✓ p) (eval✓ q)
eval✓ (congs⋙ {A} {B} {C} p q r)    = cong³ (⟦S⟧ {A} {B} {C}) (eval✓ p) (eval✓ q) (eval✓ r)
eval✓ (congpair⋙ {A} {B} p q)       = cong² (_⟦,⟧_ {A} {B}) (eval✓ p) (eval✓ q)
eval✓ (congfst⋙ {A} {B} p)          = cong (⟦π₁⟧ {A} {B}) (eval✓ p)
eval✓ (congsnd⋙ {A} {B} p)          = cong (⟦π₂⟧ {A} {B}) (eval✓ p)
eval✓ (congboom⋙ {C} p)             = cong (⟦elim𝟘⟧ {C}) (eval✓ p)
eval✓ (conginl⋙ {A} {B} p)          = cong (⟦ι₁⟧ {A} {B}) (eval✓ p)
eval✓ (conginr⋙ {A} {B} p)          = cong (⟦ι₂⟧ {A} {B}) (eval✓ p)
eval✓ (congcase⋙ {A} {B} {C} p q r) = cong³ (⟦celim⊎⟧ {A} {B} {C}) (eval✓ p) (eval✓ q) (eval✓ r)
eval✓ beta▻ₖ⋙                       = refl
eval✓ beta▻ₛ⋙                       = refl
eval✓ beta∧₁⋙                       = refl
eval✓ beta∧₂⋙                       = refl
eval✓ eta∧⋙                         = refl
eval✓ eta⊤⋙                        = refl
eval✓ beta∨₁⋙                       = refl
eval✓ beta∨₂⋙                       = refl


_∘_ : {A : Set} {B : A → Set} {C : {x : A} → B x → Set₁} →
      (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
      ((x : A) → C (g x))
f ∘ g = λ x → f (g x)

postulate
  R : {A : Set₁} → A → A → Set₁

_≡_ : {A : Set₁} → A → A → Set₁
_≡_ = R

data D (A : Set) : Set where
  c : A → D A

postulate
  cong  : {A B : Set₁} {x y : A} (f : A → B) → x ≡ y → f x ≡ f y
  refl  : {A : Set₁} {x : A} → x ≡ x
  A     : Set
  P     : D A → Set
  p     : (F : A → Set) → (P ∘ c) ≡ F → (P ∘ c) ≡ F
  eq    : P ≡ P

_ : p (P ∘ c) (cong (_∘ c) eq) ≡ p (P ∘ c) (cong (_∘ c) eq)
_ = cong (λ eq → p _ eq) (cong (cong (_∘ c)) refl)


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

open import LogicalFormulae
open import Groups.Definition
open import Numbers.Naturals.Definition
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Rings.Definition
open import Rings.EuclideanDomains.Definition
open import Fields.Fields
open import Fields.Lemmas

module Rings.EuclideanDomains.Examples where

polynomialField : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} {R : Ring S _+_ _*_} (F : Field R) → (Setoid._∼_ S (Ring.1R R) (Ring.0R R) → False) → EuclideanDomain R
EuclideanDomain.isIntegralDomain (polynomialField F 1!=0) = fieldIsIntDom F
EuclideanDomain.norm (polynomialField F _) a!=0 = zero
EuclideanDomain.normSize (polynomialField F _) a!=0 b!=0 c b=ac = inr refl
DivisionAlgorithmResult.quotient (EuclideanDomain.divisionAlg (polynomialField {_*_ = _*_} F _) {a = a} {b} a!=0 b!=0) with Field.allInvertible F b b!=0
... | bInv , prB = a * bInv
DivisionAlgorithmResult.rem (EuclideanDomain.divisionAlg (polynomialField F _) a!=0 b!=0) = Field.0F F
DivisionAlgorithmResult.remSmall (EuclideanDomain.divisionAlg (polynomialField {S = S} F _) a!=0 b!=0) = inl (Equivalence.reflexive (Setoid.eq S))
DivisionAlgorithmResult.divAlg (EuclideanDomain.divisionAlg (polynomialField {S = S} {R = R} F _) {a = a} {b = b} a!=0 b!=0) with Field.allInvertible F b b!=0
... | bInv , prB = transitive (transitive (transitive (symmetric identIsIdent) (transitive *Commutative (*WellDefined reflexive (symmetric prB)))) *Associative) (symmetric identRight)
  where
    open Setoid S
    open Equivalence eq
    open Ring R
    open Group additiveGroup


open import Nat
open import Prelude
open import List
open import core

-- erasure of cursor in the types and expressions is defined in the paper,
-- and in the core file, as a function on zexpressions. because of the
-- particular encoding of all the judgments as datatypes and the agda
-- semantics for pattern matching, it is sometimes also convenient to have
-- a judgemental form of erasure.
--
-- this file describes the obvious encoding of the view this function as a
-- jugement relating input and output as a datatype, and argues that this
-- encoding is correct by showing a isomorphism with the function. we also
-- show that as a correlary, the judgement is well moded at (∀, ∃!), which
-- is unsurprising if the jugement is written correctly.
--
-- taken together, these proofs allow us to move between the judgemental
-- form of erasure and the function form when it's convenient.
--
-- while we do not have it, the argument given here is sufficiently strong
-- to produce an equality between these things in a system with the
-- univalence axiom, as described in the homotopy type theory book and the
-- associated work done in agda.
module judgemental-erase where

  --cursor erasure for types, as written in the paper
  _◆t : τ̂ → τ̇
  ▹ t ◃ ◆t =  t
  (t1 ==>₁ t2) ◆t = (t1 ◆t) ==> t2
  (t1 ==>₂ t2) ◆t = t1 ==> (t2 ◆t)

  --cursor erasure for expressions, as written in the paper
  _◆e : ê → ė
  ▹ x ◃ ◆e       = x
  (e ·:₁ t) ◆e   = (e ◆e) ·: t
  (e ·:₂ t) ◆e   = e      ·: (t ◆t)
  ·λ x e ◆e      = ·λ x (e ◆e)
  (e1 ∘₁ e2) ◆e  = (e1 ◆e) ∘ e2
  (e1 ∘₂ e2) ◆e  = e1      ∘ (e2 ◆e)
  (e1 ·+₁ e2) ◆e = (e1 ◆e) ·+ e2
  (e1 ·+₂ e2) ◆e = e1      ·+ (e2 ◆e)
  ⦇⌜ e ⌟⦈ ◆e     = ⦇⌜ e ◆e ⌟⦈

  -- this pair of theorems moves from the judgmental form to the function form
  erase-t◆ : {t : τ̂} {tr : τ̇} → (erase-t t tr) → (t ◆t == tr)
  erase-t◆ ETTop       = refl
  erase-t◆ (ETArrL p)  = ap1 (λ x → x ==> _) (erase-t◆ p)
  erase-t◆ (ETArrR p)  = ap1 (λ x → _ ==> x) (erase-t◆ p)

  erase-e◆ : {e : ê} {er : ė} → (erase-e e er) → (e ◆e == er)
  erase-e◆ EETop       = refl
  erase-e◆ (EEAscL p)  with erase-e◆ p
  erase-e◆ (EEAscL p) | refl = refl -- ap1 (λ x → x ·: _)  (erase-e◆ p)
  erase-e◆ (EEAscR p)  = ap1 (λ x → _ ·: x)  (erase-t◆ p)
  erase-e◆ (EELam p)   = ap1 (λ e → ·λ _ e)  (erase-e◆ p)
  erase-e◆ (EEApL p)   = ap1 (λ x → x ∘ _)   (erase-e◆ p)
  erase-e◆ (EEApR p)   = ap1 (λ x → _ ∘ x)   (erase-e◆ p)
  erase-e◆ (EEPlusL p) = ap1 (λ x → x ·+ _)  (erase-e◆ p)
  erase-e◆ (EEPlusR p) = ap1 (λ x → _ ·+ x)  (erase-e◆ p)
  erase-e◆ (EENEHole p) = ap1 (λ x → ⦇⌜ x ⌟⦈) (erase-e◆ p)

  -- this pair of theorems moves back from judgmental form to the function form
  ◆erase-t : (t : τ̂) (tr : τ̇) → (t ◆t == tr) → (erase-t t tr)
  ◆erase-t ▹ x ◃ .x refl = ETTop
  ◆erase-t (t ==>₁ x) (.(t ◆t) ==> .x) refl with ◆erase-t t (t ◆t) refl
  ... | ih = ETArrL ih
  ◆erase-t (x ==>₂ t) (.x ==> .(t ◆t)) refl with ◆erase-t t (t ◆t) refl
  ... | ih = ETArrR ih

  ◆erase-e : (e : ê) (er : ė) → (e ◆e == er) → (erase-e e er)
  ◆erase-e ▹ x ◃ .x refl = EETop
  ◆erase-e (e ·:₁ x) .((e ◆e) ·: x) refl with ◆erase-e e (e ◆e) refl
  ... | ih = EEAscL ih
  ◆erase-e (x ·:₂ x₁) .(x ·: (x₁ ◆t)) refl = EEAscR (◆erase-t x₁ (x₁ ◆t) refl)
  ◆erase-e (·λ x e) .(·λ x (e ◆e)) refl = EELam (◆erase-e e (e ◆e) refl)
  ◆erase-e (e ∘₁ x) .((e ◆e) ∘ x) refl = EEApL (◆erase-e e (e ◆e) refl)
  ◆erase-e (x ∘₂ e) .(x ∘ (e ◆e)) refl = EEApR (◆erase-e e (e ◆e) refl)
  ◆erase-e (e ·+₁ x) .((e ◆e) ·+ x) refl = EEPlusL (◆erase-e e (e ◆e) refl)
  ◆erase-e (x ·+₂ e) .(x ·+ (e ◆e)) refl = EEPlusR (◆erase-e e (e ◆e) refl)
  ◆erase-e ⦇⌜ e ⌟⦈ .(⦇⌜ e ◆e ⌟⦈) refl = EENEHole (◆erase-e e (e ◆e) refl)

  -- jugemental erasure for both types and terms only has one proof for
  -- relating the a term to its non-judgemental erasure
  t-contr : (t : τ̂) → (x y : erase-t t (t ◆t)) → x == y
  t-contr ▹ x ◃ ETTop ETTop = refl
  t-contr (t ==>₁ x) (ETArrL y) (ETArrL z) = ap1 ETArrL (t-contr t y z)
  t-contr (x ==>₂ t) (ETArrR y) (ETArrR z) = ap1 ETArrR (t-contr t y z)

  e-contr : (e : ê) → (x y : erase-e e (e ◆e)) → x == y
  e-contr ▹ x ◃ EETop EETop = refl
  e-contr (e ·:₁ x) (EEAscL x₁) (EEAscL y) = ap1 EEAscL (e-contr e x₁ y)
  e-contr (x₁ ·:₂ x) (EEAscR x₂) (EEAscR x₃) = ap1 EEAscR (t-contr x x₂ x₃)
  e-contr (·λ x e) (EELam x₁) (EELam y) = ap1 EELam (e-contr e x₁ y)
  e-contr (e ∘₁ x) (EEApL x₁) (EEApL y) = ap1 EEApL (e-contr e x₁ y)
  e-contr (x ∘₂ e) (EEApR x₁) (EEApR y) = ap1 EEApR (e-contr e x₁ y)
  e-contr (e ·+₁ x) (EEPlusL x₁) (EEPlusL y) = ap1 EEPlusL (e-contr e x₁ y)
  e-contr (x ·+₂ e) (EEPlusR x₁) (EEPlusR y) = ap1 EEPlusR (e-contr e x₁ y)
  e-contr ⦇⌜ e ⌟⦈ (EENEHole x) (EENEHole y) = ap1 EENEHole (e-contr e x y)

  -- taken together, these four theorems demonstrate that both round-trips
  -- of the above functions are stable up to ==
  erase-trt1 : (t : τ̂) (tr : τ̇) → (x : t ◆t == tr) → (erase-t◆ (◆erase-t t tr x)) == x
  erase-trt1 ▹ x ◃ .x refl = refl
  erase-trt1 (t ==>₁ x) (.(t ◆t) ==> .x) refl with erase-t◆ (◆erase-t t (t ◆t) refl)
  erase-trt1 (t ==>₁ x) (.(t ◆t) ==> .x) refl | refl = refl
  erase-trt1 (x ==>₂ t) (.x ==> .(t ◆t)) refl with erase-t◆ (◆erase-t t (t ◆t) refl)
  erase-trt1 (x ==>₂ t) (.x ==> .(t ◆t)) refl | refl = refl

  erase-trt2 : (t : τ̂) (tr : τ̇) → (x : erase-t t tr) → ◆erase-t t tr (erase-t◆ x) == x
  erase-trt2 .(▹ tr ◃) tr ETTop = refl
  erase-trt2 _ _ (ETArrL ETTop) = refl
  erase-trt2 (t1 ==>₁ t2) _ (ETArrL x) with erase-t◆ x
  erase-trt2 (t1 ==>₁ t2) _ (ETArrL x) | refl = ap1 ETArrL (t-contr _ (◆erase-t t1 (t1 ◆t) refl) x)
  erase-trt2 (t1 ==>₂ t2) _ (ETArrR x) with erase-t◆ x
  erase-trt2 (t1 ==>₂ t2) _ (ETArrR x) | refl = ap1 ETArrR (t-contr _ (◆erase-t t2 (t2 ◆t) refl) x)

  erase-ert1 : (e : ê) (er : ė) → (x : e ◆e == er) → (erase-e◆ (◆erase-e e er x)) == x
  erase-ert1 ▹ x ◃ .x refl = refl
  erase-ert1 (e ·:₁ x) .((e ◆e) ·: x) refl with erase-e◆ (◆erase-e e (e ◆e) refl)
  erase-ert1 (e ·:₁ x) .((e ◆e) ·: x) refl | refl = refl
  erase-ert1 (x ·:₂ t) .(x ·: (t ◆t)) refl =  ap1 (λ a → ap1 (_·:_ x) a) (erase-trt1 t _ refl)
  erase-ert1 (·λ x e) .(·λ x (e ◆e)) refl = ap1 (λ a → ap1 (·λ x) a) (erase-ert1 e _ refl)
  erase-ert1 (e ∘₁ x) .((e ◆e) ∘ x) refl =  ap1 (λ a → ap1 (λ x₁ → x₁ ∘ x) a) (erase-ert1 e _ refl)
  erase-ert1 (x ∘₂ e) .(x ∘ (e ◆e)) refl = ap1 (λ a → ap1 (_∘_ x) a) (erase-ert1 e _ refl)
  erase-ert1 (e ·+₁ x) .((e ◆e) ·+ x) refl = ap1 (λ a → ap1 (λ x₁ → x₁ ·+ x) a) (erase-ert1 e _ refl)
  erase-ert1 (x ·+₂ e) .(x ·+ (e ◆e)) refl = ap1 (λ a → ap1 (_·+_ x) a) (erase-ert1 e _ refl)
  erase-ert1 ⦇⌜ e ⌟⦈ .(⦇⌜ e ◆e ⌟⦈) refl = ap1 (λ a → ap1 ⦇⌜_⌟⦈ a) (erase-ert1 e _ refl)

  erase-ert2 : (e : ê) (er : ė) → (b : erase-e e er) → ◆erase-e e er (erase-e◆ b) == b
  erase-ert2 .(▹ er ◃) er EETop = refl
  erase-ert2 (e ·:₁ x) _ (EEAscL b) with erase-e◆ b
  erase-ert2 (e ·:₁ x) _ (EEAscL b) | refl = ap1 EEAscL (e-contr _ (◆erase-e e (e ◆e) refl) b)
  erase-ert2 (e ·:₂ x) _ (EEAscR b) with erase-t◆ b
  erase-ert2 (e ·:₂ x) .(e ·: (x ◆t)) (EEAscR b) | refl = ap1 EEAscR (t-contr _ (◆erase-t x (x ◆t) refl) b)
  erase-ert2 (·λ x e) _ (EELam b) with erase-e◆ b
  erase-ert2 (·λ x e) .(·λ x (e ◆e)) (EELam b) | refl = ap1 EELam (e-contr e (◆erase-e e (e ◆e) refl) b)
  erase-ert2 (e ∘₁ x) _ (EEApL b) with erase-e◆ b
  erase-ert2 (e ∘₁ x) .((e ◆e) ∘ x) (EEApL b) | refl = ap1 EEApL (e-contr e (◆erase-e e (e ◆e) refl) b)
  erase-ert2 (e1 ∘₂ e) _ (EEApR b) with erase-e◆ b
  erase-ert2 (e1 ∘₂ e) .(e1 ∘ (e ◆e)) (EEApR b) | refl = ap1 EEApR (e-contr e (◆erase-e e (e ◆e) refl) b)
  erase-ert2 (e ·+₁ x) _ (EEPlusL b) with erase-e◆ b
  erase-ert2 (e ·+₁ x) .((e ◆e) ·+ x) (EEPlusL b) | refl = ap1 EEPlusL (e-contr e (◆erase-e e (e ◆e) refl) b)
  erase-ert2 (e1 ·+₂ e) _ (EEPlusR b) with erase-e◆ b
  erase-ert2 (e1 ·+₂ e) .(e1 ·+ (e ◆e)) (EEPlusR b) | refl = ap1 EEPlusR (e-contr e (◆erase-e e (e ◆e) refl) b)
  erase-ert2 ⦇⌜ e ⌟⦈ _ (EENEHole b) with erase-e◆ b
  erase-ert2 ⦇⌜ e ⌟⦈ .(⦇⌜ e ◆e ⌟⦈) (EENEHole b) | refl = ap1 EENEHole (e-contr e (◆erase-e e (e ◆e) refl) b)

  -- since both round trips are stable, these functions demonstrate
  -- isomorphisms between the jugemental and non-judgemental definitions of
  -- erasure
  erase-e-iso : (e : ê) (er : ė) → (e ◆e == er) ≃ (erase-e e er)
  erase-e-iso e er = (◆erase-e e er) , (erase-e◆ , erase-ert1 e er , erase-ert2 e er)

  erase-t-iso : (t : τ̂) (tr : τ̇) → (t ◆t == tr) ≃ (erase-t t tr)
  erase-t-iso t tr = (◆erase-t t tr) , (erase-t◆ , erase-trt1 t tr , erase-trt2 t tr)

  -- this isomorphism supplies the argument that the judgement has mode (∀,
  -- !∃), where uniqueness comes from erase-e◆.
  erase-e-mode : (e : ê) → Σ[ er ∈ ė ] (erase-e e er)
  erase-e-mode e = (e ◆e) , (◆erase-e e (e ◆e) refl)

  -- some translations and lemmas to move between the different
  -- forms. these are not needed to show that this is an ok encoding pair,
  -- but they are helpful when actually using it.

  -- even more specifically, the relation relates an expression to its
  -- functional erasure.
  rel◆t : (t : τ̂) → (erase-t t (t ◆t))
  rel◆t t = ◆erase-t t (t ◆t) refl

  rel◆ : (e : ê) → (erase-e e (e ◆e))
  rel◆ e = ◆erase-e e (e ◆e) refl

  lem-erase-synth : ∀{e e' Γ t} → erase-e e e' → Γ ⊢ e' => t → Γ ⊢ (e ◆e) => t
  lem-erase-synth er wt = tr (λ x → _ ⊢ x => _) (! (erase-e◆ er)) wt

  lem-erase-ana : ∀{e e' Γ t} → erase-e e e' → Γ ⊢ e' <= t → Γ ⊢ (e ◆e) <= t
  lem-erase-ana er wt = tr (λ x → _ ⊢ x <= _) (! (erase-e◆ er)) wt

  lem-synth-erase : ∀{Γ e t e' } → Γ ⊢ e ◆e => t → erase-e e e' → Γ ⊢ e' => t
  lem-synth-erase d1 d2 with erase-e◆ d2
  ... | refl = d1

  eraset-det : ∀{t t' t''} → erase-t t t' → erase-t t t'' → t' == t''
  eraset-det e1 e2 with erase-t◆ e1
  ... | refl = erase-t◆ e2

  erasee-det : ∀{e e' e''} → erase-e e e' → erase-e e e'' → e' == e''
  erasee-det e1 e2 with erase-e◆ e1
  ... | refl = erase-e◆ e2

  erase-in-hole : ∀ {e e'} → erase-e e e' → erase-e ⦇⌜ e ⌟⦈ ⦇⌜ e' ⌟⦈
  erase-in-hole (EENEHole er) = EENEHole (erase-in-hole er)
  erase-in-hole x = EENEHole x

  eq-er-trans : ∀{e e◆ e'} →
                    (e ◆e) == (e' ◆e) →
                    erase-e e e◆ →
                    erase-e e' e◆
  eq-er-trans {e} {e◆} {e'} eq er = tr (λ f → erase-e e' f) (erasee-det (◆erase-e e (e' ◆e) eq) er) (rel◆ e')

  eq-ert-trans : ∀{t t' t1 t2} →
                (t ◆t) == (t' ◆t) →
                erase-t t t1 →
                erase-t t' t2 →
                t1 == t2
  eq-ert-trans eq er1 er2 = ! (erase-t◆ er1) · (eq · (erase-t◆ er2))


-- Operators for combining and building families
module SOAS.Families.Build {T : Set} where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Sorting {T}
open import SOAS.Families.Core {T}

-- | Metavariable contexts

-- Inductive construction of context- and type-indexed sets
data MCtx : Set where
  ⁅⁆      : MCtx
  ⁅_⊩ₙ_⁆_ : (Π : Ctx {T}) → (τ : T) → MCtx → MCtx
infixr 7 ⁅_⊩ₙ_⁆_

-- Pattern synonym for parameterless elements and final elements
infixr 10 ⁅_⁆̣ ⁅_⊩ₙ_⁆̣
infixr 7 ⁅_⁆_ ⁅_⊩_⁆_ ⁅_·_⊩_⁆_ ⁅_⊩_⁆̣ ⁅_·_⊩_⁆̣ _⁅_⊩ₙ_⁆
pattern ⁅_⁆̣ α = ⁅ ∅ ⊩ₙ α ⁆ ⁅⁆
pattern ⁅_⊩ₙ_⁆̣ Π α = ⁅ Π ⊩ₙ α ⁆ ⁅⁆
pattern ⁅_⁆_ τ 𝔐 = ⁅ ∅ ⊩ₙ τ ⁆ 𝔐
pattern ⁅_⊩_⁆_ τ α 𝔐 = ⁅ ⌊ τ ⌋ ⊩ₙ α ⁆ 𝔐
pattern ⁅_·_⊩_⁆_ τ₁ τ₂ α 𝔐 = ⁅ ⌊ τ₁ ∙ τ₂ ⌋ ⊩ₙ α ⁆ 𝔐
pattern ⁅_⊩_⁆̣ τ α = ⁅ ⌊ τ ⌋ ⊩ₙ α ⁆ ⁅⁆
pattern ⁅_·_⊩_⁆̣ τ₁ τ₂ α = ⁅ ⌊ τ₁ ∙ τ₂ ⌋ ⊩ₙ α ⁆ ⁅⁆

-- Add type-context pair to the end of the metavariable context
_⁅_⊩ₙ_⁆ : MCtx → Ctx {T} → T → MCtx
⁅⁆              ⁅ Γ ⊩ₙ α ⁆ = ⁅ Γ ⊩ₙ α ⁆̣
(⁅ Π ⊩ₙ τ ⁆ 𝔐) ⁅ Γ ⊩ₙ α ⁆ = ⁅ Π ⊩ₙ τ ⁆ (𝔐 ⁅ Γ ⊩ₙ α ⁆)

private
  variable
    Γ Δ Θ Π : Ctx
    α β γ τ : T
    𝔐 : MCtx

-- Membership of metavariable contexts
data _⊩_∈_ : Ctx → T → MCtx → Set where
  ↓ : Π ⊩ τ ∈ (⁅ Π ⊩ₙ τ ⁆ 𝔐)
  ↑_ : Π ⊩ τ ∈ 𝔐 → Π ⊩ τ ∈ (⁅ Γ ⊩ₙ α ⁆ 𝔐)

infixr 220 ↑_

-- Metavariable context can be interpreted as a family via the membership
∥_∥ : MCtx → Familyₛ
∥ 𝔐 ∥ α Γ = Γ ⊩ α ∈ 𝔐
infixr 60 ∥_∥

_▷_ : MCtx → (Familyₛ → Familyₛ) → Familyₛ
𝔐 ▷ 𝒳 = 𝒳 ∥ 𝔐 ∥
infix 4 _▷_

-- Generalised sums and pattern matching
data +₂ (A B : Set) : Set where
  _₁ : A → +₂ A B
  _₂ : B → +₂ A B

data +₃ (A B C : Set) : Set where
  _₁ : A → +₃ A B C
  _₂ : B → +₃ A B C
  _₃ : C → +₃ A B C

data +₄ (A B C D : Set) : Set where
  _₁ : A → +₄ A B C D
  _₂ : B → +₄ A B C D
  _₃ : C → +₄ A B C D
  _₄ : D → +₄ A B C D

infixr 60 _₁
infixr 60 _₂
infixr 60 _₃
infixr 60 _₄

₂| : {A B : Set}{X : Set} → (A → X) → (B → X) → (+₂ A B → X)
₂| f g (a ₁) = f a
₂| f g (b ₂) = g b

₃| : {A B C : Set}{X : Set} → (A → X) → (B → X) → (C → X) → (+₃ A B C → X)
₃| f g h (a ₁) = f a
₃| f g h (b ₂) = g b
₃| f g h (c ₃) = h c

₄| : {A B C D : Set}{X : Set} → (A → X) → (B → X) → (C → X) → (D → X) → (+₄ A B C D → X)
₄| f g h e (a ₁) = f a
₄| f g h e (b ₂) = g b
₄| f g h e (c ₃) = h c
₄| f g h e (d ₄) = e d

pattern _ₛ 𝔪 = 𝔪 ₁
pattern _ₘ 𝔪 = 𝔪 ₂
infixr 60 _ₛ
infixr 60 _ₘ

-- Empty and unit families

data Ø : Familyₛ where

data _⊪_ (Γ : Ctx)(α : T) : Familyₛ where
  ● : (Γ ⊪ α) α Γ

⊪_ : T → Familyₛ
⊪ α = ∅ ⊪ α

infix 20 _⊪_
infix 20 ⊪_

-- Sum of families

infix 10 _⊹_
infix 10 _⊹_⊹_
infix 10 _⊹_⊹_⊹_

_⊹_ : Familyₛ → Familyₛ → Familyₛ
(𝒳 ⊹ 𝒴) α Γ = +₂ (𝒳 α Γ) (𝒴 α Γ)

_⊹₁_ : {𝒳₁ 𝒳₂ 𝒴₁ 𝒴₂ : Familyₛ} → (𝒳₁ ⇾̣ 𝒳₂) → (𝒴₁ ⇾̣ 𝒴₂)
     → (𝒳₁ ⊹ 𝒴₁) ⇾̣ (𝒳₂ ⊹ 𝒴₂)
(f ⊹₁ g) (x ₁) = (f x) ₁
(f ⊹₁ g) (y ₂) = (g y) ₂

_⊹_⊹_ : Familyₛ → Familyₛ → Familyₛ → Familyₛ
(𝒳 ⊹ 𝒴 ⊹ 𝒵) α Γ = +₃ (𝒳 α Γ) (𝒴 α Γ) (𝒵 α Γ)

_⊹_⊹_⊹_ : Familyₛ → Familyₛ → Familyₛ → Familyₛ → Familyₛ
(𝒳 ⊹ 𝒴 ⊹ 𝒵 ⊹ 𝒲) α Γ = +₄ (𝒳 α Γ) (𝒴 α Γ) (𝒵 α Γ) (𝒲 α Γ)


{-# OPTIONS --universe-polymorphism #-}
module Categories.Monoidal.Braided.Helpers where

open import Categories.Monoidal.Helpers

open import Data.Nat using (_+_)
open import Function using (flip)

open import Categories.Category
import Categories.Functor

open import Categories.Bifunctor hiding (identityˡ; identityʳ; assoc) renaming (id to idF; _≡_ to _≡F_; _∘_ to _∘F_)
open import Categories.NaturalIsomorphism
open import Categories.NaturalTransformation using (_∘₀_; _∘₁_; _∘ˡ_; _∘ʳ_; NaturalTransformation) renaming (_≡_ to _≡ⁿ_; id to idⁿ)

module BraidedHelperFunctors {o ℓ e} (C : Category o ℓ e) (—⊗— : Bifunctor C C C) (id : Category.Obj C) where
  open MonoidalHelperFunctors C —⊗— id

  private module C = Category C
  open C hiding (id; identityˡ; identityʳ)

  import Categories.Power.NaturalTransformation
  private module PowNat = Categories.Power.NaturalTransformation C
  open PowNat

  private module ⊗ = Functor —⊗— renaming (F₀ to ⊗₀; F₁ to ⊗₁; F-resp-≡ to ⊗-resp-≡)
  open ⊗

  module Braiding (identityˡ : NaturalIsomorphism id⊗x x)
                  (identityʳ : NaturalIsomorphism x⊗id x)
                  (assoc : NaturalIsomorphism [x⊗y]⊗z x⊗[y⊗z])
                  (braid : NaturalIsomorphism x⊗y y⊗x) where
    open NaturalIsomorphism identityˡ using () renaming (F⇒G to υˡ)
    open NaturalIsomorphism identityʳ using () renaming (F⇒G to υʳ)
    open NaturalIsomorphism assoc using () renaming (F⇒G to α; F⇐G to α₂)
    open NaturalIsomorphism braid using () renaming (F⇒G to B)

    α-over : ∀ {n} (F₁ F₂ F₃ : Powerendo n) → NaturalTransformation ((F₁ ⊗₂ F₂) ⊗₂ F₃) (overlap2ʳ —⊗— F₁ F₂ F₃)
    α-over F₁ F₂ F₃ = α ∘ʳ plex {3} F₁ F₂ F₃ -- ((hyp F₁ ∥ hyp F₂) ∥ hyp F₃)

    α₂-over : ∀ {n} (F₁ F₂ F₃ : Powerendo n) → NaturalTransformation (overlap2ʳ —⊗— F₁ F₂ F₃) ((F₁ ⊗₂ F₂) ⊗₂ F₃)
    α₂-over F₁ F₂ F₃ = α₂ ∘ʳ plex {3} F₁ F₂ F₃

    B-over : ∀ {n} (F₁ F₂ : Powerendo n) → NaturalTransformation (F₁ ⊗₂ F₂) (F₂ ⊗₂ F₁)
    B-over F₁ F₂ = B ∘ʳ plex {2} F₁ F₂

    BTriangleTop   : NaturalTransformation id⊗x x⊗id
    BTriangleTop   = B-over (widenˡ 1 id↑) x

    BTriangleLeft  : NaturalTransformation id⊗x x
    BTriangleLeft  = υˡ

    BTriangleRight : NaturalTransformation x⊗id x
    BTriangleRight = υʳ

    Hexagon1TopA    : NaturalTransformation [x⊗y]⊗z x⊗[y⊗z]
    Hexagon1TopA    = α-over (select 0) (select 1) (select 2)
    Hexagon1TopB    : NaturalTransformation x⊗[y⊗z] [y⊗z]⊗x
    Hexagon1TopB    = B-over (select 0) (select 1 ⊗₂ select 2)
    Hexagon1SideB   : NaturalTransformation [y⊗z]⊗x y⊗[z⊗x]
    Hexagon1SideB   = α-over (select 1) (select 2) (select 0)

    Hexagon1SideA   : NaturalTransformation [x⊗y]⊗z [y⊗x]⊗z
    Hexagon1SideA   = B-over (select 0) (select 1) ⊗ⁿ′ id3 {select 2}
    Hexagon1BottomA : NaturalTransformation [y⊗x]⊗z y⊗[x⊗z]
    Hexagon1BottomA = α-over (select 1) (select 0) (select 2)
    Hexagon1BottomB : NaturalTransformation y⊗[x⊗z] y⊗[z⊗x]
    Hexagon1BottomB = id3 {select 1} ⊗ⁿ′ B-over (select 0) (select 2)

    Hexagon2TopA    : NaturalTransformation x⊗[y⊗z] [x⊗y]⊗z
    Hexagon2TopA    = α₂-over (select 0) (select 1) (select 2)
    Hexagon2TopB    : NaturalTransformation [x⊗y]⊗z z⊗[x⊗y]
    Hexagon2TopB    = B-over (select 0 ⊗₂ select 1) (select 2)
    Hexagon2SideB   : NaturalTransformation z⊗[x⊗y] [z⊗x]⊗y
    Hexagon2SideB   = α₂-over (select 2) (select 0) (select 1)

    Hexagon2SideA   : NaturalTransformation x⊗[y⊗z] x⊗[z⊗y]
    Hexagon2SideA   = id3 {select 0} ⊗ⁿ′ B-over (select 1) (select 2)
    Hexagon2BottomA : NaturalTransformation x⊗[z⊗y] [x⊗z]⊗y
    Hexagon2BottomA = α₂-over (select 0) (select 2) (select 1)
    Hexagon2BottomB : NaturalTransformation [x⊗z]⊗y [z⊗x]⊗y
    Hexagon2BottomB = B-over (select 0) (select 2) ⊗ⁿ′ id3 {select 1}


module lambdasyntax where

open import Data.Nat using (ℕ)
open import Data.Bool using (Bool; true; false)
open import Data.Vec using (Vec; []; lookup)
open import Relation.Nullary
open import Data.Empty hiding (⊥)
open import Relation.Binary.PropositionalEquality

data Label : Set where
    ⊤ ⊥ ✭ : Label

data GType : Set where
    bool : Label → GType
    _⇒_  : GType → Label → GType → GType
    err  : GType

infixr 4 _∙_
infixl 6 _∨_ _∧_
data Term : Set where
    var           : ℕ → Term
    litBool       : Bool → Label → Term
    lam           : GType → Term → Label → Term
    _∧_           : Term → Term → Term
    _∨_           : Term → Term → Term
    _∙_           : Term → Term → Term
    if_then_else_ : Term → Term → Term → Term
    error         : Term

Ctx : ℕ → Set
Ctx = Vec GType

getLabel : GType → Label
getLabel (bool ℓ) = ℓ
getLabel ((g ⇒ ℓ) g₁) = ℓ
getLabel err = ✭ -- lazy propagation

setLabel : GType → Label → GType
setLabel (bool _) ℓ = bool ℓ
setLabel ((t ⇒ x) t₁) ℓ = (t ⇒ ℓ) t₁
setLabel err _ = err

-- gradual join
_~⋎~_ : (ℓ₁ ℓ₂ : Label) → Label
⊤ ~⋎~ ⊤ = ⊤
⊤ ~⋎~ ⊥ = ⊤
⊤ ~⋎~ ✭ = ⊤
⊥ ~⋎~ ⊤ = ⊤
⊥ ~⋎~ ⊥ = ⊥
⊥ ~⋎~ ✭ = ✭
✭ ~⋎~ ⊤ = ⊤
✭ ~⋎~ ⊥ = ✭
✭ ~⋎~ ✭ = ✭

-- gradual meet
_~⋏~_ : ∀ (ℓ₁ ℓ₂ : Label) → Label
⊥ ~⋏~ ✭ = ⊥
✭ ~⋏~ ⊥ = ⊥
ℓ₁ ~⋏~ ✭ = ✭
✭ ~⋏~ ℓ₂ = ✭
⊤ ~⋏~ ⊤ = ⊤
⊤ ~⋏~ ⊥ = ⊥
⊥ ~⋏~ ⊤ = ⊥
⊥ ~⋏~ ⊥ = ⊥

_:∧:_ : ∀ (t₁ t₂ : GType) → GType
_:∨:_ : ∀ (t₁ t₂ : GType) → GType
bool ℓ₁ :∧: bool ℓ₂ = bool (ℓ₁ ~⋏~ ℓ₂)
(s₁₁ ⇒ ℓ₁) s₁₂ :∧: (s₂₁ ⇒ ℓ₂) s₂₂ = ((s₁₁ :∨: s₂₁) ⇒ (ℓ₁ ~⋏~ ℓ₂)) (s₁₂ :∧: s₂₂)
_ :∧: _ = err
-- _:∨:_ : ∀ (t₁ t₂ : gtype) → gtype
bool ℓ₁ :∨: bool ℓ₂ = bool (ℓ₁ ~⋎~ ℓ₂)
(s₁₁ ⇒ ℓ₁) s₁₂ :∨: (s₂₁ ⇒ ℓ₂) s₂₂ = ((s₁₁ :∧: s₂₁) ⇒ (ℓ₁ ~⋎~ ℓ₂)) (s₁₂ :∨: s₂₂)
_ :∨: _ = err

data _≤_ : Label → Label → Set where
    ⊥≤⊤ : ⊥ ≤ ⊤
    ⊤≤⊤ : ⊤ ≤ ⊤
    ⊥≤⊥ : ⊥ ≤ ⊥
    ℓ≤✭ : ∀ {ℓ} → ℓ ≤ ✭
    ✭≤ℓ : ∀ {ℓ} → ✭ ≤ ℓ

_≤?_ : (ℓ₁ ℓ₂ : Label) → Dec (ℓ₁ ≤ ℓ₂)
⊤ ≤? ⊤ = yes ⊤≤⊤
⊤ ≤? ⊥ = no (λ ())
⊤ ≤? ✭ = yes (ℓ≤✭)
⊥ ≤? ⊤ = yes ⊥≤⊤
⊥ ≤? ⊥ = yes ⊥≤⊥
⊥ ≤? ✭ = yes (ℓ≤✭)
✭ ≤? ⊤ = yes (✭≤ℓ)
✭ ≤? ⊥ = yes (✭≤ℓ)
✭ ≤? ✭ = yes (ℓ≤✭)

data _≾_ : GType → GType → Set where
    yes : (t₁ t₂ : GType) → t₁ ≾ t₂
    no  : (t₁ t₂ : GType) → t₁ ≾ t₂

_≾?_ : (t₁ t₂ : GType) → t₁ ≾ t₂
bool ℓ ≾? bool ℓ₁ with ℓ ≤? ℓ₁
...      | yes p = yes (bool ℓ) (bool ℓ₁)
...      | no ¬p = no (bool ℓ) (bool ℓ₁)
(t₁ ⇒ ℓ) t₂ ≾? (t₃ ⇒ ℓ₁) t₄ with t₃ ≾? t₁ | t₂ ≾? t₄ | ℓ ≤? ℓ₁
(t₁ ⇒ ℓ) t₂ ≾? (t₃ ⇒ ℓ₁) t₄ | yes .t₃ .t₁ | (yes .t₂ .t₄) | (yes p) = yes ((t₁ ⇒ ℓ) t₂) ((t₃ ⇒ ℓ₁) t₄)

(t₁ ⇒ ℓ) t₂ ≾? (t₃ ⇒ ℓ₁) t₄ | yes .t₃ .t₁ | (yes .t₂ .t₄) | (no ¬p) = no ((t₁ ⇒ ℓ) t₂) ((t₃ ⇒ ℓ₁) t₄)
(t₁ ⇒ ℓ) t₂ ≾? (t₃ ⇒ ℓ₁) t₄ | yes .t₃ .t₁ | (no .t₂ .t₄) | (yes p) = no ((t₁ ⇒ ℓ) t₂) ((t₃ ⇒ ℓ₁) t₄)
(t₁ ⇒ ℓ) t₂ ≾? (t₃ ⇒ ℓ₁) t₄ | yes .t₃ .t₁ | (no .t₂ .t₄) | (no ¬p) = no ((t₁ ⇒ ℓ) t₂) ((t₃ ⇒ ℓ₁) t₄)
(t₁ ⇒ ℓ) t₂ ≾? (t₃ ⇒ ℓ₁) t₄ | no .t₃ .t₁ | (yes .t₂ .t₄) | (yes p) = no ((t₁ ⇒ ℓ) t₂) ((t₃ ⇒ ℓ₁) t₄)
(t₁ ⇒ ℓ) t₂ ≾? (t₃ ⇒ ℓ₁) t₄ | no .t₃ .t₁ | (yes .t₂ .t₄) | (no ¬p) = no ((t₁ ⇒ ℓ) t₂) ((t₃ ⇒ ℓ₁) t₄)
(t₁ ⇒ ℓ) t₂ ≾? (t₃ ⇒ ℓ₁) t₄ | no .t₃ .t₁ | (no .t₂ .t₄) | (yes p) = no ((t₁ ⇒ ℓ) t₂) ((t₃ ⇒ ℓ₁) t₄)
(t₁ ⇒ ℓ) t₂ ≾? (t₃ ⇒ ℓ₁) t₄ | no .t₃ .t₁ | (no .t₂ .t₄) | (no ¬p) = no ((t₁ ⇒ ℓ) t₂) ((t₃ ⇒ ℓ₁) t₄)

-- everything else is no
t₁ ≾? t₂ = no t₁ t₂


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

open import Categories.Category

module Categories.Category.Complete.Properties {o ℓ e} (C : Category o ℓ e) where

open import Level
open import Data.Product
open import Relation.Binary

open import Categories.Category.Complete
open import Categories.Category.Complete.Finitely
open import Categories.Category.Construction.Functors
open import Categories.Diagram.Limit as Lim
open import Categories.Diagram.Limit.Properties
open import Categories.Diagram.Equalizer.Limit C
open import Categories.Diagram.Cone.Properties
open import Categories.Object.Terminal
open import Categories.Object.Product.Limit C
open import Categories.Object.Terminal.Limit C
open import Categories.Functor
open import Categories.Functor.Limits
open import Categories.Functor.Properties
open import Categories.NaturalTransformation
open import Categories.NaturalTransformation.NaturalIsomorphism using (_≃_)

import Categories.Category.Construction.Cones as Co
import Categories.Morphism.Reasoning as MR
import Categories.Morphism as Mor

-- exports
open import Categories.Category.Complete.Properties.Construction public
open import Categories.Category.Complete.Properties.SolutionSet public

private
  variable
    o′ ℓ′ e′ o″ ℓ″ e″ : Level
  module C = Category C

module _ (Com : Complete o′ ℓ′ e′ C) where

  Complete⇒FinitelyComplete : FinitelyComplete C
  Complete⇒FinitelyComplete = record
    { cartesian = record
      { terminal = limit⇒⊥ (Com (⊥⇒limit-F _ _ _))
      ; products = record
        { product = λ {A B} → limit⇒product (Com (product⇒limit-F _ _ _ A B))
        }
      }
    ; equalizer = complete⇒equalizer Com
    }

-- if the base category is complete, then the functor category is complete.
-- in addition, the evaluation functor is continuous.
--
--     Functors-Complete : Complete o″ ℓ″ e″ D^C
--     evalF-Continuous : ∀ X → Continuous o″ ℓ″ e″ (evalF C D X)

module _ {D : Category o′ ℓ′ e′} (Com : Complete o″ ℓ″ e″ D) where
  private
    D^C = Functors C D
    module D^C = Category D^C
    module D   = Category D

    module _ {J : Category o″ ℓ″ e″} (F : Functor J D^C) where
      private
        module J = Category J
        module F = Functor F
        open F
        module F₀ j = Functor (F₀ j)
        module F₁ {a b} (f : a J.⇒ b) = NaturalTransformation (F₁ f)

      ev : C.Obj → Functor D^C D
      ev = evalF C D

      F[-,_] : C.Obj → Functor J D
      F[-, X ] = ev X ∘F F

      F[-,-] : Functor C (Functors J D)
      F[-,-] = record
        { F₀           = F[-,_]
        ; F₁           = λ {A B} f → ntHelper record
          { η       = λ j → F₀.₁ j f
          ; commute = λ {j k} g → begin
            F₀.₁ k f D.∘ F₁.η g A D.∘ F₀.₁ j C.id   ≈⟨ pullˡ (F₁.sym-commute g f) ⟩
            (F₁.η g B D.∘ F₀.₁ j f) D.∘ F₀.₁ j C.id ≈⟨ elimʳ (F₀.identity _) ⟩
            F₁.η g B D.∘ F₀.₁ j f                   ≈⟨ introʳ (F₀.identity _) ⟩∘⟨refl ⟩
            (F₁.η g B D.∘ F₀.₁ j C.id) D.∘ F₀.₁ j f ∎
          }
        ; identity     = F₀.identity _
        ; homomorphism = F₀.homomorphism _
        ; F-resp-≈     = λ eq → F₀.F-resp-≈ _ eq
        }
        where open D.HomReasoning
              open MR D

      module F[-,-] = Functor F[-,-]

      module LimFX X = Limit (Com F[-, X ])
      open LimFX hiding (commute)

      K⇒lim : ∀ {X Y} (f : X C.⇒ Y) K → Co.Cones F[-, Y ] [ nat-map-Cone (F[-,-].₁ f) K , limit Y ]
      K⇒lim f K = rep-cone _ (nat-map-Cone (F[-,-].₁ f) K)

      lim⇒lim : ∀ {X Y} (f : X C.⇒ Y) → Co.Cones F[-, Y ] [ nat-map-Cone (F[-,-].₁ f) (limit X) , limit Y ]
      lim⇒lim f = K⇒lim f (limit _)

      module lim⇒lim {X Y} (f : X C.⇒ Y) = Co.Cone⇒ F[-, Y ] (lim⇒lim f)

      module FCone (K : Co.Cone F) where
        open Co.Cone F K public
        module N   = Functor N
        module ψ j = NaturalTransformation (ψ j)

      module FCone⇒ {K K′ : Co.Cone F} (K⇒K′ : Co.Cone⇒ F K K′) where
        open Co.Cone⇒ F K⇒K′ public
        module arr = NaturalTransformation arr

      FXcone : ∀ X → (K : Co.Cone F) → Co.Cone F[-, X ]
      FXcone X K = record
        { N    = N.₀ X
        ; apex = record
          { ψ       = λ j → ψ.η j X
          ; commute = λ f → D.∘-resp-≈ˡ (elimʳ (F₀.identity _)) ○ commute f
          }
        }
        where open FCone K
              open D.HomReasoning
              open MR D

      ⊤ : Co.Cone F
      ⊤ = record
        { N    = record
          { F₀           = λ X → apex X
          ; F₁           = λ {A B} f → lim⇒lim.arr f
          ; identity     = λ {X} →
            terminal.!-unique X record
            { arr     = D.id
            ; commute = D.identityʳ ○ ⟺ (elimˡ (F₀.identity _))
            }
          ; homomorphism = λ {X Y Z} {f g} →
            terminal.!-unique₂ Z
              {nat-map-Cone (F[-,-].₁ (g C.∘ f)) (limit X)}
              {terminal.! Z}
              {record { commute = λ {j} →
              begin
                proj Z j ∘ lim⇒lim.arr g ∘ lim⇒lim.arr f
                  ≈⟨ pullˡ (lim⇒lim.commute g) ⟩
                (F₀.₁ j g ∘ proj Y j) ∘ lim⇒lim.arr f
                  ≈⟨ pullʳ (lim⇒lim.commute f) ⟩
                F₀.₁ j g ∘ F₀.₁ j f ∘ proj X j
                  ≈˘⟨ pushˡ (F₀.homomorphism j) ⟩
                F₀.₁ j (g C.∘ f) ∘ proj X j
                  ∎ }}
          ; F-resp-≈     = λ {A B} {f g} eq → terminal.!-unique B record
            { commute = lim⇒lim.commute g ○ ∘-resp-≈ˡ (F₀.F-resp-≈ _ (C.Equiv.sym eq)) }
          }
        ; apex = record
          { ψ       = λ j → ntHelper record
            { η       = λ X → proj X j
            ; commute = λ _ → LimFX.commute _
            }
          ; commute = λ f {X} → ∘-resp-≈ˡ (introʳ (F₀.identity _)) ○ limit-commute X f
          }
        }
        where open D
              open D.HomReasoning
              open MR D

      K⇒⊤′ : ∀ X {K} → Co.Cones F [ K , ⊤ ] → Co.Cones F[-, X ] [ FXcone X K , LimFX.limit X ]
      K⇒⊤′ X {K} K⇒⊤ = record
        { arr     = arr.η X
        ; commute = comm
        }
        where open FCone⇒ K⇒⊤ renaming (commute to comm)

      complete : Limit F
      complete = record
        { terminal = record
          { ⊤             = ⊤
          ; ⊤-is-terminal = record
            { !        = λ {K} →
              let module K = FCone K
              in record
              { arr     = ntHelper record
                { η       = λ X → rep X (FXcone X K)
                ; commute = λ {X Y} f →
                  terminal.!-unique₂ Y
                    {nat-map-Cone (F[-,-].₁ f) (FXcone X K)}
                    {record { commute = λ {j} →
                    begin
                      proj Y j ∘ rep Y (FXcone Y K) ∘ K.N.₁ f ≈⟨ pullˡ (LimFX.commute Y) ⟩
                      K.ψ.η j Y ∘ K.N.F₁ f                    ≈⟨ K.ψ.commute j f ⟩
                      F₀.₁ j f ∘ K.ψ.η j X                    ∎ }}
                    {record { commute = λ {j} →
                    begin
                      proj Y j ∘ lim⇒lim.arr f ∘ rep X (FXcone X K) ≈⟨ pullˡ (lim⇒lim.commute f) ⟩
                      (F₀.₁ j f ∘ proj X j) ∘ rep X (FXcone X K)    ≈⟨ pullʳ (LimFX.commute X) ⟩
                      F₀.₁ j f ∘ K.ψ.η j X                          ∎ }}
                }
              ; commute = λ {_} {X} → LimFX.commute X
              }
            ; !-unique = λ K⇒⊤ {X} → terminal.!-unique X (K⇒⊤′ X K⇒⊤)
            }
          }
        }
        where open D
              open D.HomReasoning
              open MR D

      module _ (L : Limit F) (X : C.Obj) where
        module LimExpanded (L : Limit F) where
          private
            module L = Limit L
          open L public
          module apex   = Functor L.apex
          module proj j = NaturalTransformation (L.proj j)

        module L = LimExpanded L
        module complete = LimExpanded complete

        open MR D
        open D.HomReasoning

        cone-iso :  Mor._≅_ (Co.Cones F) complete.limit L.limit
        cone-iso = up-to-iso-cone F complete L
        module cone-iso where
          open Mor._≅_ cone-iso public
          module from where
            open Co.Cone⇒ F from public
            module arr = NaturalTransformation arr
          module to where
            open Co.Cone⇒ F to public
            module arr = NaturalTransformation arr

          ft-iso : Mor._≅_ D^C complete.apex L.apex
          ft-iso = Lim.up-to-iso F complete L
          module ft-iso = Mor._≅_ ft-iso

          apex-iso : ∀ X → Mor._≅_ D (complete.apex.₀ X) (L.apex.₀ X)
          apex-iso X = record
            { from = NaturalTransformation.η ft-iso.from X
            ; to   = NaturalTransformation.η ft-iso.to X
            ; iso  = record
              { isoˡ = ft-iso.isoˡ
              ; isoʳ = ft-iso.isoʳ
              }
            }

        ! : {K : Co.Cone F[-, X ]} → Co.Cone⇒ F[-, X ] K (F-map-Coneˡ (ev X) L.limit)
        ! {K} = record
          { arr     = cone-iso.from.arr.η X D.∘ rep X K
          ; commute = λ {j} → begin
            (L.proj.η j X D.∘ L.apex.₁ C.id) D.∘ cone-iso.from.arr.η X D.∘ rep X K
              ≈⟨ elimʳ L.apex.identity ⟩∘⟨refl ⟩
            L.proj.η j X D.∘ cone-iso.from.arr.η X D.∘ rep X K
              ≈⟨ pullˡ cone-iso.from.commute ⟩
            complete.proj.η j X D.∘ rep X K
              ≈⟨ LimFX.commute X {_} {K} ⟩
            ψ j
              ∎
          }
          where open Co.Cone _ K
        module ! K = Co.Cone⇒ _ (! {K})

        !-unique : {K : Co.Cone F[-, X ]} (f : Co.Cone⇒ F[-, X ] K (F-map-Coneˡ (ev X) L.limit)) →
                   !.arr K D.≈ Co.Cone⇒.arr f
        !-unique {K} f = ⟺ (switch-tofromˡ (cone-iso.apex-iso X) target)
          where open Co.Cone _ K
                module f = Co.Cone⇒ _ f
                target : cone-iso.to.arr.η X D.∘ f.arr D.≈ rep X K
                target = terminal.!-unique₂ X {K}
                         {record
                           { arr     = cone-iso.to.arr.η X D.∘ f.arr
                           ; commute = λ {j} → begin
                             proj X j D.∘ cone-iso.to.arr.η X D.∘ f.arr ≈⟨ pullˡ cone-iso.to.commute ⟩
                             L.proj.η j X D.∘ f.arr                     ≈⟨ introʳ L.apex.identity ⟩∘⟨refl ⟩
                             (L.proj.η j X D.∘ L.apex.₁ C.id) D.∘ f.arr ≈⟨ f.commute ⟩
                             ψ j                                        ∎
                           }}
                         {record
                           { arr     = rep X K
                           ; commute = λ {j} → begin
                             proj X j D.∘ rep X K                       ≈⟨ LimFX.commute X ⟩
                             ψ j                                        ∎
                           }}

        preserves : IsTerminal (Co.Cones F[-, X ]) (F-map-Coneˡ (ev X) L.limit)
        preserves = record
          { !        = !
          ; !-unique = !-unique
          }

  Functors-Complete : Complete o″ ℓ″ e″ D^C
  Functors-Complete = complete

  evalF-Continuous : ∀ X → Continuous o″ ℓ″ e″ (evalF C D X)
  evalF-Continuous X {J} {F} L = preserves F L X


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

open import HoTT
open import homotopy.HSpace
open import homotopy.EM1HSpace
open import homotopy.EilenbergMacLane1 using (EM₁-level₁)
open import lib.types.TwoSemiCategory
open import lib.two-semi-categories.FundamentalCategory

module homotopy.EM1HSpaceAssoc where

module EM₁HSpaceAssoc {i} (G : AbGroup i) where

  private
    module G = AbGroup G
  open EM₁HSpace G public
  private
    module H-⊙EM₁ = HSpaceStructure H-⊙EM₁

  mult-loop-assoc : (g : G.El) (y z : EM₁ G.grp)
    → mult-loop g (mult y z) == ap (λ x' → mult x' z) (mult-loop g y)
  mult-loop-assoc g y z =
    EM₁-prop-elim {P = λ y → mult-loop g (mult y z) == ap (λ x' → mult x' z) (mult-loop g y)}
                  {{λ y → has-level-apply (has-level-apply (EM₁-level₁ G.grp) _ _) _ _}}
                  base' y
    where
    base' : mult-loop g (mult embase z) == ap (λ x' → mult x' z) (mult-loop g embase)
    base' = ! (mult-emloop-β g z)

  H-⊙EM₁-assoc : (x y z : EM₁ G.grp) → mult (mult x y) z == mult x (mult y z)
  H-⊙EM₁-assoc x y z =
    EM₁-set-elim {P = λ x → mult (mult x y) z == mult x (mult y z)}
                 {{λ x → has-level-apply (EM₁-level₁ G.grp) _ _}}
                 idp
                 comp'
                 x
    where
      abstract
        comp' : (g : G.El) → idp == idp [ (λ x → mult (mult x y) z == mult x (mult y z)) ↓ emloop g ]
        comp' g =
          ↓-='-in $
          idp ∙' ap (λ x → mult x (mult y z)) (emloop g)
            =⟨ ∙'-unit-l _ ⟩
          ap (λ x → mult x (mult y z)) (emloop g)
            =⟨ mult-emloop-β g (mult y z) ⟩
          mult-loop g (mult y z)
            =⟨ mult-loop-assoc g y z ⟩
          ap (λ v → mult v z) (mult-loop g y)
            =⟨ ap (ap (λ v → mult v z)) (! (mult-emloop-β g y)) ⟩
          ap (λ v → mult v z) (ap (λ x → mult x y) (emloop g))
            =⟨ ∘-ap (λ v → mult v z) (λ x → mult x y) (emloop g) ⟩
          ap (λ x → mult (mult x y) z) (emloop g)
            =⟨ ! (∙-unit-r _) ⟩
          ap (λ x → mult (mult x y) z) (emloop g) ∙ idp =∎

  H-EM₁-assoc-coh-unit-l : coh-unit-l H-⊙EM₁ H-⊙EM₁-assoc
  H-EM₁-assoc-coh-unit-l x y = =ₛ-in idp

  H-EM₁-assoc-coh-unit-r : coh-unit-r H-⊙EM₁ H-⊙EM₁-assoc
  H-EM₁-assoc-coh-unit-r =
    EM₁-prop-elim {P = λ x → ∀ y → P x y} {{λ x → Π-level (P-level x)}}
      (EM₁-prop-elim {P = P embase} {{P-level embase}} (=ₛ-in idp))
    where
    P : EM₁ G.grp → EM₁ G.grp → Type i
    P = coh-unit-r-eq H-⊙EM₁ H-⊙EM₁-assoc
    P-level : ∀ x y → is-prop (P x y)
    P-level x y = =ₛ-level (EM₁-level₁ G.grp)

  H-EM₁-assoc-coh-unit-l-r-pentagon : coh-unit-l-r-pentagon H-⊙EM₁ H-⊙EM₁-assoc
  H-EM₁-assoc-coh-unit-l-r-pentagon =
    coh-unit-l-to-unit-l-r-pentagon H-⊙EM₁ H-⊙EM₁-assoc H-EM₁-assoc-coh-unit-l

  import homotopy.Pi2HSuspCompose H-⊙EM₁ H-⊙EM₁-assoc H-EM₁-assoc-coh-unit-l-r-pentagon as Pi2EMSuspCompose
  open Pi2EMSuspCompose hiding (comp-functor) public

  abstract
    H-EM₁-assoc-pentagon : coh-assoc-pentagon H-⊙EM₁ H-⊙EM₁-assoc
    H-EM₁-assoc-pentagon w x y z =
      EM₁-prop-elim {P = λ w' → P w' x y z} {{λ w' → P-level w' x y z}}
        (EM₁-prop-elim {P = λ x' → P embase x' y z} {{λ x' → P-level embase x' y z}} (=ₛ-in idp) x)
        w
      where
      P : (w x y z : EM₁ G.grp) → Type i
      P = coh-assoc-pentagon-eq H-⊙EM₁ H-⊙EM₁-assoc
      P-level : ∀ w x y z → is-prop (P w x y z)
      P-level w x y z = =ₛ-level (EM₁-level₁ G.grp)

  EM₁-2-semi-category : TwoSemiCategory lzero i
  EM₁-2-semi-category = HSpace-2-semi-category H-⊙EM₁ H-⊙EM₁-assoc H-EM₁-assoc-pentagon

  comp-functor :
    TwoSemiFunctor
      EM₁-2-semi-category
      (=ₜ-fundamental-cat (Susp (EM₁ G.grp)))
  comp-functor =
    record
    { F₀ = λ _ → [ north ]
    ; F₁ = λ x → [ η x ]
    ; pres-comp = comp
    ; pres-comp-coh = comp-coh
    }
    -- this is *exactly* the same as
    --   `Pi2EMSuspCompose.comp-functor H-EM₁-assoc-pentagon`
    -- inlined but Agda chokes on this shorter definition


{-# OPTIONS --sized-types #-}

module SizedTypesRigidVarClash where

open import Common.Size renaming (↑_ to _^)

data Nat : {size : Size} -> Set where
  zero : {size : Size} -> Nat {size ^}
  suc  : {size : Size} -> Nat {size} -> Nat {size ^}

inc : {i j : Size} -> Nat {i} -> Nat {j ^}
inc x = suc x


module AbsurdLam where

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

data Fin : Nat -> Set where
  fzero : forall {n} -> Fin (suc n)
  fsuc  : forall {n} -> Fin n -> Fin (suc n)

data False : Set where

elimFalse : (A : Set) -> False -> A
elimFalse A = \()

data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

magic : forall {n} -> suc n == zero -> False
magic = \()

hidden : Nat -> {x : Fin zero} -> False
hidden = \n {}


open import Relation.Binary
open import Relation.Binary.PropositionalEquality

module Category.Monad.Monotone.Identity {i}(pre : Preorder i i i) where

open Preorder pre renaming (Carrier to I; _∼_ to _≤_; refl to ≤-refl)

open import Relation.Unary.PredicateTransformer using (Pt)
open import Category.Monad.Monotone pre
open RawMPMonad

Identity : Pt I i
Identity = λ P i → P i

instance
  id-monad : RawMPMonad Identity
  return id-monad px = px
  _≥=_ id-monad c f = f ≤-refl c


------------------------------------------------------------------------
-- If the "Outrageous but Meaningful Coincidences" approach is used to
-- formalise a language, then you can end up with an extensional type
-- theory (with equality reflection)
------------------------------------------------------------------------

module README.DependentlyTyped.Extensional-type-theory where

import Axiom.Extensionality.Propositional as E
open import Data.Empty
open import Data.Product renaming (curry to c)
open import Data.Unit
open import Data.Universe.Indexed
import deBruijn.Context
open import Function hiding (_∋_) renaming (const to k)
import Level
import Relation.Binary.PropositionalEquality as P

------------------------------------------------------------------------
-- A non-indexed universe

mutual

  data U : Set where
    empty : U
    π     : (a : U) (b : El a → U) → U

  El : U → Set
  El empty   = ⊥
  El (π a b) = (x : El a) → El (b x)

Uni : IndexedUniverse _ _ _
Uni = record { I = ⊤; U = λ _ → U; El = El }

------------------------------------------------------------------------
-- Contexts and variables

-- We get these for free.

open deBruijn.Context Uni public
  renaming (_·_ to _⊙_; ·-cong to ⊙-cong)

-- Some abbreviations.

⟨empty⟩ : ∀ {Γ} → Type Γ
⟨empty⟩ = -, λ _ → empty

⟨π⟩ : ∀ {Γ} (σ : Type Γ) → Type (Γ ▻ σ) → Type Γ
⟨π⟩ σ τ = -, k π ˢ indexed-type σ ˢ c (indexed-type τ)

⟨π̂⟩ : ∀ {Γ} (σ : Type Γ) →
      ((γ : Env Γ) → El (indexed-type σ γ) → U) → Type Γ
⟨π̂⟩ σ τ = -, k π ˢ indexed-type σ ˢ τ

------------------------------------------------------------------------
-- Well-typed terms

mutual

  infixl 9 _·_
  infix  3 _⊢_

  -- Terms.

  data _⊢_ (Γ : Ctxt) : Type Γ → Set where
    var : ∀ {σ} (x : Γ ∋ σ) → Γ ⊢ σ
    ƛ   : ∀ {σ τ} (t : Γ ▻ σ ⊢ τ) → Γ ⊢ ⟨π⟩ σ τ
    _·_ : ∀ {σ τ} (t₁ : Γ ⊢ ⟨π̂⟩ σ τ) (t₂ : Γ ⊢ σ) → Γ ⊢ (-, τ ˢ ⟦ t₂ ⟧)

  -- Semantics of terms.

  ⟦_⟧ : ∀ {Γ σ} → Γ ⊢ σ → Value Γ σ
  ⟦ var x   ⟧ γ = lookup x γ
  ⟦ ƛ t     ⟧ γ = λ v → ⟦ t ⟧ (γ , v)
  ⟦ t₁ · t₂ ⟧ γ = (⟦ t₁ ⟧ γ) (⟦ t₂ ⟧ γ)

------------------------------------------------------------------------
-- We can define looping terms (assuming extensionality)

module Looping (ext : E.Extensionality Level.zero Level.zero) where

  -- The casts are examples of the use of equality reflection: the
  -- casts are meta-language constructions, not object-language
  -- constructions.

  cast₁ : ∀ {Γ} →
          Γ ▻ ⟨empty⟩ ⊢ ⟨π⟩ ⟨empty⟩ ⟨empty⟩ → Γ ▻ ⟨empty⟩ ⊢ ⟨empty⟩
  cast₁ t = P.subst (_⊢_ _) (P.cong (_,_ tt) (ext (⊥-elim ∘ proj₂))) t

  cast₂ : ∀ {Γ} →
          Γ ▻ ⟨empty⟩ ⊢ ⟨empty⟩ → Γ ▻ ⟨empty⟩ ⊢ ⟨π⟩ ⟨empty⟩ ⟨empty⟩
  cast₂ t = P.subst (_⊢_ _) (P.cong (_,_ tt) (ext (⊥-elim ∘ proj₂))) t

  ω : ε ▻ ⟨empty⟩ ⊢ ⟨empty⟩
  ω = cast₁ (ƛ (cast₂ (var zero) · var zero))

  -- A simple example of a term which does not have a normal form.

  Ω : ε ▻ ⟨empty⟩ ⊢ ⟨empty⟩
  Ω = cast₂ ω · ω

  const-Ω : ε ⊢ ⟨π⟩ ⟨empty⟩ ⟨empty⟩
  const-Ω = ƛ Ω

-- Some observations:
--
-- * The language with spines (in README.DependentlyTyped.Term) does
--   not support terms like the ones above; in the casts one would
--   have to prove that distinct spines are equal.
--
-- * The spines ensure that the normaliser in
--   README.DependentlyTyped.NBE terminates. The existence of terms
--   like Ω implies that it is impossible to implement a normaliser
--   for the spine-less language defined in this module.


{-
This module contains:
- constant displayed structures of URG structures
- products of URG structures
-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.DStructures.Structures.Constant where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv

open import Cubical.Data.Sigma

open import Cubical.DStructures.Base
open import Cubical.DStructures.Meta.Properties

open import Cubical.Relation.Binary

private
  variable
    ℓA ℓ≅A ℓB ℓ≅B ℓC ℓ≅C ℓ≅A×B : Level

-- The constant displayed structure of a URG structure 𝒮-B over 𝒮-A
𝒮ᴰ-const : {A : Type ℓA} (𝒮-A : URGStr A ℓ≅A)
           {B : Type ℓB} (𝒮-B : URGStr B ℓ≅B)
           → URGStrᴰ 𝒮-A (λ _ → B) ℓ≅B
𝒮ᴰ-const {A = A} 𝒮-A {B} 𝒮-B
  = urgstrᴰ (λ b _ b' → b ≅ b') ρ uni
    where
      open URGStr 𝒮-B

-- the total structure of the constant structure gives
-- nondependent product of URG structures
_×𝒮_ : {A : Type ℓA} (StrA : URGStr A ℓ≅A)
         {B : Type ℓB} (StrB : URGStr B ℓ≅B)
         → URGStr (A × B) (ℓ-max ℓ≅A ℓ≅B)
_×𝒮_ StrA {B} StrB = ∫⟨ StrA ⟩ (𝒮ᴰ-const StrA StrB)

-- any displayed structure defined over a
-- structure on a product can also be defined
-- over the swapped product
×𝒮-swap :  {A : Type ℓA} {B : Type ℓB} {C : A × B → Type ℓC}
         {ℓ≅A×B ℓ≅ᴰ : Level}
         {StrA×B : URGStr (A × B) ℓ≅A×B}
         (StrCᴰ : URGStrᴰ StrA×B C ℓ≅ᴰ)
         → URGStrᴰ (𝒮-transport Σ-swap-≃ StrA×B)
                   (λ (b , a) → C (a , b))
                   ℓ≅ᴰ
×𝒮-swap {C = C} {ℓ≅ᴰ = ℓ≅ᴰ} {StrA×B = StrA×B} StrCᴰ =
  make-𝒮ᴰ (λ c p c' → c ≅ᴰ⟨ p ⟩ c')
              ρᴰ
              λ (b , a) c → isUnivalent→contrRelSingl (λ c c' → c ≅ᴰ⟨ URGStr.ρ StrA×B (a , b) ⟩ c')
                                                        ρᴰ
                                                        uniᴰ
                                                        c
              where
                open URGStrᴰ StrCᴰ


{-# OPTIONS --cubical --safe #-}

module Strict.Properties where

open import Path
open import Level
open import Strict
open import Agda.Builtin.Strict
open import Function

$!-≡ : {A : Type a} {B : A → Type b} → (f : ∀ x → B x) → ∀ x → (f $! x) ≡ f x
$!-≡ f x = builtin-eq-to-path (primForceLemma x f)

$!≡$ : {A : Type a} {B : A → Type b} → _$!_ {A = A} {B = B} ≡ _$_ {A = A} {B = B}
$!≡$ i f x = $!-≡ f x i


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

open import HoTT
open import cw.CW
open import cw.FinCW
open import cw.FinBoundary
open import cohomology.Theory

module cw.cohomology.cochainequiv.DualizedHigherBoundary (OT : OrdinaryTheory lzero)
  {n} (⊙fin-skel : ⊙FinSkeleton (S (S n))) where

open OrdinaryTheory OT

private
  fin-skel = ⊙FinSkeleton.skel ⊙fin-skel
  I = AttachedFinSkeleton.numCells fin-skel

  fin-skel₋₁ = AttachedFinSkeleton.skel fin-skel
  I₋₁ = AttachedFinSkeleton.numCells fin-skel₋₁

abstract
  rephrase-dualized-higher-boundary-in-degree : ∀ g <I
    → GroupIso.g (FreeAbGroup-extend-iso (C2-abgroup 0))
        (GroupIso.f (FreeAbGroup-extend-iso (C2-abgroup 0)) g ∘ᴳ fboundary-last fin-skel) <I
    == Group.sum (C2 0) (λ <I₋₁ → Group.exp (C2 0) (g <I₋₁) (fdegree-last fin-skel <I <I₋₁))
  rephrase-dualized-higher-boundary-in-degree g <I =
    FormalSum-extend (C2-abgroup 0) g (GroupHom.f (fboundary-last fin-skel) fs[ inl <I :: nil ])
      =⟨ ap (FormalSum-extend (C2-abgroup 0) g) $
          app= (is-equiv.g-f (FreeAbGroup-extend-is-equiv (FreeAbGroup (Fin I₋₁))) (fboundary'-last fin-skel)) <I ⟩
    FormalSum-extend (C2-abgroup 0) g
      (Group.sum (FreeAbGroup.grp (Fin I₋₁))
        (λ <I₋₁ → Group.exp (FreeAbGroup.grp (Fin I₋₁)) fs[ inl <I₋₁ :: nil ] (fdegree-last fin-skel <I <I₋₁)))
      =⟨ GroupHom.pres-sum (FreeAbGroup-extend (C2-abgroup 0) g)
          (λ <I₋₁ → Group.exp (FreeAbGroup.grp (Fin I₋₁)) fs[ inl <I₋₁ :: nil ] (fdegree-last fin-skel <I <I₋₁)) ⟩
    Group.sum (C2 0)
      (λ <I₋₁ →
        (FormalSum-extend (C2-abgroup 0) g
          (Group.exp (FreeAbGroup.grp (Fin I₋₁)) fs[ inl <I₋₁ :: nil ] (fdegree-last fin-skel <I <I₋₁))))
      =⟨ ap (Group.sum (C2 0))
          (λ= λ <I₋₁ →
            GroupHom.pres-exp (FreeAbGroup-extend (C2-abgroup 0) g)
              fs[ inl <I₋₁ :: nil ]
              (fdegree-last fin-skel <I <I₋₁)) ⟩
    Group.sum (C2 0)
      (λ <I₋₁ →
        (Group.exp (C2 0)
          (FormalSum-extend (C2-abgroup 0) g fs[ inl <I₋₁ :: nil ])
          (fdegree-last fin-skel <I <I₋₁)))
      =⟨ ap (Group.sum (C2 0))
          (λ= λ <I₋₁ → ap (λ g → Group.exp (C2 0) g (fdegree-last fin-skel <I <I₋₁)) $
            app= (is-equiv.g-f (FreeAbGroup-extend-is-equiv (C2-abgroup 0)) g) <I₋₁) ⟩
    Group.sum (C2 0) (λ <I₋₁ → (Group.exp (C2 0) (g <I₋₁) (fdegree-last fin-skel <I <I₋₁)))
      =∎


module BasicIS4.Metatheory.Hilbert-BasicKripkeOno where

open import BasicIS4.Syntax.Hilbert public
open import BasicIS4.Semantics.BasicKripkeOno public

-- Soundness with respect to all models, or evaluation.

eval : ∀ {A Γ} → Γ ⊢ A → Γ ⊨ A
eval (var i)           γ = lookup i γ
eval (app {A} {B} t u) γ = _⟪$⟫_ {A} {B} (eval t γ) (eval u γ)
eval ci                γ = K I
eval (ck {A} {B})      γ = K (⟪K⟫ {A} {B})
eval (cs {A} {B} {C})  γ = K (⟪S⟫′ {A} {B} {C})
eval (box t)           γ = λ ζ → eval t ∙
eval (cdist {A} {B})   γ = K (_⟪D⟫′_ {A} {B})
eval (cup {A})         γ = K (⟪↑⟫ {A})
eval (cdown {A})       γ = K (⟪↓⟫ {A})
eval (cpair {A} {B})   γ = K (_⟪,⟫′_ {A} {B})
eval cfst              γ = K π₁
eval csnd              γ = K π₂
eval unit              γ = ∙

-- TODO: Correctness of evaluation with respect to conversion.


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.Rationals.HITQ.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Relation.Nullary

open import Cubical.HITs.Ints.QuoInt

open import Cubical.Data.Nat as ℕ hiding (_·_)
open import Cubical.Data.NatPlusOne
open import Cubical.Data.Sigma

-- ℚ as a higher inductive type

data ℚ : Type₀ where
  con : (u : ℤ) (a : ℤ) → ¬ (a ≡ pos 0) → ℚ
  path : ∀ u a v b {p q} → (u · b) ≡ (v · a) → con u a p ≡ con v b q
  trunc : isSet ℚ

[_] : ℤ × ℕ₊₁ → ℚ
[ a , 1+ b ] = con a (pos (suc b)) (ℕ.snotz ∘ cong abs)

-- Natural number and negative integer literals for ℚ

open import Cubical.Data.Nat.Literals public

instance
  fromNatℚ : HasFromNat ℚ
  fromNatℚ = record { Constraint = λ _ → Unit ; fromNat = λ n → [ pos n , 1 ] }

instance
  fromNegℚ : HasFromNeg ℚ
  fromNegℚ = record { Constraint = λ _ → Unit ; fromNeg = λ n → [ neg n , 1 ] }


open import Categories
open import Functors
open import RMonads

module RMonads.REM.Adjunction {a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}}
                              {J : Fun C D}(M : RMonad J)  where

open import Library
open import RAdjunctions
open import RMonads.REM M
open import RMonads.REM.Functors J M

open Fun
open RAdj
open RAlg
open RAlgMorph
open RMonad M
open Cat D

REMAdj : RAdj J EM
REMAdj = record {
  L = REML;
  R = REMR;
  left   = λ f → comp (amor f) η;
  right  = λ{_ B} f → record{
    amor = astr B f;
    ahom = sym (alaw2 B)};
  lawa    = λ {_ Y} f →
    RAlgMorphEq (
      proof
      astr Y (comp (amor f) η)
      ≅⟨ sym (ahom f) ⟩
      comp (amor f) (bind η)
      ≅⟨ cong (comp (amor f)) law1 ⟩
      comp (amor f) iden
      ≅⟨ idr ⟩
      amor f ∎);
  lawb    = λ {_ B} f → sym (alaw1 B);
  natleft = λ f g h →
    proof
    comp (amor g) (comp (comp (amor h) η) (HMap J f))
    ≅⟨ cong (comp (amor g)) ass ⟩
    comp (amor g) (comp (amor h) (comp η (HMap J f)))
    ≅⟨ cong (comp (amor g) ∘ comp (amor h)) (sym law2) ⟩
    comp (amor g) (comp (amor h) (comp (bind (comp η (HMap J f))) η))
    ≅⟨ cong (comp (amor g)) (sym ass) ⟩
    comp (amor g) (comp (comp (amor h) (bind (comp η (HMap J f)))) η)
    ≅⟨ sym ass ⟩
    comp (comp (amor g) (comp (amor h) (bind (comp η (HMap J f))))) η
    ∎;
  natright = λ{W}{X}{Y}{Z} f g h →
    RAlgMorphEq (
      proof
      astr Z (comp (amor g) (comp h (HMap J f)))
      ≅⟨ sym (ahom g) ⟩
      comp (amor g) (astr Y (comp h (HMap J f)))
      ≅⟨ cong (λ h₁ → comp (amor g) (astr Y (comp h₁ (HMap J f)))) (alaw1 Y) ⟩
      comp (amor g) (astr Y (comp (comp (astr Y h) η) (HMap J f)))
      ≅⟨ cong (comp (amor g) ∘ astr Y) ass ⟩
      comp (amor g) (astr Y (comp (astr Y h) (comp η (HMap J f))))
      ≅⟨ cong (comp (amor g)) (alaw2 Y) ⟩
      comp (amor g) (comp (astr Y h) (bind (comp η (HMap J f))))
      ∎)}


module BadTermination where

data N : Set where
  zero : N
  suc  : N -> N

postulate inf : N

data D : N -> Set where
  d₁ : D (suc inf)
  d₂ : D inf

f : (n : N) -> D n -> N
f .inf       d₂ = zero
f .(suc inf) d₁ = f inf d₂


open import Mockingbird.Forest using (Forest)

-- The Forest Without a Name
module Mockingbird.Problems.Chapter16 {b ℓ} (forest : Forest {b} {ℓ}) where

open import Data.Product using (_×_; _,_; ∃-syntax)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Function using (_$_; _⇔_; Equivalence)
open import Relation.Binary using (_Respects_)
open import Relation.Nullary using (¬_)
open import Relation.Unary using (Pred)

open Forest forest
import Mockingbird.Problems.Chapter14 forest as Chapter₁₄
open import Mockingbird.Problems.Chapter15 forest using (⇔-¬)

module _ {s} (Sings : Pred Bird s)
         (respects : Sings Respects _≈_)
         (LEM : ∀ x → Sings x ⊎ ¬ Sings x)
         (e : Bird)
         (law₁ : ∀ {x y} → Sings (e ∙ x ∙ y) → Sings y)
         (law₂ : ∀ {x y} → Sings (e ∙ x ∙ y) ⇔ (¬ Sings x))
         (law₃ : ∀ {x y} → Sings (e ∙ x ∙ y) ⇔ (¬ Sings x × Sings y))
         (law₄ : ∀ x → ∃[ y ] Sings y ⇔ Sings (e ∙ y ∙ x)) where

  IsSilent : Pred Bird s
  IsSilent x = ¬ Sings x

  private
    respects′ : IsSilent Respects _≈_
    respects′ x≈y ¬x-sings y-sings = ¬x-sings $ respects (sym x≈y) y-sings

    LEM′ : ∀ x → IsSilent x ⊎ ¬ IsSilent x
    LEM′ x with LEM x
    ... | inj₁ x-sings = inj₂ λ ¬x-sings → ¬x-sings x-sings
    ... | inj₂ ¬x-sings = inj₁ ¬x-sings

    law₁′ : ∀ {x y} → IsSilent y → IsSilent (e ∙ x ∙ y)
    law₁′ ¬y-sings exy-sings = ¬y-sings $ law₁ exy-sings

    law₂′ : ∀ {x y} → ¬ IsSilent x → IsSilent (e ∙ x ∙ y)
    law₂′ = Equivalence.g $ ⇔-¬ law₂

    law₃′ : ∀ {x y} → IsSilent x → IsSilent (e ∙ x ∙ y) → IsSilent y
    law₃′ {x} {y} ¬x-sings ¬exy-sings y-sings = Equivalence.f (⇔-¬ law₃) ¬exy-sings (¬x-sings , y-sings)

    law₄′ : ∀ x → ∃[ y ] IsSilent y ⇔ IsSilent (e ∙ y ∙ x)
    law₄′ x =
      let (y , y-sings⇔eyx-sings) = law₄ x
      in (y , ⇔-¬ y-sings⇔eyx-sings)

  problem : ∀ x → ¬ Sings x
  problem = Chapter₁₄.problem₁ IsSilent respects′ LEM′ e law₁′ law₂′ law₃′ law₄′


------------------------------------------------------------------------
-- The Agda standard library
--
-- List membership and some related definitions
------------------------------------------------------------------------

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

open import Relation.Binary

module Data.List.Membership.Setoid {c ℓ} (S : Setoid c ℓ) where

open import Function using (_∘_; id; flip)
open import Data.Fin using (Fin; zero; suc)
open import Data.List.Base as List using (List; []; _∷_; length; lookup)
open import Data.List.Relation.Unary.Any
  using (Any; index; map; here; there)
open import Data.Product as Prod using (∃; _×_; _,_)
open import Relation.Unary using (Pred)
open import Relation.Nullary using (¬_)

open Setoid S renaming (Carrier to A)

open Data.List.Relation.Unary.Any using (_∷=_; _─_) public

------------------------------------------------------------------------
-- Definitions

infix 4 _∈_ _∉_

_∈_ : A → List A → Set _
x ∈ xs = Any (x ≈_) xs

_∉_ : A → List A → Set _
x ∉ xs = ¬ x ∈ xs

------------------------------------------------------------------------
-- Operations

mapWith∈ : ∀ {b} {B : Set b}
           (xs : List A) → (∀ {x} → x ∈ xs → B) → List B
mapWith∈ []       f = []
mapWith∈ (x ∷ xs) f = f (here refl) ∷ mapWith∈ xs (f ∘ there)

------------------------------------------------------------------------
-- Finding and losing witnesses

module _ {p} {P : Pred A p} where

  find : ∀ {xs} → Any P xs → ∃ λ x → x ∈ xs × P x
  find (here px)   = (_ , here refl , px)
  find (there pxs) = Prod.map id (Prod.map there id) (find pxs)

  lose : P Respects _≈_ →  ∀ {x xs} → x ∈ xs → P x → Any P xs
  lose resp x∈xs px = map (flip resp px) x∈xs

------------------------------------------------------------------------
-- DEPRECATED
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 0.16

map-with-∈ = mapWith∈
{-# WARNING_ON_USAGE map-with-∈
"Warning: map-with-∈ was deprecated in v0.16.
Please use mapWith∈ instead."
#-}


------------------------------------------------------------------------
-- Simple combinators working solely on and with functions
------------------------------------------------------------------------

module Data.Function where

infixr 9 _∘_ _∘′_ _∘₀_ _∘₁_
infixl 1 _on_ _on₁_
infixl 1 _⟨_⟩_ _⟨_⟩₁_
infixr 0 _-[_]₁-_ _-[_]-_ _$_
infix  0 _∶_ _∶₁_

------------------------------------------------------------------------
-- Types

-- Unary functions on a given set.

Fun₁ : Set → Set
Fun₁ a = a → a

-- Binary functions on a given set.

Fun₂ : Set → Set
Fun₂ a = a → a → a

------------------------------------------------------------------------
-- Functions

_∘_ : {A : Set} {B : A → Set} {C : {x : A} → B x → Set} →
      (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
      ((x : A) → C (g x))
f ∘ g = λ x → f (g x)

_∘′_ : {A B C : Set} → (B → C) → (A → B) → (A → C)
f ∘′ g = _∘_ f g

_∘₀_ : {A : Set} {B : A → Set} {C : {x : A} → B x → Set₁} →
       (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
       ((x : A) → C (g x))
f ∘₀ g = λ x → f (g x)

_∘₁_ : {A : Set₁} {B : A → Set₁} {C : {x : A} → B x → Set₁} →
       (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
       ((x : A) → C (g x))
f ∘₁ g = λ x → f (g x)

id : {a : Set} → a → a
id x = x

id₁ : {a : Set₁} → a → a
id₁ x = x

const : {a b : Set} → a → b → a
const x = λ _ → x

const₁ : {a : Set₁} {b : Set} → a → b → a
const₁ x = λ _ → x

flip : {A B : Set} {C : A → B → Set} →
       ((x : A) (y : B) → C x y) → ((y : B) (x : A) → C x y)
flip f = λ x y → f y x

flip₁ : {A B : Set} {C : A → B → Set₁} →
        ((x : A) (y : B) → C x y) → ((y : B) (x : A) → C x y)
flip₁ f = λ x y → f y x

-- Note that _$_ is right associative, like in Haskell. If you want a
-- left associative infix application operator, use
-- Category.Functor._<$>_, available from
-- Category.Monad.Identity.IdentityMonad.

_$_ : {a : Set} {b : a → Set} → ((x : a) → b x) → ((x : a) → b x)
f $ x = f x

_⟨_⟩_ : {a b c : Set} → a → (a → b → c) → b → c
x ⟨ f ⟩ y = f x y

_⟨_⟩₁_ : {a b : Set} → a → (a → b → Set) → b → Set
x ⟨ f ⟩₁ y = f x y

_on_ : {a b c : Set} → (b → b → c) → (a → b) → (a → a → c)
_*_ on f = λ x y → f x * f y

_on₁_ : {a b : Set} {c : Set₁} → (b → b → c) → (a → b) → (a → a → c)
_*_ on₁ f = λ x y → f x * f y

_-[_]-_ : {a b c d e : Set} →
          (a → b → c) → (c → d → e) → (a → b → d) → (a → b → e)
f -[ _*_ ]- g = λ x y → f x y * g x y

_-[_]₁-_ : {a b : Set} →
           (a → b → Set) → (Set → Set → Set) → (a → b → Set) →
           (a → b → Set)
f -[ _*_ ]₁- g = λ x y → f x y * g x y

-- In Agda you cannot annotate every subexpression with a type
-- signature. This function can be used instead.
--
-- You should think of the colon as being mirrored around its vertical
-- axis; the type comes first.

_∶_ : (A : Set) → A → A
_ ∶ x = x

_∶₁_ : (A : Set₁) → A → A
_ ∶₁ x = x