------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of products
------------------------------------------------------------------------

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

module Data.Product.Properties where

open import Data.Product
open import Function using (_∘_)
open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (yes; no)

------------------------------------------------------------------------
-- Equality

module _ {a b} {A : Set a} {B : A → Set b} where

  ,-injectiveˡ : ∀ {a c} {b : B a} {d : B c} → (a , b) ≡ (c , d) → a ≡ c
  ,-injectiveˡ refl = refl

  -- See also Data.Product.Properties.WithK.,-injectiveʳ.


module Oscar.Data.Term.AlphaConversion.internal {𝔣} (FunctionName : Set 𝔣) where

open import Oscar.Data.Term FunctionName

open import Oscar.Data.Equality
open import Oscar.Data.Fin
open import Oscar.Data.Vec
open import Oscar.Function
open import Oscar.Relation

infixr 19 _◂_ _◂s_

mutual

  _◂_ : ∀ {m n} → m ⟨ Fin ⟩→ n → m ⟨ Term ⟩→ n
  _◂_ f (i 𝑥) = i (f 𝑥)
  _◂_ f leaf = leaf
  _◂_ f (τ₁ fork τ₂) = (f ◂ τ₁) fork (f ◂ τ₂)
  _◂_ f (function 𝑓 τs) = function 𝑓 (f ◂s τs)

  _◂s_ : ∀ {m n} → m ⟨ Fin ⟩→ n → ∀ {N} → m ⟨ Terms N ⟩→ n
  _◂s_ f [] = []
  _◂s_ f (τ ∷ τs) = f ◂ τ ∷ f ◂s τs

mutual

  ◂-identity : ∀ {m} (τ : Term m) → id ◂ τ ≡ τ
  ◂-identity (i _) = refl
  ◂-identity leaf = refl
  ◂-identity (τ₁ fork τ₂) rewrite ◂-identity τ₁ | ◂-identity τ₂ = refl
  ◂-identity (function 𝑓 τs) rewrite ◂s-identity τs = refl

  ◂s-identity : ∀ {N m} (τs : Terms N m) → id ◂s τs ≡ τs
  ◂s-identity [] = refl
  ◂s-identity (τ ∷ τs) rewrite ◂-identity τ | ◂s-identity τs = refl

mutual

  ◂-associativity : ∀ {l m n} (f : l ⟨ Fin ⟩→ m) (g : m ⟨ Fin ⟩→ n) → (τ : Term l) → (g ∘ f) ◂ τ ≡ g ◂ f ◂ τ
  ◂-associativity _ _ (i _) = refl
  ◂-associativity _ _ leaf = refl
  ◂-associativity f g (τ₁ fork τ₂) rewrite ◂-associativity f g τ₁ | ◂-associativity f g τ₂ = refl
  ◂-associativity f g (function 𝑓 τs) rewrite ◂s-associativity f g τs = refl

  ◂s-associativity : ∀ {l m n} (f : l ⟨ Fin ⟩→ m) (g : m ⟨ Fin ⟩→ n) → ∀ {N} (x : Terms N l) → (g ∘ f) ◂s x ≡ g ◂s f ◂s x
  ◂s-associativity _ _ [] = refl
  ◂s-associativity f g (τ ∷ τs) rewrite ◂-associativity f g τ | ◂s-associativity f g τs = refl

mutual

  ◂-extensionality : ∀ {m n} {f g : m ⟨ Fin ⟩→ n} → f ≡̇ g → f ◂_ ≡̇ g ◂_
  ◂-extensionality f≡̇g (i 𝑥) rewrite f≡̇g 𝑥 = refl
  ◂-extensionality f≡̇g leaf = refl
  ◂-extensionality f≡̇g (τ₁ fork τ₂) rewrite ◂-extensionality f≡̇g τ₁ | ◂-extensionality f≡̇g τ₂ = refl
  ◂-extensionality f≡̇g (function 𝑓 τs) rewrite ◂s-extensionality f≡̇g τs = refl

  ◂s-extensionality : ∀ {m n} {f g : m ⟨ Fin ⟩→ n} → f ≡̇ g → ∀ {N} → _◂s_ f {N} ≡̇ _◂s_ g {N}
  ◂s-extensionality _ [] = refl
  ◂s-extensionality f≡̇g (τ ∷ τs) rewrite ◂-extensionality f≡̇g τ | ◂s-extensionality f≡̇g τs = refl


------------------------------------------------------------------------
-- Weakening for the NBE values
------------------------------------------------------------------------

import Axiom.Extensionality.Propositional as E
import Level
open import Data.Universe

-- The code makes use of the assumption that propositional equality of
-- functions is extensional.

module README.DependentlyTyped.NBE.Weakening
  (Uni₀ : Universe Level.zero Level.zero)
  (ext : E.Extensionality Level.zero Level.zero)
  where

open import Data.Product renaming (curry to c)
open import deBruijn.Substitution.Data
open import Function.Base hiding (_∋_)
import README.DependentlyTyped.NBE.Value as Value
open Value Uni₀ renaming ([_] to [̌_])
import README.DependentlyTyped.NormalForm as NF
open NF Uni₀ renaming ([_] to [_]n)
import README.DependentlyTyped.NormalForm.Substitution as NFS
open NFS Uni₀
import README.DependentlyTyped.Term as Term; open Term Uni₀
import Relation.Binary.PropositionalEquality as P

open P.≡-Reasoning

mutual

  -- Weakening.

  w̌k[_] : ∀ {Γ} σ τ → V̌alue Γ τ → V̌alue (Γ ▻ σ) (τ /̂ ŵk)
  w̌k[ _ ] (⋆     , τ) t       =   t /⊢n Renaming.wk
  w̌k[ _ ] (el    , τ) [ t ]el = [ t /⊢n Renaming.wk ]el
  w̌k[ σ ] (π _ _ , τ) f       =
    (λ Γ₊ → proj₁ f (σ ◅ Γ₊)) , w̌k-π-well-behaved τ f

  w̌k : ∀ {Γ σ} τ → V̌alue Γ τ → V̌alue (Γ ▻ σ) (τ /̂ ŵk)
  w̌k τ v = w̌k[ _ ] τ v

  abstract

    -- The Π case of weakening is well-behaved.

    w̌k-π-well-behaved :
      ∀ {Γ σ sp₁ sp₂} τ (f : V̌alue Γ (π sp₁ sp₂ , τ)) →
      W̌ell-behaved sp₁ sp₂ (τ /̂I ŵk) (λ Γ₊ → proj₁ f (σ ◅ Γ₊))
    w̌k-π-well-behaved {σ = σ} τ f Γ₊ v =
      let lemma = begin
            [ ⟦̌ τ /̂I ŵk ∣ (λ Γ₊ → proj₁ f (σ ◅ Γ₊)) ⟧-π /̂Val ŵk₊ Γ₊ ]  ≡⟨ /̂Val-cong (P.sym $ w̌eaken-corresponds-π τ f) P.refl ⟩
            [ ⟦̌_⟧ {σ = τ} f /̂Val ŵk[ σ ] /̂Val ŵk₊ Γ₊                ]  ≡⟨ P.refl ⟩
            [ ⟦̌ τ ∣ proj₁ f ⟧-π /̂Val ŵk₊ (σ ◅ Γ₊)                   ]  ∎

      in begin
      [ (⟦̌ τ /̂I ŵk ∣ (λ Γ₊ → proj₁ f (σ ◅ Γ₊)) ⟧-π /̂Val ŵk₊      Γ₊ ) ˢ ⟦̌ v ⟧ ]  ≡⟨ ˢ-cong lemma P.refl ⟩
      [ (⟦̌ τ       ∣         proj₁ f           ⟧-π /̂Val ŵk₊ (σ ◅ Γ₊)) ˢ ⟦̌ v ⟧ ]  ≡⟨ proj₂ f (σ ◅ Γ₊) v ⟩
      [ ⟦̌ proj₁ f (σ ◅ Γ₊) v ⟧                                                ]  ∎

    -- The Π case of weakening weakens.

    w̌eaken-corresponds-π :
      ∀ {Γ σ sp₁ sp₂} τ (f : V̌alue Γ (π sp₁ sp₂ , τ)) →
        ⟦̌_⟧ {σ = τ} f /̂Val ŵk[ σ ] ≅-Value
        ⟦̌ τ /̂I ŵk ∣ (λ Γ₊ → proj₁ f (σ ◅ Γ₊)) ⟧-π
    w̌eaken-corresponds-π {σ = σ} τ f =
      let f̌ = ⟦̌_⟧ {σ = τ} f

      in begin
      [ f̌ /̂Val ŵk[ σ ]                                            ]  ≡⟨ P.refl ⟩
      [ c ((f̌ /̂Val ŵk₊ (σ ◅ fst τ /̂ ŵk ◅ ε)) ˢ lookup zero)       ]  ≡⟨ curry-cong $
                                                                          ˢ-cong (P.refl {x = [ f̌ /̂Val ŵk₊ (σ ◅ fst τ /̂ ŵk ◅ ε) ]})
                                                                                (P.sym $ ňeutral-to-normal-identity _ _) ⟩
      [ c ((f̌ /̂Val ŵk₊ (σ ◅ fst τ /̂ ŵk ◅ ε)) ˢ ⟦ žero _ _ ⟧n)     ]  ≡⟨ curry-cong $ proj₂ f (σ ◅ fst τ /̂ ŵk ◅ ε) _ ⟩
      [ c ⟦̌ proj₁ f (σ ◅ fst τ /̂ ŵk ◅ ε) (řeflect _ (var zero)) ⟧ ]  ≡⟨ P.sym $ unfold-⟦̌∣⟧-π (τ /̂I ŵk) (λ Γ₊ → proj₁ f (σ ◅ Γ₊)) ⟩
      [ ⟦̌ τ /̂I ŵk ∣ (λ Γ₊ → proj₁ f (σ ◅ Γ₊)) ⟧-π                 ]  ∎

-- Weakening.

w̌eaken : ∀ {Γ} {σ : Type Γ} → [ V̌al ⟶ V̌al ] ŵk[ σ ]
w̌eaken = record
  { function    = w̌k
  ; corresponds = corr
  }
  where
  abstract

    -- Weakening weakens.

    corr : ∀ {Γ σ} τ (v : V̌alue Γ τ) →
           ⟦̌ v ⟧ /̂Val ŵk[ σ ] ≅-Value ⟦̌ w̌k[ σ ] τ v ⟧
    corr (⋆         , τ) t       = t /⊢n-lemma Renaming.wk
    corr (el        , τ) [ t ]el = t /⊢n-lemma Renaming.wk
    corr (π sp₁ sp₂ , τ) f       = w̌eaken-corresponds-π τ f

-- Variables can be turned into values.

v̌ar : [ Var ⟶⁼ V̌al ]
v̌ar = record
  { function    = λ _ x → řeflect _ (var x)
  ; corresponds = λ _ x → P.sym $ ňeutral-to-normal-identity _ (var x)
  }

-- Values can be turned into terms.
--
-- This definition uses the assumption that propositional equality of
-- functions is extensional. I don't know how much work is required to
-- avoid this assumption, or if it is even possible to do so.

V̌al↦Tm : V̌al ↦ Tm
V̌al↦Tm = record
  { trans = record
    { function    = λ _ v → ⌊ řeify _ v ⌋
    ; corresponds = λ _ _ → P.refl
    }
  ; simple = record
    { weaken     = w̌eaken
    ; var        = v̌ar
    ; weaken-var = w̌eaken-v̌ar _
    }
  }
  where
  open Renaming hiding (var)

  abstract
    w̌eaken-v̌ar : ∀ {Γ σ} τ (x : Γ ∋ τ) →
                 w̌k[ σ ] τ (v̌ar ⊙ x) ≅-V̌alue v̌ar ⊙ suc[ σ ] x
    w̌eaken-v̌ar (⋆ , τ) x = begin
      [̌ var (x /∋ wk) ]  ≡⟨ ≅-⊢n-⇒-≅-Value-⋆ $ var-n-cong $ ≅-⊢-⇒-≅-∋ $ /∋-wk x ⟩
      [̌ var (suc x)   ]  ∎
    w̌eaken-v̌ar (el , τ) x =  begin
      [̌ [ var (x /∋ wk) ]el ]  ≡⟨ ≅-⊢n-⇒-≅-Value-el $ var-n-cong $ ≅-⊢-⇒-≅-∋ $ /∋-wk x ⟩
      [̌ [ var (suc x)   ]el ]  ∎
    w̌eaken-v̌ar {σ = σ} (π _ _ , τ) x = ,-cong ext λ Γ₊ v → begin
      [̌ řeflect _ ((var x /⊢n wk₊ (σ ◅ Γ₊)) · řeify _ v) ]  ≡⟨ řeflect-cong $
                                                                 ·n-cong (var-n-cong $ ≅-⊢-⇒-≅-∋ $ /∋-wk₊-◅ x Γ₊)
                                                                         (P.refl {x = [ řeify _ v ]n}) ⟩
      [̌ řeflect _ ((var (suc x) /⊢n wk₊ Γ₊) · řeify _ v) ]  ∎

module V̌al-subst = _↦_ V̌al↦Tm


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

module Equiv where

open import Agda.Builtin.Cubical.Glue public
  using ( isEquiv
        ; equiv-proof
        ; _≃_)

open import Cubical.Foundations.Everything public using (ua)
open import Cubical.Foundations.Equiv public
  using (equivToIso; isPropIsEquiv)
  renaming (compEquiv to trans-≃; invEquiv to sym-≃)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Classes where

open import Cubical.Core.Everything

------------------------------------------------------------------------
-- Conversion typeclasses

-- | A typeclass to coerce values of A to some other type. The coercion used is
-- | only dependent on the input type, so the output type does not need to be inferable.
-- |
-- | Coersion should mainly be used for any case where there is only one
-- | unambiguous possible conversion that can happen to some object, such as
-- | the coersions of algebras to their carrier types.
record Coerce {a} (A : Type a) : Typeω where
  field
    b : Level
    Target : Type b
    coerce : A → Target

open Coerce {{...}} using (coerce)

-- | An operator synonym for the typeclass method `coerce`.
⟨_⟩ = coerce

instance
  -- Used for any case where sigma types are used to encode types with structure
  ΣCoerce : ∀ {ℓ ℓ′} {A : Type ℓ} {P : A → Type ℓ′} → Coerce (Σ A P)
  ΣCoerce = record { coerce = fst }

-- | A typeclass used to cast values of A to values of B. The cast performed is
-- | based on both the input and output types, so both need to be inferable.
record Cast {a b} (A : Type a) (B : Type b) : Type (ℓ-max a b) where
  field
    cast : A → B

open Cast {{...}}

-- | An operator synonym for the typeclass method `coerce`.
[_] = cast

------------------------------------------------------------------------
-- Homomorphism typeclasses

-- | A typeclass for function/equivalence types that respect
-- | some structure. The input types are different to allow for
-- | universe polymorphism.
record HomOperators {a b} (A : Type a) (B : Type b) ℓ
          : Type (ℓ-max (ℓ-max a b) (ℓ-suc ℓ)) where
  field
    _⟶ᴴ_ : A → B → Type ℓ
    _≃ᴴ_ : A → B → Type ℓ

open HomOperators {{...}} public


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

{- *** Definition 5.3 and Lemma 5.5 are taken from the library ***
   *** Corollary 6.8 is too trivial a consequence of -}

{- ConnectednessAlt and the last submodule of Connection are the
   only modules importing real truncation types from the library.
   Except for that, Univalence is the only additional assumption
   to Agda-style MLTT we work with. -}
module Universe.index where

{- General utility funcions and type constructors for
   the pseudo-universe of types of fixed truncation level. -}
import Universe.Utility.General
import Universe.Utility.TruncUniverse

{- Pointed types.
   Corresponds to section 4 plus some lemmata of section 5,
   which are used in multiple modules and thus belong here. -}
-- *** Definitions 4.1, 4.3, 4.5, 4.6 and Lemmata 4.5, 4.7, 5.1, 5.4 ***
import Universe.Utility.Pointed

{- Homotopically complicated types.
   Corresponds to section 5 sans the initial lemma.
   Concludes with the main theorem that the n-types
   in the n-th universe from a strict n-type.
   Hierarchy and Trunc.* are mutually independent. -}
{- *** Lemmata 5.2, 5.7, 5.8(*), Theorems 5.9, 5.11, and Corollary 5.6 ***
       (*) a slightly weaker version -}
import Universe.Hierarchy

{- Connectedness constructions
   Corresponds to section 6 and 7.
   The first three modules develop a framework of
   truncations internal to MLTT+Univalence without truncations.
   Connection contains the main result of section 6.
   ConnectednessAlt is independent from the first four modules
   and presents a provably equivalent definition of n-connectedness
   using only propositional truncation (as remarked in the article
   and mentioned in an exercise in the HoTT book). -}

--- *** Definition 6.2, Lemma 6.6
import Universe.Trunc.Universal

--- *** Definition 6.4, Lemma 6.7 ***
import Universe.Trunc.Basics

--- *** Lemmata 6.9, 6.10
import Universe.Trunc.TypeConstructors

--- *** Definitions 6.11, 6.13, Lemmata 6.12, 6.14, 6.15
import Universe.Trunc.Connection
import Universe.Trunc.ConnectednessAlt


------------------------------------------------------------------------
-- The Agda standard library
--
-- Floating point numbers
------------------------------------------------------------------------

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

module Data.Float where

------------------------------------------------------------------------
-- Re-export base definitions and decidability of equality

open import Data.Float.Base public
open import Data.Float.Properties using (_≈?_; _<?_; _≟_; _==_) public


{-# OPTIONS --cubical --safe #-}
module Cubical.Modalities.Modality where

{-
  translated from
  https://github.com/HoTT/HoTT-Agda/blob/master/core/lib/types/Modality.agda
-}

open import Cubical.Core.Everything
open import Cubical.Foundations.Everything

record Modality ℓ : Type (ℓ-suc ℓ) where
  field
    isModal : Type ℓ → Type ℓ
    isModalIsProp : {A : Type ℓ} → isProp (isModal A)

    ◯ : Type ℓ → Type ℓ                                  -- \ciO
    ◯-isModal : {A : Type ℓ} → isModal (◯ A)

    η : {A : Type ℓ} → A → ◯ A

    ◯-elim : {A : Type ℓ} {B : ◯ A → Type ℓ}
      (B-modal : (x : ◯ A) → isModal (B x))
      → ((x : A) → (B (η x))) → ((x : ◯ A) → B x)

    ◯-elim-β : {A : Type ℓ} {B : ◯ A → Type ℓ}
      (B-modal : (x : ◯ A) → isModal (B x)) (f : (x : A) → (B (η x)))
      → (a : A) → ◯-elim B-modal f (η a) ≡ f a

    ◯-=-isModal : {A : Type ℓ} (x y : ◯ A) → isModal (x ≡ y)

  ◯-Types : Type (ℓ-suc ℓ)
  ◯-Types = Σ[ A ∈ Type ℓ ] isModal A

  {- elimination rules -}

  module ◯Elim {A : Type ℓ} {B : ◯ A → Type ℓ}
    (B-modal : (x : ◯ A) → isModal (B x)) (η* : (x : A) → (B (η x))) where
      f : (x : ◯ A) → B x
      f = ◯-elim B-modal η*
      η-β : (a : A) → ◯-elim B-modal η* (η a) ≡ η* a
      η-β = ◯-elim-β B-modal η*

  module ◯Rec {A : Type ℓ} {B : Type ℓ}
         (B-modal : isModal B) (η* : A → B)
      = ◯Elim (λ _ → B-modal) η*

  ◯-rec = ◯Rec.f
  ◯-rec-β = ◯Rec.η-β

  {- functoriality -}

  module ◯Fmap {A B : Type ℓ} (f : A → B) =
      ◯Rec ◯-isModal (η ∘ f)

  ◯-map = ◯Fmap.f
  ◯-map-β = ◯Fmap.η-β

  ◯-preservesEquiv : {A B : Type ℓ} (f : A → B) → isEquiv f → isEquiv (◯-map f)
  ◯-preservesEquiv f f-ise = isoToIsEquiv (iso _ (◯-map inv) to-from from-to) where
    open Iso (equivToIso (f , f-ise))
    abstract
      to-from : ∀ ◯b → ◯-map f (◯-map inv ◯b) ≡ ◯b
      to-from = ◯-elim
        (λ ◯b → ◯-=-isModal (◯-map f (◯-map inv ◯b)) ◯b)
        (λ b → cong (◯-map f) (◯-map-β inv b) ∙ ◯-map-β f (inv b) ∙ cong η (rightInv b))
      from-to : ∀ ◯a → ◯-map inv (◯-map f ◯a) ≡ ◯a
      from-to = ◯-elim
          (λ ◯a → ◯-=-isModal (◯-map inv (◯-map f ◯a)) ◯a)
          (λ a → cong (◯-map inv) (◯-map-β f a) ∙ ◯-map-β inv (f a) ∙ cong η (leftInv a))

  ◯-equiv : {A B : Type ℓ} → A ≃ B → ◯ A ≃ ◯ B
  ◯-equiv (f , f-ise) = ◯-map f , ◯-preservesEquiv f f-ise

  {- equivalences preserve being modal -}

  equivPreservesIsModal : {A B : Type ℓ} → A ≃ B → isModal A → isModal B
  equivPreservesIsModal eq = fst (pathToEquiv (cong isModal (ua eq)))

  {- modal types and [η] being an equivalence -}

  isModalToIsEquiv : {A : Type ℓ} → isModal A → isEquiv (η {A})
  isModalToIsEquiv {A} w =  isoToIsEquiv (iso (η {A}) η-inv inv-l inv-r)
       where η-inv : ◯ A → A
             η-inv = ◯-rec w (idfun A)

             abstract
               inv-r : (a : A) → η-inv (η a) ≡ a
               inv-r = ◯-rec-β w (idfun A)

               inv-l : (a : ◯ A) → η (η-inv a) ≡ a
               inv-l = ◯-elim (λ a₀ → ◯-=-isModal _ _)
                              (λ a₀ → cong η (inv-r a₀))

  abstract
    isEquivToIsModal : {A : Type ℓ} → isEquiv (η {A}) → isModal A
    isEquivToIsModal {A} eq = equivPreservesIsModal (invEquiv (η , eq)) ◯-isModal

    retractIsModal : {A B : Type ℓ} (w : isModal A)
        (f : A → B) (g : B → A) (r : (b : B) → f (g b) ≡ b) →
        isModal B
    retractIsModal {A} {B} w f g r =
      isEquivToIsModal
        (isoToIsEquiv (iso η η-inv inv-l inv-r))
      where η-inv : ◯ B → B
            η-inv = f ∘ (◯-rec w g)

            inv-r : (b : B) → η-inv (η b) ≡ b
            inv-r b = cong f (◯-rec-β w g b) ∙ r b

            inv-l : (b : ◯ B) → η (η-inv b) ≡ b
            inv-l = ◯-elim (λ b → ◯-=-isModal _ _) (λ b → cong η (inv-r b))

  {- function types with modal codomain are modal -}

  abstract
    Π-isModal : {A : Type ℓ} {B : A → Type ℓ}
              (w : (a : A) → isModal (B a)) → isModal ((x : A) → B x)
    Π-isModal {A} {B} w = retractIsModal {◯ _} {(x : A) → B x} ◯-isModal η-inv η r

        where η-inv : ◯ ((x : A) → B x) → (x : A) → B x
              η-inv φ' a = ◯-rec (w a) (λ φ → φ a) φ'

              r : (φ : (x : A) →  B x) → η-inv (η φ) ≡ φ
              r φ = funExt (λ a → ◯-rec-β (w a) (λ φ₀ → φ₀ a) φ)

    →-isModal : {A B : Type ℓ} → isModal B → isModal (A → B)
    →-isModal w = Π-isModal (λ _ → w)

  {- sigma types of a modal dependent type with modal base are modal -}

  abstract
    Σ-isModal : {A : Type ℓ} (B : A → Type ℓ)
      → isModal A → ((a : A) → isModal (B a))
      → isModal (Σ A B)
    Σ-isModal {A} B A-modal B-modal =
      retractIsModal {◯ (Σ A B)} {Σ A B} ◯-isModal η-inv η r

      where h : ◯ (Σ A B) → A
            h = ◯-rec A-modal fst

            h-β : (x : Σ A B) → h (η x) ≡ fst x
            h-β = ◯-rec-β A-modal fst

            f : (j : I) → (x : Σ A B) → B (h-β x j)
            f j x = transp (λ i → B (h-β x ((~ i) ∨ j))) j (snd x)

            k : (y : ◯ (Σ A B)) → B (h y)
            k = ◯-elim (B-modal ∘ h) (f i0)

            η-inv : ◯ (Σ A B) → Σ A B
            η-inv y = h y , k y

            p : (x : Σ A B) → k (η x) ≡ f i0 x
            p = ◯-elim-β (B-modal ∘ h) (f i0)

            almost : (x : Σ A B) → (h (η x) , f i0 x) ≡ x
            almost x i = h-β x i , f i x

            r : (x : Σ A B) → η-inv (η x) ≡ x
            r x = (λ i → h (η x) , p x i) ∙ (almost x)


module Helper.CodeGeneration where

open import Agda.Primitive
open import Data.Nat
open import Data.Fin
open import Data.List
open import Function using (_∘_ ; _$_ ; _∋_)
open import Reflection

a : {A : Set} -> (x : A) -> Arg A
a x = arg (arg-info visible relevant) x

a1 : {A : Set} -> (x : A) -> Arg A
a1 x = arg (arg-info hidden relevant) x

t0 : Term -> Type
t0 t = el (lit 0) t

fin_term : (n : ℕ) -> Term
fin_term zero = con (quote Fin.zero) []
fin_term (suc fin) = con (quote Fin.suc) [ a (fin_term fin) ]

fin_pat : (n : ℕ) -> (l : Pattern) -> Pattern
fin_pat zero l = l
fin_pat (suc n) l = con (quote Fin.suc) [ a (fin_pat n l) ]

fin_type : (n : ℕ) -> Type
fin_type n = t0 (def (quote Fin) [ a (lit (nat n)) ])

-- Annotate terms with a type
_∋-t_ : Term -> Term -> Term
_∋-t_ ty term = def (quote _∋_) (a ty ∷ a term ∷ [])

cons : (n : Name) -> List Name
cons n with (definition n)
cons n | data-type d = reverse (constructors d)
cons n | _ = []

infer_type = el (lit 0) unknown


module Section6 where

open import Section5 public

-- 6. Application to terms
-- =======================
--
-- In practice we may not want to work with proof trees but rather well-typed terms.  As an
-- application of the results above we show how to give semantics to a formulation of Martin-
-- Löf’s substitution calculus [13, 20] in the simply typed setting.  In this calculus we have a
-- set of untyped terms, `𝕋`, and we define when a term in `𝕋` is well-typed and when two terms
-- of a given type are convertible with each other.
--
-- In order to give semantics to untyped terms, we first define an erasure function that
-- translates a proof tree `M` to an untyped term, denoted `M ⁻`.  The main theorem is then to prove
-- that if two proof trees `M, N` erase to the same term, `M ⁻ ≡ N ⁻`, then `M ≅ N`; it follows that
-- `M` and `N` have the same semantics.  For this we first prove that `nf M ⁻ ≡ nf N ⁻` implies
-- `M ≅ N`.  We also define a reduction on the untyped terms `Γ ⊢ t₁ ⇓ t₂ ∷ A` that is deterministic
-- (i.e., if `Γ ⊢ t ⇓ t₁ ∷ A` and `Γ ⊢ t ⇓ t₂ ∷ A`, then `t₁ ≡ t₂`) such that `Γ ⊢ M ⁻ ⇓ nf M ⁻ ∷ A`.
-- We then prove that if a proof tree `M` erases to a well-typed term `t`, then `t ⇓ nf M ⁻`.  Now,
-- if two proof trees `M` and `N` erase to the same well-typed term `t`, then `t ⇓ nf M ⁻` and
-- `t ⇓ nf N ⁻`.  Since the reduction is deterministic we have that `nf M ⁻` and `nf N ⁻` are the
-- same, and hence `M ≅ N`.  The idea of this proof comes from Streicher [19] (chapter IV).

-- 6.1. Definition of terms
-- ------------------------
--
-- We mutually define the set of terms, `𝕋 : Set`, and substitutions, `𝕊 : Set`.  (…)

mutual
  data 𝕋 : Set where
    ν   : Name → 𝕋
    ƛ   : Name → 𝕋 → 𝕋
    _∙_ : 𝕋 → 𝕋 → 𝕋
    _▶_ : 𝕋 → 𝕊 → 𝕋

  data 𝕊 : Set where
    []      : 𝕊
    [_,_≔_] : 𝕊 → Name → 𝕋 → 𝕊
    _●_     : 𝕊 → 𝕊 → 𝕊

-- 6.2. Typing rules
-- -----------------
--
-- We give the typing rules for terms and substitutions mutually inductively.  (…)

mutual
  infix 3 _⊢_∷_
  data _⊢_∷_ : 𝒞 → 𝕋 → 𝒯 → Set where
    ↑⟨_⟩⊢∷ : ∀ {Γ Δ A t} →
                Γ ⊇ Δ → Δ ⊢ t ∷ A →
                Γ ⊢ t ∷ A
    ν       : ∀ {Γ A} →
                (x : Name) → Γ ∋ x ∷ A →
                Γ ⊢ ν x ∷ A
    ƛ       : ∀ {Γ A B t} →
                (x : Name) {{_ : T (fresh x Γ)}} → [ Γ , x ∷ A ] ⊢ t ∷ B →
                Γ ⊢ ƛ x t ∷ A ⊃ B
    _∙_     : ∀ {Γ A B t₁ t₂} →
                Γ ⊢ t₁ ∷ A ⊃ B → Γ ⊢ t₂ ∷ A →
                Γ ⊢ t₁ ∙ t₂ ∷ B
    _▶_     : ∀ {Γ Δ A s t} →
                Δ ⊢ t ∷ A → Γ ⋙ s ∷ Δ →
                Γ ⊢ t ▶ s ∷ A

  infix 3 _⋙_∷_
  data _⋙_∷_ : 𝒞 → 𝕊 → 𝒞 → Set where
    ↑⟨_⟩⋙∷ : ∀ {Γ Δ Θ s} →
                Θ ⊇ Γ → Γ ⋙ s ∷ Δ →
                Θ ⋙ s ∷ Δ
    ↓⟨_⟩⋙∷ : ∀ {Γ Δ Θ s} →
                Δ ⊇ Θ → Γ ⋙ s ∷ Δ →
                Γ ⋙ s ∷ Θ
    refl⋙∷ : ∀ {Γ} →
                Γ ⋙ [] ∷ Γ
    [_,_≔_] : ∀ {Γ Δ A s t} →
                Γ ⋙ s ∷ Δ → (x : Name) {{_ : T (fresh x Δ)}} → Γ ⊢ t ∷ A →
                Γ ⋙ [ s , x ≔ t ] ∷ [ Δ , x ∷ A ]
    _●_     : ∀ {Γ Δ Θ s₁ s₂} →
                Δ ⋙ s₂ ∷ Θ → Γ ⋙ s₁ ∷ Δ →
                Γ ⋙ s₂ ● s₁ ∷ Θ

module _ where
  instance
    raise⊢∷ : ∀ {A t} → Raiseable (_⊢ t ∷ A)
    raise⊢∷ = record { ↑⟨_⟩ = ↑⟨_⟩⊢∷ }

    raise⋙∷ : ∀ {Γ s} → Raiseable (_⋙ s ∷ Γ)
    raise⋙∷ = record { ↑⟨_⟩ = ↑⟨_⟩⋙∷ }

    lower⋙∷ : ∀ {Δ s} → Lowerable (Δ ⋙ s ∷_)
    lower⋙∷ = record { ↓⟨_⟩ = ↓⟨_⟩⋙∷ }

-- 6.3. Convertibility of terms
-- ----------------------------
--
-- We mutually inductively define when two terms are convertible with each other together
-- with the definition of convertibility between substitutions.  (…)

mutual
  infix 3 _⊢_≊_∷_
  data _⊢_≊_∷_ : 𝒞 → 𝕋 → 𝕋 → 𝒯 → Set where
    refl≊  : ∀ {Γ A t} →
               Γ ⊢ t ≊ t ∷ A
    sym≊   : ∀ {Γ A t t′} →
               Γ ⊢ t ≊ t′ ∷ A →
               Γ ⊢ t′ ≊ t ∷ A
    trans≊ : ∀ {Γ A t t′ t″} →
               Γ ⊢ t ≊ t′ ∷ A → Γ ⊢ t′ ≊ t″ ∷ A →
               Γ ⊢ t ≊ t″ ∷ A

    congƛ≊ : ∀ {Γ A B t t′ x} {{_ : T (fresh x Γ)}} →
               [ Γ , x ∷ A ] ⊢ t ≊ t′ ∷ B →
               Γ ⊢ ƛ x t ≊ ƛ x t′ ∷ A ⊃ B
    cong∙≊ : ∀ {Γ A B t t′ u u′} →
               Γ ⊢ t ≊ t′ ∷ A ⊃ B → Γ ⊢ u ≊ u′ ∷ A →
               Γ ⊢ t ∙ u ≊ t′ ∙ u′ ∷ B
    cong▶≊ : ∀ {Γ Δ A t t′ s s′} →
               Γ ⊢ t ≊ t′ ∷ A → Δ ⋙ s ≊ₛ s′ ∷ Γ →
               Γ ⊢ t ▶ s ≊ t′ ▶ s′ ∷ A

    conv₁≊ : ∀ {Γ A t} →
               Γ ⊢ t ∷ A →
               Γ ⊢ t ≊ t ∷ A
    conv₂≊ : ∀ {Γ Δ A B s t₁ t₂ x} {{_ : T (fresh x Δ)}} →
               Γ ⋙ s ∷ Δ → [ Δ , x ∷ A ] ⊢ t₁ ∷ B → Γ ⊢ t₂ ∷ A →
               Γ ⊢ (ƛ x t₁ ▶ s) ∙ t₂ ≊ t₁ ▶ [ s , x ≔ t₂ ] ∷ B
    conv₃≊ : ∀ {Γ A B t x} {{_ : T (fresh x Γ)}} →
               Γ ⊢ t ∷ A ⊃ B →
               Γ ⊢ t ≊ ƛ x (t ∙ ν x) ∷ A ⊃ B
    conv₄≊ : ∀ {Γ Δ A t₁ t₂} →
               Γ ⊇ Δ → Δ ⊢ t₁ ≊ t₂ ∷ A →
               Γ ⊢ t₁ ≊ t₂ ∷ A
    conv₅≊ : ∀ {Γ Δ A s t x} {{_ : T (fresh x Δ)}} →
               Γ ⋙ s ∷ Δ → Γ ⊢ t ∷ A →
               Γ ⊢ ν x ▶ [ s , x ≔ t ] ≊ t ∷ A
    conv₆≊ : ∀ {Γ A t} →
               Γ ⊢ t ∷ A →
               Γ ⊢ t ▶ [] ≊ t ∷ A
    conv₇≊ : ∀ {Γ Δ A B s t₁ t₂} →
               Δ ⊢ t₁ ∷ A ⊃ B → Δ ⊢ t₂ ∷ A → Γ ⋙ s ∷ Δ →
               Γ ⊢ (t₁ ∙ t₂) ▶ s ≊ (t₁ ▶ s) ∙ (t₂ ▶ s) ∷ B
    conv₈≊ : ∀ {Γ₁ Γ₂ Γ₃ A s₁ s₂ t} →
               Γ₂ ⋙ s₁ ∷ Γ₃ → Γ₁ ⋙ s₂ ∷ Γ₂ → Γ₃ ⊢ t ∷ A →
               Γ₁ ⊢ (t ▶ s₁) ▶ s₂ ≊ t ▶ (s₁ ● s₂) ∷ A

  data _⋙_≊ₛ_∷_ : 𝒞 → 𝕊 → 𝕊 → 𝒞 → Set where
    refl≊ₛ  : ∀ {Γ Δ s} →
                Δ ⋙ s ≊ₛ s ∷ Γ
    sym≊ₛ   : ∀ {Γ Δ s s′} →
                Δ ⋙ s ≊ₛ s′ ∷ Γ →
                Δ ⋙ s′ ≊ₛ s ∷ Γ
    trans≊ₛ : ∀ {Γ Δ s s′ s″} →
                Δ ⋙ s ≊ₛ s′ ∷ Γ → Δ ⋙ s′ ≊ₛ s″ ∷ Γ →
                Δ ⋙ s ≊ₛ s″ ∷ Γ

    cong≔≊ₛ : ∀ {Γ Δ A s s′ t t′ x} {{_ : T (fresh x Δ)}} →
                Γ ⋙ s ≊ₛ s′ ∷ Δ → Γ ⊢ t ≊ t′ ∷ A →
                Γ ⋙ [ s , x ≔ t ] ≊ₛ [ s′ , x ≔ t′ ] ∷ [ Δ , x ∷ A ]
    cong●≊ₛ : ∀ {Γ Δ Θ s₁ s₁′ s₂ s₂′} →
                Δ ⋙ s₂ ≊ₛ s₂′ ∷ Θ → Γ ⋙ s₁ ≊ₛ s₁′ ∷ Δ →
                Γ ⋙ s₂ ● s₁ ≊ₛ s₂′ ● s₁′ ∷ Θ

    conv₁≊ₛ : ∀ {Γ₁ Γ₂ Δ s₁ s₂} →
                Γ₁ ⊇ Γ₂ → Γ₂ ⋙ s₁ ≊ₛ s₂ ∷ Δ →
                Γ₁ ⋙ s₁ ≊ₛ s₂ ∷ Δ
    conv₂≊ₛ : ∀ {Γ Δ₁ Δ₂ s₁ s₂} →
                Δ₁ ⊇ Δ₂ → Γ ⋙ s₁ ≊ₛ s₂ ∷ Δ₁ →
                Γ ⋙ s₁ ≊ₛ s₂ ∷ Δ₂
    conv₃≊ₛ : ∀ {Γ Δ s} →
                Γ ⋙ s ∷ Δ →
                Γ ⋙ s ● [] ≊ₛ s ∷ Δ
    conv₄≊ₛ : ∀ {Γ₁ Γ₂ Γ₃ Δ s₁ s₂ s₃} →
                Γ₁ ⋙ s₃ ∷ Γ₂ → Γ₂ ⋙ s₂ ∷ Γ₃ → Γ₃ ⋙ s₁ ∷ Δ →
                Γ₃ ⋙ (s₁ ● s₂) ● s₃ ≊ₛ s₁ ● (s₂ ● s₃) ∷ Δ
    conv₅≊ₛ : ∀ {Γ₁ Γ₂ Δ A s₁ s₂ t x} {{_ : T (fresh x Δ)}} →
                Γ₁ ⋙ s₂ ∷ Γ₂ → Γ₂ ⋙ s₁ ∷ Δ → Γ₂ ⊢ t ∷ A →
                Γ₁ ⋙ [ s₁ , x ≔ t ] ● s₂ ≊ₛ [ s₁ ● s₂ , x ≔ t ▶ s₂ ] ∷ [ Δ , x ∷ A ]
    conv₆≊ₛ : ∀ {Γ s} →
                Γ ⋙ s ∷ [] →
                Γ ⋙ s ≊ₛ [] ∷ []
    conv₇≊ₛ : ∀ {Γ Δ A s x} {{_ : T (fresh x Δ)}} →
                Γ ⋙ s ∷ [ Δ , x ∷ A ] →
                Γ ⋙ s ≊ₛ [ s , x ≔ ν x ▶ s ] ∷ [ Δ , x ∷ A ]
    conv₈≊ₛ : ∀ {Γ Δ A s t x} {{_ : T (fresh x Δ)}} →
                Γ ⋙ s ∷ Δ → Δ ⊢ t ∷ A →
                Γ ⋙ [ s , x ≔ t ] ≊ₛ s ∷ Δ
    conv₉≊ₛ : ∀ {Γ Δ s} →
                Γ ⋙ s ∷ Δ →
                Γ ⋙ [] ● s ≊ₛ s ∷ Δ

-- It is straightforward to prove that if two terms (substitutions) are convertible with each
-- other, then they are also well-typed.

-- TODO: What to do about the above paragraph?


{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
module Spire.Examples.PropositionalDesc where

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

elimEq : (A : Set) (x : A) (P : (y : A) → x ≡ y → Set)
  → P x refl
  → (y : A) (p : x ≡ y) → P y p
elimEq A .x P prefl x refl = prefl

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Cases : (E : Enum) (P : Tag E → Set) → Set
Cases [] P = ⊤
Cases (l ∷ E) P = P here × Cases E λ t → P (there t)

case : (E : Enum) (P : Tag E → Set) (cs : Cases E P) (t : Tag E) → P t
case (l ∷ E) P (c , cs) here = c
case (l ∷ E) P (c , cs) (there t) = case E (λ t → P (there t)) cs t

UncurriedCases : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedCases E P X = Cases E P → X

CurriedCases : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
CurriedCases [] P X = X
CurriedCases (l ∷ E) P X = P here → CurriedCases E (λ t → P (there t)) X

curryCases : (E : Enum) (P : Tag E → Set) (X : Set)
  (f : UncurriedCases E P X) → CurriedCases E P X
curryCases [] P X f = f tt
curryCases (l ∷ E) P X f = λ c → curryCases E (λ t → P (there t)) X (λ cs → f (c , cs))

uncurryCases : (E : Enum) (P : Tag E → Set) (X : Set)
  (f : CurriedCases E P X) → UncurriedCases E P X
uncurryCases [] P X x tt = x
uncurryCases (l ∷ E) P X f (c , cs) = uncurryCases E (λ t → P (there t)) X (f c) cs

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

data Desc (I : Set) : Set₁ where
  `End : (i : I) → Desc I
  `Rec : (i : I) (D : Desc I) → Desc I
  `Arg : (A : Set) (B : A → Desc I) → Desc I
  `RecFun : (A : Set) (B : A → I) (D : Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : (I : Set) (D : Desc I) (X : ISet I) → ISet I
El I (`End j) X i = j ≡ i
El I (`Rec j D) X i = X j × El I D X i
El I (`Arg A B) X i = Σ A (λ a → El I (B a) X i)
El I (`RecFun A B D) X i = ((a : A) → X (B a)) × El I D X i

Hyps : (I : Set) (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : El I D X i) → Set
Hyps I (`End j) X P i q = ⊤
Hyps I (`Rec j D) X P i (x , xs) = P j x × Hyps I D X P i xs
Hyps I (`Arg A B) X P i (a , b) = Hyps I (B a) X P i b
Hyps I (`RecFun A B D) X P i (f , xs) = ((a : A) → P (B a) (f a)) × Hyps I D X P i xs

caseD : (E : Enum) (I : Set) (cs : Cases E (λ _ → Desc I)) (t : Tag E) → Desc I
caseD E I cs t = case E (λ _ → Desc I) cs t

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

TagDesc : (I : Set) → Set
TagDesc I = Σ Enum (λ E → Cases E (λ _ → Desc I))

toCase : (I : Set) (E,cs : TagDesc I) → Tag (proj₁ E,cs) → Desc I
toCase I (E , cs) = case E (λ _ → Desc I) cs

toDesc : (I : Set) → TagDesc I → Desc I
toDesc I (E , cs) = `Arg (Tag E) (toCase I (E , cs))

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

UncurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
UncurriedEl I D X = {i : I} → El I D X i → X i

CurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
CurriedEl I (`End i) X = X i
CurriedEl I (`Rec j D) X = (x : X j) → CurriedEl I D X
CurriedEl I (`Arg A B) X = (a : A) → CurriedEl I (B a) X
CurriedEl I (`RecFun A B D) X = ((a : A) → X (B a)) → CurriedEl I D X

curryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : UncurriedEl I D X) → CurriedEl I D X
curryEl I (`End i) X cn = cn refl
curryEl I (`Rec i D) X cn = λ x → curryEl I D X (λ xs → cn (x , xs))
curryEl I (`Arg A B) X cn = λ a → curryEl I (B a) X (λ xs → cn (a , xs))
curryEl I (`RecFun A B D) X cn = λ f → curryEl I D X (λ xs → cn (f , xs))

uncurryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : CurriedEl I D X) → UncurriedEl I D X
uncurryEl I (`End i) X cn refl = cn
uncurryEl I (`Rec i D) X cn (x , xs) = uncurryEl I D X (cn x) xs
uncurryEl I (`Arg A B) X cn (a , xs) = uncurryEl I (B a) X (cn a) xs
uncurryEl I (`RecFun A B D) X cn (f , xs) = uncurryEl I D X (cn f) xs

data μ (I : Set) (D : Desc I) : I → Set where
  con : UncurriedEl I D (μ I D)

con2 : (I : Set) (D : Desc I) → CurriedEl I D (μ I D)
con2 I D = curryEl I D (μ I D) con

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

UncurriedHyps : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  → Set
UncurriedHyps I D X P cn =
  (i : I) (xs : El I D X i) → Hyps I D X P i xs → P i (cn xs)

CurriedHyps : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  → Set
CurriedHyps I (`End i) X P cn =
  P i (cn refl)
CurriedHyps I (`Rec i D) X P cn =
  (x : X i) → P i x → CurriedHyps I D X P (λ xs → cn (x , xs))
CurriedHyps I (`Arg A B) X P cn =
  (a : A) → CurriedHyps I (B a) X P (λ xs → cn (a , xs))
CurriedHyps I (`RecFun A B D) X P cn =
  (f : (a : A) → X (B a)) (ihf : (a : A) → P (B a) (f a)) → CurriedHyps I D X P (λ xs → cn (f , xs))

curryHyps : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : UncurriedHyps I D X P cn)
  → CurriedHyps I D X P cn
curryHyps I (`End i) X P cn pf =
  pf i refl tt
curryHyps I (`Rec i D) X P cn pf =
  λ x ih → curryHyps I D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryHyps I (`Arg A B) X P cn pf =
  λ a → curryHyps I (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)
curryHyps I (`RecFun A B D) X P cn pf =
  λ f ihf → curryHyps I D X P (λ xs → cn (f , xs)) (λ i xs ihs → pf i (f , xs) (ihf , ihs))

uncurryHyps : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : CurriedHyps I D X P cn)
  → UncurriedHyps I D X P cn
uncurryHyps I (`End .i) X P cn pf i refl tt =
  pf
uncurryHyps I (`Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryHyps I D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryHyps I (`Arg A B) X P cn pf i (a , xs) ihs =
  uncurryHyps I (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs
uncurryHyps I (`RecFun A B D) X P cn pf i (f , xs) (ihf , ihs) =
  uncurryHyps I D X P (λ ys → cn (f , ys)) (pf f ihf) i xs ihs

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

ind :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : UncurriedHyps I D (μ I D) P con)
  (i : I)
  (x : μ I D i)
  → P i x

hyps :
  (I : Set)
  (D₁ : Desc I)
  (P : (i : I) → μ I D₁ i → Set)
  (pcon : UncurriedHyps I D₁ (μ I D₁) P con)
  (D₂ : Desc I)
  (i : I)
  (xs : El I D₂ (μ I D₁) i)
  → Hyps I D₂ (μ I D₁) P i xs

ind I D P pcon i (con xs) = pcon i xs (hyps I D P pcon D i xs)

hyps I D P pcon (`End j) i q = tt
hyps I D P pcon (`Rec j A) i (x , xs) = ind I D P pcon j x , hyps I D P pcon A i xs
hyps I D P pcon (`Arg A B) i (a , b) = hyps I D P pcon (B a) i b
hyps I D P pcon (`RecFun A B E) i (f , xs) = (λ a → ind I D P pcon (B a) (f a)) , hyps I D P pcon E i xs

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

ind2 :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : CurriedHyps I D (μ I D) P con)
  (i : I)
  (x : μ I D i)
  → P i x
ind2 I D P pcon i x = ind I D P (uncurryHyps I D (μ I D) P con pcon) i x

elim :
  (I : Set)
  (TD : TagDesc I)
  → let
    D = toDesc I TD
    E = proj₁ TD
    Cs = toCase I TD
  in (P : (i : I) → μ I D i → Set)
  → let
    Q = λ t → CurriedHyps I (Cs t) (μ I D) P (λ xs → con (t , xs))
    X = (i : I) (x : μ I D i) → P i x
  in UncurriedCases E Q X
elim I TD P cs i x =
  let
    D = toDesc I TD
    E = proj₁ TD
    Cs = toCase I TD
    Q = λ t → CurriedHyps I (Cs t) (μ I D) P (λ xs → con (t , xs))
    p = case E Q cs
  in ind2 I D P p i x

elim2 :
  (I : Set)
  (TD : TagDesc I)
  → let
    D = toDesc I TD
    E = proj₁ TD
    Cs = toCase I TD
  in (P : (i : I) → μ I D i → Set)
  → let
    Q = λ t → CurriedHyps I (Cs t) (μ I D) P (λ xs → con (t , xs))
    X = (i : I) (x : μ I D i) → P i x
  in CurriedCases E Q X
elim2 I TD P =
  let
    D = toDesc I TD
    E = proj₁ TD
    Cs = toCase I TD
    Q = λ t → CurriedHyps I (Cs t) (μ I D) P (λ xs → con (t , xs))
    X = (i : I) (x : μ I D i) → P i x
  in curryCases E Q X (elim I TD P)

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

module Sugared where

  data ℕT : Set where `zero `suc : ℕT
  data VecT : Set where `nil `cons : VecT

  ℕD : Desc ⊤
  ℕD = `Arg ℕT λ
    { `zero → `End tt
    ; `suc → `Rec tt (`End tt)
    }

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (`zero , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (`suc , n , refl)

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg VecT λ
    { `nil  → `End zero
    ; `cons → `Arg (ℕ tt) λ n → `Arg A λ _ → `Rec n (`End (suc n))
    }

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (`nil , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (`cons , n , x , xs , refl)

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

  add : ℕ tt → ℕ tt → ℕ tt
  add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → n
      ; tt (`suc , m , q) (ih , tt) n → suc (ih n)
      }
    )
    tt

  mult : ℕ tt → ℕ tt → ℕ tt
  mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → zero
      ; tt (`suc , m , q) (ih , tt) n → add n (ih n)
      }
    )
    tt

  append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
  append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
    (λ
      { .(con (`zero , refl)) (`nil , refl) ih n ys → ys
      ; .(con (`suc , m , refl)) (`cons , m , x , xs , refl) (ih , tt) n ys → cons A (add m n) x (ih n ys)
      }
    )

  concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
  concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
    (λ
      { .(con (`zero , refl)) (`nil , refl) tt → nil A
      ; .(con (`suc , n , refl)) (`cons , n , xs , xss , refl) (ih , tt) → append A m xs (mult n m) ih
      }
    )

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

module Desugared where

  ℕT : Enum
  ℕT = "zero" ∷ "suc" ∷ []

  VecT : Enum
  VecT = "nil" ∷ "cons" ∷ []

  ℕTD : TagDesc ⊤
  ℕTD = ℕT
    , `End tt
    , `Rec tt (`End tt)
    , tt

  ℕCs : Tag ℕT → Desc ⊤
  ℕCs = toCase ⊤ ℕTD

  ℕD : Desc ⊤
  ℕD = toDesc ⊤ ℕTD

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (here , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (there here , n , refl)

  zero2 : ℕ tt
  zero2 = con2 ⊤ ℕD here

  suc2 : ℕ tt → ℕ tt
  suc2 = con2 ⊤ ℕD (there here)

  VecTD : (A : Set) → TagDesc (ℕ tt)
  VecTD A = VecT
    , `End zero
    , `Arg (ℕ tt) (λ n → `Arg A λ _ → `Rec n (`End (suc n)))
    , tt

  VecCs : (A : Set) → Tag VecT → Desc (ℕ tt)
  VecCs A = toCase (ℕ tt) (VecTD A)

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = toDesc (ℕ tt) (VecTD A)

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (here , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (there here , n , x , xs , refl)

  nil2 : (A : Set) → Vec A zero
  nil2 A = con2 (ℕ tt) (VecD A) here

  cons2 : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons2 A = con2 (ℕ tt) (VecD A) (there here)

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

  module Induction where

    add : ℕ tt → ℕ tt → ℕ tt
    add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕCs t) ℕ u)
               (ih : Hyps ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → n)
        , (λ m,q ih,tt n → suc (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕCs t) ℕ u)
               (ih : Hyps ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → zero)
        , (λ m,q ih,tt n → add n (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ m t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecCs A t) (Vec A) m)
               (ih : Hyps (ℕ tt) (VecD A) (Vec A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)) m (t , c))
               (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
        )
        ( (λ q ih n ys → subst (λ m → Vec A (add m n)) q ys)
        , (λ m',x,xs,q ih,tt n ys →
            let m' = proj₁ m',x,xs,q
                x = proj₁ (proj₂ m',x,xs,q)
                q = proj₂ (proj₂ (proj₂ m',x,xs,q))
                ih = proj₁ ih,tt
            in
            subst (λ m → Vec A (add m n)) q (cons A (add m' n) x (ih n ys))
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecCs (Vec A m) t) (Vec (Vec A m)) n)
               (ih : Hyps (ℕ tt) (VecD (Vec A m)) (Vec (Vec A m)) (λ n xss → Vec A (mult n m)) n (t , c))
               → Vec A (mult n m)
        )
        ( (λ q ih → subst (λ n → Vec A (mult n m)) q (nil A))
        , (λ n',xs,xss,q ih,tt →
            let n' = proj₁ n',xs,xss,q
                xs = proj₁ (proj₂ n',xs,xss,q)
                q = proj₂ (proj₂ (proj₂ n',xs,xss,q))
                ih = proj₁ ih,tt
            in
            subst (λ n → Vec A (mult n m)) q (append A m xs (mult n' m) ih)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

  module Eliminator where

    elimℕ : (P : (ℕ tt) → Set)
      (pzero : P zero)
      (psuc : (m : ℕ tt) → P m → P (suc m))
      (n : ℕ tt)
      → P n
    elimℕ P pzero psuc = ind ⊤ ℕD (λ u n → P n)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕCs t) ℕ u)
               (ih : Hyps ⊤ ℕD ℕ (λ u n → P n) u (t , c))
               → P (con (t , c))
        )
        ( (λ q ih →
            elimEq ⊤ tt (λ u q → P (con (here , q)))
              pzero
              u q
          )
        , (λ n,q ih,tt →
            elimEq ⊤ tt (λ u q → P (con (there here , proj₁ n,q , q)))
              (psuc (proj₁ n,q) (proj₁ ih,tt))
              u (proj₂ n,q)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    elimVec : (A : Set) (P : (n : ℕ tt) → Vec A n → Set)
      (pnil : P zero (nil A))
      (pcons : (n : ℕ tt) (a : A) (xs : Vec A n) → P n xs → P (suc n) (cons A n a xs))
      (n : ℕ tt)
      (xs : Vec A n)
      → P n xs
    elimVec A P pnil pcons = ind (ℕ tt) (VecD A) (λ n xs → P n xs)
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecCs A t) (Vec A) n)
               (ih : Hyps (ℕ tt) (VecD A) (Vec A) (λ n xs → P n xs) n (t , c))
               → P n (con (t , c))
        )
        ( (λ q ih →
            elimEq (ℕ tt) zero (λ n q → P n (con (here , q)))
              pnil
              n q
          )
        , (λ n',x,xs,q ih,tt →
            let n' = proj₁ n',x,xs,q
                x = proj₁ (proj₂ n',x,xs,q)
                xs = proj₁ (proj₂ (proj₂ n',x,xs,q))
                q = proj₂ (proj₂ (proj₂ n',x,xs,q))
                ih = proj₁ ih,tt
            in
            elimEq (ℕ tt) (suc n') (λ n q → P n (con (there here , n' , x , xs , q)))
              (pcons n' x xs ih )
              n q
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

    add : ℕ tt → ℕ tt → ℕ tt
    add = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → n)
      (λ m ih n → suc (ih n))

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → zero)
      (λ m ih n → add n (ih n))

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elimVec A (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ n ys → ys)
      (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elimVec (Vec A m) (λ n xss → Vec A (mult n m))
      (nil A)
      (λ n xs xss ih → append A m xs (mult n m) ih)

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

  module GenericEliminator where

    add : ℕ tt → ℕ tt → ℕ tt
    add = elim2 ⊤ ℕTD _
      (λ n → n)
      (λ m ih n → suc (ih n))
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elim2 ⊤ ℕTD _
      (λ n → zero)
      (λ m ih n → add n (ih n))
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elim2 (ℕ tt) (VecTD A) _
      (λ n ys → ys)
      (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elim2 (ℕ tt) (VecTD (Vec A m)) _
      (nil A)
      (λ n xs xss ih → append A m xs (mult n m) ih)

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


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Prod.Base where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function

-- Here we define an inductive version of the product type, see below
-- for its uses.

-- See `Cubical.Data.Sigma` for `_×_` defined as a special case of
-- sigma types, which is the generally preferred one.

-- If × is defined using Σ then transp/hcomp will be compute
-- "negatively", that is, they won't reduce unless we project out the
-- first of second component. This is not always what we want so this
-- implementation is done using a datatype which computes positively.

private
  variable
    ℓ ℓ' : Level

data _×_ (A : Type ℓ) (B : Type ℓ') : Type (ℓ-max ℓ ℓ') where
  _,_ : A → B → A × B

infixr 5 _×_

proj₁ : {A : Type ℓ} {B : Type ℓ'} → A × B → A
proj₁ (x , _) = x

proj₂ : {A : Type ℓ} {B : Type ℓ'} → A × B → B
proj₂ (_ , x) = x

private
  variable
    A    : Type ℓ
    B C  : A → Type ℓ

intro : (∀ a → B a) → (∀ a → C a) → ∀ a → B a × C a
intro f g a = f a , g a

map : {B : Type ℓ} {D : B → Type ℓ'}
   → (∀ a → C a) → (∀ b → D b) → (x : A × B) → C (proj₁ x) × D (proj₂ x)
map f g = intro (f ∘ proj₁) (g ∘ proj₂)

×-η : {A : Type ℓ} {B : Type ℓ'} (x : A × B) → x ≡ ((proj₁ x) , (proj₂ x))
×-η (x , x₁) = refl


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

module Control.Monad.Levels.Definition where

open import Prelude
open import Data.Bag

data Levels (A : Type a) : Type a where
  _∷_ : ⟅ A ⟆ → Levels A → Levels A
  []  : Levels A

  trail : [] ∷ [] ≡ []
  trunc : isSet (Levels A)


module RandomAccessList.General.Redundant where

open import RandomAccessList.General.Core

open import Data.Nat

Redundant : Set → ℕ → Set
Redundant A = General A 0 2

cons : ∀ {n A} → A → Redundant A n → Redundant A n
cons a [] = ?
cons a (∺ x x₁ x₂ xs) = ?


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

module Lists.Definition where

data List {a : _} (A : Set a) : Set a where
  [] : List A
  _::_ : (x : A) (xs : List A) → List A
infixr 10 _::_
{-# BUILTIN LIST List #-}

[_] : {a : _} {A : Set a} → (a : A) → List A
[ a ] = a :: []

_++_ : {a : _} {A : Set a} → List A → List A → List A
[] ++ m = m
(x :: l) ++ m = x :: (l ++ m)


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

module Agda.Builtin.Bool where

data Bool : Set where
  false true : Bool

{-# BUILTIN BOOL  Bool  #-}
{-# BUILTIN FALSE false #-}
{-# BUILTIN TRUE  true  #-}

{-# COMPILE UHC Bool = data __BOOL__ (__FALSE__ | __TRUE__) #-}

{-# COMPILE JS Bool  = function (x,v) { return ((x)? v["true"]() : v["false"]()); } #-}
{-# COMPILE JS false = false #-}
{-# COMPILE JS true  = true  #-}


{-# OPTIONS --cubical --no-import-sorts --safe #-}

module Cubical.Data.Fin.Properties where

open import Cubical.Core.Everything

open import Cubical.Functions.Embedding
open import Cubical.Functions.Surjection
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport

open import Cubical.Data.Fin.Base as Fin
open import Cubical.Data.Nat
open import Cubical.Data.Nat.Order
open import Cubical.Data.Empty as Empty
open import Cubical.Data.Unit
open import Cubical.Data.Sum
open import Cubical.Data.Sigma
open import Cubical.Data.FinData.Base renaming (Fin to FinData) hiding (¬Fin0 ; toℕ)

open import Cubical.Relation.Nullary
open import Cubical.Relation.Nullary.DecidableEq

open import Cubical.Induction.WellFounded

open import Cubical.Relation.Nullary

private
 variable
   a b ℓ : Level
   n : ℕ
   A : Type a

-- Fin 0 is empty, and thus a proposition.
isPropFin0 : isProp (Fin 0)
isPropFin0 = Empty.rec ∘ ¬Fin0

-- Fin 1 has only one value.
isContrFin1 : isContr (Fin 1)
isContrFin1
  = fzero , λ
  { (zero , _) → toℕ-injective refl
  ; (suc k , sk<1) → Empty.rec (¬-<-zero (pred-≤-pred sk<1))
  }

Unit≃Fin1 : Unit ≃ Fin 1
Unit≃Fin1 =
  isoToEquiv
    (iso
      (const fzero)
      (const tt)
      (isContrFin1 .snd)
      (isContrUnit .snd)
    )

-- Regardless of k, Fin k is a set.
isSetFin : ∀{k} → isSet (Fin k)
isSetFin {k} = isSetΣ isSetℕ (λ _ → isProp→isSet m≤n-isProp)

discreteFin : ∀ {n} → Discrete (Fin n)
discreteFin {n} (x , hx) (y , hy) with discreteℕ x y
... | yes prf = yes (Σ≡Prop (λ _ → m≤n-isProp) prf)
... | no prf = no λ h → prf (cong fst h)

inject<-ne : ∀ {n} (i : Fin n) → ¬ inject< ≤-refl i ≡ (n , ≤-refl)
inject<-ne {n} (k , k<n) p = <→≢ k<n (cong fst p)

Fin-fst-≡ : ∀ {n} {i j : Fin n} → fst i ≡ fst j → i ≡ j
Fin-fst-≡ = Σ≡Prop (λ _ → m≤n-isProp)

private
  subst-app : (B : A → Type b) (f : (x : A) → B x) {x y : A} (x≡y : x ≡ y) →
              subst B x≡y (f x) ≡ f y
  subst-app B f {x = x} =
    J (λ y e → subst B e (f x) ≡ f y) (substRefl {B = B} (f x))

-- Computation rules for the eliminator.
module _ (P : ∀ {k} → Fin k → Type ℓ)
         (fz : ∀ {k} → P {suc k} fzero)
         (fs : ∀ {k} {fn : Fin k} → P fn → P (fsuc fn))
         {k : ℕ} where
  elim-fzero : Fin.elim P fz fs {k = suc k} fzero ≡ fz
  elim-fzero =
    subst P (toℕ-injective _) fz ≡⟨ cong (λ p → subst P p fz) (isSetFin _ _ _ _) ⟩
    subst P refl fz              ≡⟨ substRefl {B = P} fz ⟩
    fz                           ∎

  elim-fsuc : (fk : Fin k) → Fin.elim P fz fs (fsuc fk) ≡ fs (Fin.elim P fz fs fk)
  elim-fsuc fk =
    subst P (toℕ-injective (λ _ → toℕ (fsuc fk′))) (fs (Fin.elim P fz fs fk′))
      ≡⟨ cong (λ p → subst P p (fs (Fin.elim P fz fs fk′)) ) (isSetFin _ _ _ _) ⟩
    subst P (cong fsuc fk′≡fk) (fs (Fin.elim P fz fs fk′))
      ≡⟨ subst-app _ (λ fj → fs (Fin.elim P fz fs fj)) fk′≡fk ⟩
    fs (Fin.elim P fz fs fk)
      ∎
    where
    fk′ = fst fk , pred-≤-pred (snd (fsuc fk))
    fk′≡fk : fk′ ≡ fk
    fk′≡fk = toℕ-injective refl

-- Helper function for the reduction procedure below.
--
-- If n = expand o k m, then n is congruent to m modulo k.
expand : ℕ → ℕ → ℕ → ℕ
expand 0 k m = m
expand (suc o) k m = k + expand o k m

expand≡ : ∀ k m o → expand o k m ≡ o · k + m
expand≡ k m zero = refl
expand≡ k m (suc o)
  = cong (k +_) (expand≡ k m o) ∙ +-assoc k (o · k) m

-- Expand a pair. This is useful because the whole function is
-- injective.
expand× : ∀{k} → (Fin k × ℕ) → ℕ
expand× {k} (f , o) = expand o k (toℕ f)

private
  lemma₀ : ∀{k m n r} → r ≡ n → k + m ≡ n → k ≤ r
  lemma₀ {k = k} {m} p q = m , +-comm m k ∙ q ∙ sym p

  expand×Inj : ∀ k → {t1 t2 : Fin (suc k) × ℕ} → expand× t1 ≡ expand× t2 → t1 ≡ t2
  expand×Inj k {f1 , zero} {f2 , zero} p i
    = toℕ-injective {fj = f1} {f2} p i , zero
  expand×Inj k {f1 , suc o1} {(r , r<sk) , zero} p
    = Empty.rec (<-asym r<sk (lemma₀ refl p))
  expand×Inj k {(r , r<sk) , zero} {f2 , suc o2} p
    = Empty.rec (<-asym r<sk (lemma₀ refl (sym p)))
  expand×Inj k {f1 , suc o1} {f2 , suc o2}
    = cong (λ { (f , o) → (f , suc o) })
    ∘ expand×Inj k {f1 , o1} {f2 , o2}
    ∘ inj-m+ {suc k}

  expand×Emb : ∀ k → isEmbedding (expand× {k})
  expand×Emb 0 = Empty.rec ∘ ¬Fin0 ∘ fst
  expand×Emb (suc k)
    = injEmbedding (isSetΣ isSetFin (λ _ → isSetℕ)) isSetℕ (expand×Inj k)

-- A Residue is a family of types representing evidence that a
-- natural is congruent to a value of a finite type.
Residue : ℕ → ℕ → Type₀
Residue k n = Σ[ tup ∈ Fin k × ℕ ] expand× tup ≡ n

-- There is at most one canonical finite value congruent to each
-- natural.
isPropResidue : ∀ k n → isProp (Residue k n)
isPropResidue k = isEmbedding→hasPropFibers (expand×Emb k)

-- A value of a finite type is its own residue.
Fin→Residue : ∀{k} → (f : Fin k) → Residue k (toℕ f)
Fin→Residue f = (f , 0) , refl

-- Fibers of numbers that differ by k are equivalent in a more obvious
-- way than via the fact that they are propositions.
Residue+k : (k n : ℕ) → Residue k n → Residue k (k + n)
Residue+k k n ((f , o) , p) = (f , suc o) , cong (k +_) p

Residue-k : (k n : ℕ) → Residue k (k + n) → Residue k n
Residue-k k n (((r , r<k) , zero) , p) = Empty.rec (<-asym r<k (lemma₀ p refl))
Residue-k k n ((f , suc o) , p) = ((f , o) , inj-m+ p)

Residue+k-k
  : (k n : ℕ)
  → (R : Residue k (k + n))
  → Residue+k k n (Residue-k k n R) ≡ R
Residue+k-k k n (((r , r<k) , zero) , p) = Empty.rec (<-asym r<k (lemma₀ p refl))
Residue+k-k k n ((f , suc o) , p)
  = Σ≡Prop (λ tup → isSetℕ (expand× tup) (k + n)) refl

Residue-k+k
  : (k n : ℕ)
  → (R : Residue k n)
  → Residue-k k n (Residue+k k n R) ≡ R
Residue-k+k k n ((f , o) , p)
  = Σ≡Prop (λ tup → isSetℕ (expand× tup) n) refl

private
  Residue≃ : ∀ k n → Residue k n ≃ Residue k (k + n)
  Residue≃ k n
    = Residue+k k n
    , isoToIsEquiv (iso (Residue+k k n) (Residue-k k n)
                        (Residue+k-k k n) (Residue-k+k k n))

Residue≡ : ∀ k n → Residue k n ≡ Residue k (k + n)
Residue≡ k n = ua (Residue≃ k n)

-- For positive `k`, all `n` have a canonical residue mod `k`.
module Reduce (k₀ : ℕ) where
  k : ℕ
  k = suc k₀

  base : ∀ n (n<k : n < k) → Residue k n
  base n n<k = Fin→Residue (n , n<k)

  step : ∀ n → Residue k n → Residue k (k + n)
  step n = transport (Residue≡ k n)

  reduce : ∀ n → Residue k n
  reduce = +induction k₀ (Residue k) base step

  reduce≡
    : ∀ n → transport (Residue≡ k n) (reduce n) ≡ reduce (k + n)
  reduce≡ n
    = sym (+inductionStep k₀ _ base step n)

  reduceP
    : ∀ n → PathP (λ i → Residue≡ k n i) (reduce n) (reduce (k + n))
  reduceP n = toPathP (reduce≡ n)

open Reduce using (reduce; reduce≡) public

extract : ∀{k n} → Residue k n → Fin k
extract = fst ∘ fst

private
  lemma₅
    : ∀ k n (R : Residue k n)
    →  extract R ≡ extract (transport (Residue≡ k n) R)
  lemma₅ k n = sym ∘ cong extract ∘ uaβ (Residue≃ k n)

-- The residue of n modulo k is the same as the residue of k + n.
extract≡ : ∀ k n → extract (reduce k n) ≡ extract (reduce k (suc k + n))
extract≡ k n
  = lemma₅ (suc k) n (reduce k n) ∙ cong extract (Reduce.reduce≡ k n)

isContrResidue : ∀{k n} → isContr (Residue (suc k) n)
isContrResidue {k} {n} = inhProp→isContr (reduce k n) (isPropResidue (suc k) n)

-- the modulo operator on ℕ

_%_ : ℕ → ℕ → ℕ
n % zero = n
n % (suc k) = toℕ (extract (reduce k n))

_/_ : ℕ → ℕ → ℕ
n / zero = zero
n / (suc k) = reduce k n .fst .snd

moddiv : ∀ n k → (n / k) · k + n % k ≡ n
moddiv n zero = refl
moddiv n (suc k) = sym (expand≡ _ _ (n / suc k)) ∙ reduce k n .snd

n%k≡n[modk] : ∀ n k → Σ[ o ∈ ℕ ] o · k + n % k ≡ n
n%k≡n[modk] n k = (n / k) , moddiv n k

n%sk<sk : (n k : ℕ) → (n % suc k) < suc k
n%sk<sk n k = extract (reduce k n) .snd

fznotfs : ∀ {m : ℕ} {k : Fin m} → ¬ fzero ≡ fsuc k
fznotfs {m} p = subst F p tt
  where
    F : Fin (suc m) → Type₀
    F (zero , _) = Unit
    F (suc _ , _) = ⊥

fsuc-inj : {fj fk : Fin n} → fsuc fj ≡ fsuc fk → fj ≡ fk
fsuc-inj = toℕ-injective ∘ injSuc ∘ cong toℕ

punchOut : ∀ {m} {i j : Fin (suc m)} → (¬ i ≡ j) → Fin m
punchOut {_} {i} {j} p with fsplit i | fsplit j
punchOut {_} {i} {j} p | inl prfi | inl prfj =
  Empty.elim (p (i ≡⟨ sym prfi ⟩ fzero ≡⟨ prfj ⟩ j ∎))
punchOut {_} {i} {j} p | inl prfi | inr (kj , prfj) =
  kj
punchOut {zero} {i} {j} p  | inr (ki , prfi) | inl prfj =
  Empty.elim (p (
    i ≡⟨ sym (isContrFin1 .snd i) ⟩
    c ≡⟨ isContrFin1 .snd j ⟩
    j ∎
  ))
  where c = isContrFin1 .fst
punchOut {suc _} {i} {j} p | inr (ki , prfi) | inl prfj =
  fzero
punchOut {zero} {i} {j} p | inr (ki , prfi) | inr (kj , prfj) =
  Empty.elim ((p (
    i ≡⟨ sym (isContrFin1 .snd i) ⟩
    c ≡⟨ isContrFin1 .snd j ⟩
    j ∎)
  ))
  where c = isContrFin1 .fst
punchOut {suc _} {i} {j} p | inr (ki , prfi) | inr (kj , prfj) =
  fsuc (punchOut {i = ki} {j = kj}
    (λ q → p (i ≡⟨ sym prfi ⟩ fsuc ki ≡⟨ cong fsuc q ⟩ fsuc kj ≡⟨ prfj ⟩ j ∎))
  )

punchOut-inj
  : ∀ {m} {i j k : Fin (suc m)} (i≢j : ¬ i ≡ j) (i≢k : ¬ i ≡ k)
  → punchOut i≢j ≡ punchOut i≢k → j ≡ k
punchOut-inj {_} {i} {j} {k} i≢j i≢k p with fsplit i | fsplit j | fsplit k
punchOut-inj {zero} {i} {j} {k} i≢j i≢k p | _ | _ | _ =
  Empty.elim (i≢j (i ≡⟨ sym (isContrFin1 .snd i) ⟩ c ≡⟨ isContrFin1 .snd j ⟩ j ∎))
    where c = isContrFin1 .fst
punchOut-inj {suc _} {i} {j} {k} i≢j i≢k p | inl prfi | inl prfj | _ =
  Empty.elim (i≢j (i ≡⟨ sym prfi ⟩ fzero ≡⟨ prfj ⟩ j ∎))
punchOut-inj {suc _} {i} {j} {k} i≢j i≢k p | inl prfi | _ | inl prfk =
  Empty.elim (i≢k (i ≡⟨ sym prfi ⟩ fzero ≡⟨ prfk ⟩ k ∎))
punchOut-inj {suc _} {i} {j} {k} i≢j i≢k p | inl prfi | inr (kj , prfj) | inr (kk , prfk) =
  j       ≡⟨ sym prfj ⟩
  fsuc kj ≡⟨ cong fsuc p ⟩
  fsuc kk ≡⟨ prfk ⟩
  k       ∎
punchOut-inj {suc _} {i} {j} {k} i≢j i≢k p | inr (ki , prfi) | inl prfj | inl prfk =
  j     ≡⟨ sym prfj ⟩
  fzero ≡⟨ prfk ⟩
  k     ∎
punchOut-inj {suc _} {i} {j} {k} i≢j i≢k p | inr (ki , prfi) | inr (kj , prfj) | inr (kk , prfk) =
  j ≡⟨ sym prfj ⟩
  fsuc kj ≡⟨ cong fsuc lemma4 ⟩
  fsuc kk ≡⟨ prfk ⟩
  k ∎
  where
    lemma1 = λ q → i≢j (i ≡⟨ sym prfi ⟩ fsuc ki ≡⟨ cong fsuc q ⟩ fsuc kj ≡⟨ prfj ⟩ j ∎)
    lemma2 = λ q → i≢k (i ≡⟨ sym prfi ⟩ fsuc ki ≡⟨ cong fsuc q ⟩ fsuc kk ≡⟨ prfk ⟩ k ∎)
    lemma3 = fsuc-inj p
    lemma4 = punchOut-inj lemma1 lemma2 lemma3
punchOut-inj {suc m} {i} {j} {k} i≢j i≢k p | inr (ki , prfi) | inl prfj | inr (kk , prfk) =
  Empty.rec (fznotfs p)
punchOut-inj {suc _} {i} {j} {k} i≢j i≢k p | inr (ki , prfi) | inr (kj , prfj) | inl prfk =
  Empty.rec (fznotfs (sym p))

pigeonhole-special
  : ∀ {n}
  → (f : Fin (suc n) → Fin n)
  → Σ[ i ∈ Fin (suc n) ] Σ[ j ∈ Fin (suc n) ] (¬ i ≡ j) × (f i ≡ f j)
pigeonhole-special {zero} f = Empty.rec (¬Fin0 (f fzero))
pigeonhole-special {suc n} f =
  proof (any?
    (λ (i : Fin (suc n)) →
      discreteFin (f (inject< ≤-refl i)) (f (suc n , ≤-refl))
    ))
  where
    proof
      : Dec (Σ (Fin (suc n)) (λ z → f (inject< ≤-refl z) ≡ f (suc n , ≤-refl)))
      → Σ[ i ∈ Fin (suc (suc n)) ] Σ[ j ∈ Fin (suc (suc n)) ] (¬ i ≡ j) × (f i ≡ f j)
    proof (yes (i , prf)) = inject< ≤-refl i , (suc n , ≤-refl) , inject<-ne i , prf
    proof (no h) =
      let
        g : Fin (suc n) → Fin n
        g k = punchOut
          {i = f (suc n , ≤-refl)}
          {j = f (inject< ≤-refl k)}
          (λ p → h (k , Fin-fst-≡ (sym (cong fst p))))
        i , j , i≢j , p = pigeonhole-special g
      in
        inject< ≤-refl i
      , inject< ≤-refl j
      , (λ q → i≢j (Fin-fst-≡ (cong fst q)))
      , punchOut-inj
          {i = f (suc n , ≤-refl)}
          {j = f (inject< ≤-refl i)}
          {k = f (inject< ≤-refl j)}
          (λ q → h (i , Fin-fst-≡ (sym (cong fst q))))
          (λ q → h (j , Fin-fst-≡ (sym (cong fst q))))
          (Fin-fst-≡ (cong fst p))

pigeonhole
  : ∀ {m n}
  → m < n
  → (f : Fin n → Fin m)
  → Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] (¬ i ≡ j) × (f i ≡ f j)
pigeonhole {m} {n} (zero , sm≡n) f =
  transport transport-prf (pigeonhole-special f′)
  where
    f′ : Fin (suc m) → Fin m
    f′ = subst (λ h → Fin h → Fin m) (sym sm≡n) f

    f′≡f : PathP (λ i → Fin (sm≡n i) → Fin m) f′ f
    f′≡f i = transport-fillerExt (cong (λ h → Fin h → Fin m) (sym sm≡n)) (~ i) f

    transport-prf
      : (Σ[ i ∈ Fin (suc m) ] Σ[ j ∈ Fin (suc m) ] (¬ i ≡ j) × (f′ i ≡ f′ j))
      ≡ (Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] (¬ i ≡ j) × (f i ≡ f j))
    transport-prf φ =
      Σ[ i ∈ Fin (sm≡n φ) ] Σ[ j ∈ Fin (sm≡n φ) ]
        (¬ i ≡ j) × (f′≡f φ i ≡ f′≡f φ j)
pigeonhole {m} {n} (suc k , prf) f =
  let
    g : Fin (suc n′) → Fin n′
    g k = fst (f′ k) , <-trans (snd (f′ k)) m<n′
    i , j , ¬q , r = pigeonhole-special g
  in transport transport-prf (i , j , ¬q , Σ≡Prop (λ _ → m≤n-isProp) (cong fst r))
  where
    n′ : ℕ
    n′ = k + suc m

    n≡sn′ : n ≡ suc n′
    n≡sn′ =
      n ≡⟨ sym prf ⟩
      suc (k + suc m) ≡⟨ refl ⟩
      suc n′ ∎

    m<n′ : m < n′
    m<n′ = k , injSuc (suc (k + suc m) ≡⟨ prf ⟩ n ≡⟨ n≡sn′ ⟩ suc n′ ∎)

    f′ : Fin (suc n′) → Fin m
    f′ = subst (λ h → Fin h → Fin m) n≡sn′ f

    f′≡f : PathP (λ i → Fin (n≡sn′ (~ i)) → Fin m) f′ f
    f′≡f i = transport-fillerExt (cong (λ h → Fin h → Fin m) n≡sn′) (~ i) f

    transport-prf
      : (Σ[ i ∈ Fin (suc n′) ] Σ[ j ∈ Fin (suc n′) ] (¬ i ≡ j) × (f′ i ≡ f′ j))
      ≡ (Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] (¬ i ≡ j) × (f i ≡ f j))
    transport-prf φ =
      Σ[ i ∈ Fin (n≡sn′ (~ φ)) ] Σ[ j ∈ Fin (n≡sn′ (~ φ)) ]
        (¬ i ≡ j) × (f′≡f φ i ≡ f′≡f φ j)

Fin-inj′ : {n m : ℕ} → n < m → ¬ Fin m ≡ Fin n
Fin-inj′ n<m p =
  let
    i , j , i≢j , q = pigeonhole n<m (transport p)
  in i≢j (
    i ≡⟨ refl ⟩
    fst (pigeonhole n<m (transport p)) ≡⟨ transport-p-inj {p = p} q ⟩
    fst (snd (pigeonhole n<m (transport p))) ≡⟨ refl ⟩
    j ∎
  )
  where
    transport-p-inj
      : ∀ {A B : Type ℓ} {x y : A} {p : A ≡ B}
      → transport p x ≡ transport p y
      → x ≡ y
    transport-p-inj {x = x} {y = y} {p = p} q =
      x ≡⟨ sym (transport⁻Transport p x) ⟩
      transport (sym p) (transport p x) ≡⟨ cong (transport (sym p)) q ⟩
      transport (sym p) (transport p y) ≡⟨ transport⁻Transport p y ⟩
      y ∎

Fin-inj : (n m : ℕ) → Fin n ≡ Fin m → n ≡ m
Fin-inj n m p with n ≟ m
... | eq prf = prf
... | lt n<m = Empty.rec (Fin-inj′ n<m (sym p))
... | gt n>m = Empty.rec (Fin-inj′ n>m p)

≤-·sk-cancel : ∀ {m} {k} {n} → m · suc k ≤ n · suc k → m ≤ n
≤-·sk-cancel {m} {k} {n} (d , p) = o , inj-·sm {m = k} goal where
  r = d % suc k
  o = d / suc k
  resn·k : Residue (suc k) (n · suc k)
  resn·k = ((r , n%sk<sk d k) , (o + m)) , reason where
   reason = expand× ((r , n%sk<sk d k) , o + m) ≡⟨ expand≡ (suc k) r (o + m) ⟩
            (o + m) · suc k + r                 ≡[ i ]⟨ +-comm (·-distribʳ o m (suc k) (~ i)) r i ⟩
            r + (o · suc k + m · suc k)         ≡⟨ +-assoc r (o · suc k) (m · suc k) ⟩
            (r + o · suc k) + m · suc k         ≡⟨ cong (_+ m · suc k) (+-comm r (o · suc k) ∙ moddiv d (suc k)) ⟩
            d + m · suc k                       ≡⟨ p ⟩
            n · suc k ∎

  residuek·n : ∀ k n → (r : Residue (suc k) (n · suc k)) → ((fzero , n) , expand≡ (suc k) 0 n ∙ +-zero _) ≡ r
  residuek·n _ _ = isContr→isProp isContrResidue _

  r≡0 : r ≡ 0
  r≡0 = cong (toℕ ∘ extract) (sym (residuek·n k n resn·k))
  d≡o·sk : d ≡ o · suc k
  d≡o·sk = sym (moddiv d (suc k)) ∙∙ cong (o · suc k +_) r≡0 ∙∙ +-zero _
  goal : (o + m) · suc k ≡ n · suc k
  goal = sym (·-distribʳ o m (suc k)) ∙∙ cong (_+ m · suc k) (sym d≡o·sk) ∙∙ p

<-·sk-cancel : ∀ {m} {k} {n} → m · suc k < n · suc k → m < n
<-·sk-cancel {m} {k} {n} p = goal where
  ≤-helper : m ≤ n
  ≤-helper = ≤-·sk-cancel (pred-≤-pred (<≤-trans p (≤-suc ≤-refl)))
  goal : m < n
  goal = case <-split (suc-≤-suc ≤-helper) of λ
    { (inl g) → g
    ; (inr e) → Empty.rec (¬m<m (subst (λ m → m · suc k < n · suc k) e p))
    }

factorEquiv : ∀ {n} {m} → Fin n × Fin m ≃ Fin (n · m)
factorEquiv {zero} {m} = uninhabEquiv (¬Fin0 ∘ fst) ¬Fin0
factorEquiv {suc n} {m} = intro , isEmbedding×isSurjection→isEquiv (isEmbeddingIntro , isSurjectionIntro) where
  intro : Fin (suc n) × Fin m → Fin (suc n · m)
  intro (nn , mm) = nm , subst (λ nm₁ → nm₁ < suc n · m) (sym (expand≡ _ (toℕ nn) (toℕ mm))) nm<n·m where
    nm : ℕ
    nm = expand× (nn , toℕ mm)
    nm<n·m : toℕ mm · suc n + toℕ nn < suc n · m
    nm<n·m =
      toℕ mm · suc n + toℕ nn <≤⟨ <-k+ (snd nn) ⟩
      toℕ mm · suc n + suc n  ≡≤⟨ +-comm _ (suc n) ⟩
      suc (toℕ mm) · suc n    ≤≡⟨ ≤-·k (snd mm) ⟩
      m · suc n               ≡⟨ ·-comm _ (suc n) ⟩
      suc n · m               ∎ where open <-Reasoning

  intro-injective : ∀ {o} {p} → intro o ≡ intro p → o ≡ p
  intro-injective {o} {p} io≡ip = λ i → io′≡ip′ i .fst , toℕ-injective {fj = snd o} {fk = snd p} (cong snd io′≡ip′) i where
    io′≡ip′ : (fst o , toℕ (snd o)) ≡ (fst p , toℕ (snd p))
    io′≡ip′ = expand×Inj _ (cong fst io≡ip)
  isEmbeddingIntro : isEmbedding intro
  isEmbeddingIntro = injEmbedding (isSet× isSetFin isSetFin) isSetFin intro-injective

  elimF : ∀ nm → fiber intro nm
  elimF nm = ((nn , nn<n) , (mm , mm<m)) , toℕ-injective (reduce n (toℕ nm) .snd) where
    mm = toℕ nm / suc n
    nn = toℕ nm % suc n

    nmmoddiv : mm · suc n + nn ≡ toℕ nm
    nmmoddiv = moddiv _ (suc n)
    nn<n : nn < suc n
    nn<n = n%sk<sk (toℕ nm) _

    nmsnd : mm · suc n + nn < suc n · m
    nmsnd = subst (λ l → l < suc n · m) (sym nmmoddiv) (snd nm)
    mm·sn<m·sn : mm · suc n < m · suc n
    mm·sn<m·sn =
      mm · suc n      ≤<⟨ nn , +-comm nn (mm · suc n) ⟩
      mm · suc n + nn <≡⟨ nmsnd ⟩
      suc n · m       ≡⟨ ·-comm (suc n) m ⟩
      m · suc n       ∎ where open <-Reasoning
    mm<m : mm < m
    mm<m = <-·sk-cancel mm·sn<m·sn

  isSurjectionIntro : isSurjection intro
  isSurjectionIntro = ∣_∣ ∘ elimF

-- Fin (m + n) ≡ Fin m ⊎ Fin n
-- ===========================

o<m→o<m+n : (m n o : ℕ) → o < m → o < (m + n)
o<m→o<m+n m n o (k , p) = (n + k) , (n + k + suc o    ≡⟨ sym (+-assoc n k _)  ⟩
                                     n + (k + suc o)  ≡⟨ cong (λ - → n + -) p ⟩
                                     n + m            ≡⟨ +-comm n m           ⟩
                                     m + n            ∎)

∸-<-lemma : (m n o : ℕ) → o < m + n → m ≤ o → o ∸ m < n
∸-<-lemma zero    n o       o<m+n m<o = o<m+n
∸-<-lemma (suc m) n zero    o<m+n m<o = Empty.rec (¬-<-zero m<o)
∸-<-lemma (suc m) n (suc o) o<m+n m<o =
  ∸-<-lemma m n o (pred-≤-pred o<m+n) (pred-≤-pred m<o)

-- A convenient wrapper on top of trichotomy, as we will be interested in
-- whether `m < n` or `n ≤ m`.
_≤?_ : (m n : ℕ) → (m < n) ⊎ (n ≤ m)
_≤?_ m n with m ≟ n
_≤?_ m n | lt m<n = inl m<n
_≤?_ m n | eq m=n = inr (subst (λ - → - ≤ m) m=n ≤-refl)
_≤?_ m n | gt n<m = inr (<-weaken n<m)

¬-<-and-≥ : {m n : ℕ} → m < n → ¬ n ≤ m
¬-<-and-≥ {m}     {zero}  m<n n≤m = ¬-<-zero m<n
¬-<-and-≥ {zero}  {suc n} m<n n≤m = ¬-<-zero n≤m
¬-<-and-≥ {suc m} {suc n} m<n n≤m = ¬-<-and-≥ (pred-≤-pred m<n) (pred-≤-pred n≤m)

m+n∸n=m : (n m : ℕ) → (m + n) ∸ n ≡ m
m+n∸n=m zero    k = +-zero k
m+n∸n=m (suc m) k = (k + suc m) ∸ suc m   ≡⟨ cong (λ - → - ∸ suc m) (+-suc k m) ⟩
                    suc (k + m) ∸ (suc m) ≡⟨ refl                               ⟩
                    (k + m) ∸ m           ≡⟨ m+n∸n=m m k                        ⟩
                    k                     ∎

∸-lemma : {m n : ℕ} → m ≤ n → m + (n ∸ m) ≡ n
∸-lemma {zero}  {k}     _   = refl {x = k}
∸-lemma {suc m} {zero}  m≤k = Empty.rec (¬-<-and-≥ (suc-≤-suc zero-≤) m≤k)
∸-lemma {suc m} {suc k} m≤k =
  suc m + (suc k ∸ suc m)   ≡⟨ refl                                 ⟩
  suc (m + (suc k ∸ suc m)) ≡⟨ refl                                 ⟩
  suc (m + (k ∸ m))         ≡⟨ cong suc (∸-lemma (pred-≤-pred m≤k)) ⟩
  suc k                     ∎

Fin+≅Fin⊎Fin : (m n : ℕ) → Iso (Fin (m + n)) (Fin m ⊎ Fin n)
Iso.fun (Fin+≅Fin⊎Fin m n) = f
  where
    f : Fin (m + n) → Fin m ⊎ Fin n
    f (k , k<m+n) with k ≤? m
    f (k , k<m+n) | inl k<m = inl (k , k<m)
    f (k , k<m+n) | inr k≥m = inr (k ∸ m , ∸-<-lemma m n k k<m+n k≥m)
Iso.inv (Fin+≅Fin⊎Fin m n) = g
  where
    g :  Fin m  ⊎  Fin n  →  Fin (m + n)
    g (inl (k , k<m)) = k     , o<m→o<m+n m n k k<m
    g (inr (k , k<n)) = m + k , <-k+ k<n
Iso.rightInv (Fin+≅Fin⊎Fin m n) = sec-f-g
  where
    sec-f-g : _
    sec-f-g (inl (k , k<m)) with k ≤? m
    sec-f-g (inl (k , k<m)) | inl _   = cong inl (Σ≡Prop (λ _ → m≤n-isProp) refl)
    sec-f-g (inl (k , k<m)) | inr m≤k = Empty.rec (¬-<-and-≥ k<m m≤k)
    sec-f-g (inr (k , k<n)) with (m + k) ≤? m
    sec-f-g (inr (k , k<n)) | inl p   = Empty.rec (¬m+n<m {m} {k} p)
    sec-f-g (inr (k , k<n)) | inr k≥m = cong inr (Σ≡Prop (λ _ → m≤n-isProp) rem)
      where
        rem : (m + k) ∸ m ≡ k
        rem = subst (λ - → - ∸ m ≡ k) (+-comm k m) (m+n∸n=m m k)
Iso.leftInv  (Fin+≅Fin⊎Fin m n) = ret-f-g
  where
    ret-f-g : _
    ret-f-g (k , k<m+n) with k ≤? m
    ret-f-g (k , k<m+n) | inl _   = Σ≡Prop (λ _ → m≤n-isProp) refl
    ret-f-g (k , k<m+n) | inr m≥k = Σ≡Prop (λ _ → m≤n-isProp) (∸-lemma m≥k)

Fin+≡Fin⊎Fin : (m n : ℕ) → Fin (m + n) ≡ Fin m ⊎ Fin n
Fin+≡Fin⊎Fin m n = isoToPath (Fin+≅Fin⊎Fin m n)

-- Equivalence between FinData and Fin

sucFin : {N : ℕ} → Fin N → Fin (suc N)
sucFin (k , n , p) = suc k , n , (+-suc _ _ ∙ cong suc p)

FinData→Fin : (N : ℕ) → FinData N → Fin N
FinData→Fin zero ()
FinData→Fin (suc N) zero = 0 , suc-≤-suc zero-≤
FinData→Fin (suc N) (suc k) = sucFin (FinData→Fin N k)

Fin→FinData : (N : ℕ) → Fin N → FinData N
Fin→FinData zero (k , n , p) = Empty.rec (snotz (sym (+-suc n k) ∙ p))
Fin→FinData (suc N) (0 , n , p) = zero
Fin→FinData (suc N) ((suc k) , n , p) = suc (Fin→FinData N (k , n , p')) where
  p' : n + suc k ≡ N
  p' = injSuc (sym (+-suc n (suc k)) ∙ p)

secFin : (n : ℕ) → section (FinData→Fin n) (Fin→FinData n)
secFin 0 (k , n , p) = Empty.rec (snotz (sym (+-suc n k) ∙ p))
secFin (suc N) (0 , n , p) = Fin-fst-≡ refl
secFin (suc N) (suc k , n , p) = Fin-fst-≡ (cong suc (cong fst (secFin N (k , n , p')))) where
  p' : n + suc k ≡ N
  p' = injSuc (sym (+-suc n (suc k)) ∙ p)

retFin : (n : ℕ) → retract (FinData→Fin n) (Fin→FinData n)
retFin 0 ()
retFin (suc N) zero = refl
retFin (suc N) (suc k) = cong FinData.suc (cong (Fin→FinData N) (Fin-fst-≡ refl) ∙ retFin N k)

FinDataIsoFin : (N : ℕ) → Iso (FinData N) (Fin N)
Iso.fun (FinDataIsoFin N) = FinData→Fin N
Iso.inv (FinDataIsoFin N) = Fin→FinData N
Iso.rightInv (FinDataIsoFin N) = secFin N
Iso.leftInv (FinDataIsoFin N) = retFin N

FinData≃Fin : (N : ℕ) → FinData N ≃ Fin N
FinData≃Fin N = isoToEquiv (FinDataIsoFin N)

FinData≡Fin : (N : ℕ) → FinData N ≡ Fin N
FinData≡Fin N = ua (FinData≃Fin N)


{-# OPTIONS --guardedness #-}

module Cubical.README where

------------------------------------------------------------------------
-- An experimental library for Cubical Agda
-----------------------------------------------------------------------

-- The library comes with a .agda-lib file, for use with the library
-- management system.

------------------------------------------------------------------------
-- Module hierarchy
------------------------------------------------------------------------

-- The core library for Cubical Agda.
-- It contains basic primitives, equivalences, glue types.
import Cubical.Core.Everything

-- The foundations for Cubical Agda.
-- The Prelude module is self-explanatory.
import Cubical.Foundations.Prelude
import Cubical.Foundations.Everything

-- Kinds and properties of functions
import Cubical.Functions.Everything

-- Data types and properties
import Cubical.Data.Everything

-- Higher-inductive types
import Cubical.HITs.Everything

-- Coinductive data types and properties
import Cubical.Codata.Everything

-- Papers
import Cubical.Papers.Everything

-- Properties and proofs about relations
import Cubical.Relation.Everything

-- Category theory
import Cubical.Categories.Everything

-- Homotopy theory
import Cubical.Homotopy.Everything

-- Properties and kinds of Modalities
import Cubical.Modalities.Everything

-- Various experiments using Cubical Agda
import Cubical.Experiments.Everything

-- Other modules (TODO: add descriptions)
import Cubical.Induction.Everything
import Cubical.Structures.Everything

-- general definition of cohomology
import Cubical.Cohomology.Everything

-- cohomology with constant Integer coefficients
import Cubical.ZCohomology.Everything

-- Algebra library (in development)
import Cubical.Algebra.Everything

-- Various talks
import Cubical.Talks.Everything

-- Reflection
import Cubical.Reflection.Everything

-- Displayed univalent graphs
import Cubical.Displayed.Everything

-- Syntax typeclasses
import Cubical.Syntax.Everything


-- Andreas, 2012-09-15
-- Positive effects of making Agda recognize constant functions.
-- Arguments to constant functions are ignored in definitional equality.
{-# OPTIONS --copatterns #-}
module NonvariantPolarity where

open import Common.Equality

data ⊥ : Set where
record ⊤ : Set where
  constructor trivial

data Bool : Set where
  true false : Bool

True : Bool → Set
True true  = ⊤
True false = ⊥

module IgnoreArg where

  -- A function ignoring its first argument
  knot : Bool → Bool → Bool
  knot x true  = false
  knot x false = true

  test : (y : Bool) → knot true y ≡ knot false y
  test y = refl

module UnusedModulePar where

  -- An unused module parameter
  module M (x : Bool) where

    not : Bool → Bool
    not true  = false
    not false = true

  open M true
  open M false renaming (not to not′)

  test : (y : Bool) → not y ≡ not′ y
  test y = refl

module CoinductiveUnit where

  record Unit : Set where
    coinductive
    constructor delay
    field force : Unit
  open Unit

  -- The identity on Unit does not match on its argument, so it is constant.
  id : Unit → Unit
  force (id x) = id (force x)

  idConst : (x y : Unit) → id x ≡ id y
  idConst x y = refl

  -- That does not imply x ≡ y (needs bisimulation).


module lambda.hw7 where

open import Data.Product
open import Relation.Nullary
open import Relation.Nullary.Negation
open import Relation.Binary.PropositionalEquality hiding (subst)
open import Data.Nat
open import Data.Fin hiding (lift)

open import lambda.untyped
open import lambda.vec
open import lambda.system-f renaming (⊢_∶_ to ⊢F_∶_; type to typeF)
                            hiding (subst; ↑; lift; subst₁)
open import lambda.system-d renaming (⊢_∶_ to ⊢D_∶_; type to typeD;
  _⊢_∶_ to _⊢D_∶_; context to contextD)

-- Peio BORTHELLE -- Homework 7

-- Maybe it's a bit unusual to present things like this, we didn't do any Agda
-- but it would really have been more hassle formalizing the homework in Coq.
-- So here it is, there are some utilities in the other files and also some
-- bonus simply-typed lambda calculus. It was a bit more fun for me than to
-- write again some long derivation tree with no guarantee at all that there
-- isn't a stupid mistake kicking in. I tried to get the notations close to
-- what we had in the lesson, hope this doesn't look too alien.

-- Utilities
A B C : typeD
A = base 0
B = base 1
C = base 1

V₀ : ∀ {n} → typeF (suc n)
V₀ = var zero

V₁ : ∀ {n} → typeF (suc (suc n))
V₁ = var (suc zero)

module Q₁ where
  -- Source terms
  t₁ t₂ t₃ t₄ : term 0
  t₁ = lam (app (var zero) (var zero))
  t₂ = app t₁ (lam (var zero))
  t₃ = app t₁ t₁
  t₄ = lam (lam (app (var (suc zero)) (app (var zero) (var (suc zero)))))

  -- a) system F
  F₁ F₂ F₄ : typeF 0
  F₁ = (∀' V₀ ⇒ V₀) ⇒ (∀' V₀ ⇒ V₀)
  F₂ = ∀' V₀ ⇒ V₀
  F₄ = ∀' ∀' (V₀ ⇒ V₁) ⇒ ((V₀ ⇒ V₁) ⇒ V₀) ⇒ V₁

  F₁-p : ⊢F t₁ ∶ F₁
  F₁-p = lam (∀' V₀ ⇒ V₀) (app (sub (∀' V₀ ⇒ V₀) ax) ax)

  F₂-p : ⊢F t₂ ∶ F₂
  F₂-p = app (lam (∀' V₀ ⇒ V₀) (app (sub (∀' V₀ ⇒ V₀) ax) ax)) (gen (lam V₀ ax))

  -- t₃ is not normalizing: it has a non-trivial beta-reduction to itself.
  -- Because system F is strongly normalizing this prooves that it has no valid
  -- typing judgment.
  t₃-no-norm : t₃ β* t₃
  t₃-no-norm = β-beta ← ε

  F₄-p : ⊢F t₄ ∶ F₄
  F₄-p = gen (gen (lam (V₀ ⇒ V₁) (lam ((V₀ ⇒ V₁) ⇒ V₀) (app ax (app ax ax)))))

  -- b) system D
  σ₁ σ₂ σ₄ : typeD
  σ₁ = (A ∧ A ⇒ B) ⇒ B
  σ₂ = A ⇒ A
  σ₄ = (A ⇒ B) ⇒ ((A ⇒ B) ⇒ A) ⇒ B

  σ₁-p : ⊢D t₁ ∶ σ₁
  σ₁-p = lam (app (∧ᵉʳ ax) (∧ᵉˡ ax))

  σ₂-p : ⊢D t₂ ∶ σ₂
  σ₂-p = app (lam (app (∧ᵉʳ ax) (∧ᵉˡ ax))) (∧ⁱ (lam ax) (lam ax))

  -- Same as system F for t₃ because of the strongly normalizing property.

  σ₄-p : ⊢D t₄ ∶ σ₄
  σ₄-p = lam (lam (app ax (app ax ax)))

module Q₂ where
  --
  σ₁ σ₂ σ₃ σ₄ : typeD
  σ₁ = ((A ∧ B) ⇒ C) ⇒ A ⇒ B ⇒ C
  σ₂ = (A ⇒ B ⇒ C) ⇒ (A ∧ B) ⇒ C
  σ₃ = (C ⇒ A ∧ C ⇒ B) ⇒ C ⇒ (A ∧ B)
  σ₄ = C ⇒ (A ∧ B) ⇒ (C ⇒ A ∧ C ⇒ B)

  σ₁-p : ∀ {t} → ¬ ⊢D t ∶ σ₁
  σ₁-p p = {!!}

  σ₂-p : ⊢D lam (lam (app (app (var (suc zero)) (var zero)) (var zero))) ∶ σ₂
  σ₂-p = lam (lam (app (app ax (∧ᵉˡ ax)) (∧ᵉʳ ax)))

  σ₃-p : ⊢D lam (lam (app (var (suc zero)) (var zero))) ∶ σ₃
  σ₃-p = lam (lam (∧ⁱ (app (∧ᵉˡ ax) ax) (app (∧ᵉʳ ax) ax)))

  σ₄-p : ⊢D lam (lam (lam (var (suc zero)))) ∶ σ₄
  σ₄-p = lam (lam (∧ⁱ (lam (∧ᵉˡ ax)) (lam (∧ᵉʳ ax))))

module Q₃ where
  -- I got stuck on applying the substitution lemma on function type that are
  -- not lambda abstractions but ∧ eliminations. I don't manage to get from
  -- a proof of that type to a proof with the argument type on the top of the
  -- context. Maybe the substitution lemma is not well choosen.
  subj-red : ∀ {n T} → {x y : term n} → {Γ : contextD n} → Γ ⊢D x ∶ T → x →β y → Γ ⊢D y ∶ T
  subj-red ax ()
  subj-red (∧ⁱ x₁ x₂) p = ∧ⁱ (subj-red x₁ p) (subj-red x₂ p)
  subj-red (∧ᵉˡ x) p = ∧ᵉˡ (subj-red x p)
  subj-red (∧ᵉʳ x) p = ∧ᵉʳ (subj-red x p)
  subj-red (app (lam x) y) β-beta = subst-p x (λ { zero → y; (suc i) → ax })
  subj-red (app (∧ᵉˡ x) y) β-beta = {!   !}
  subj-red (app (∧ᵉʳ x) y) β-beta = {!   !}
  subj-red (app x y) (β-app₁ p) = app (subj-red x p) y
  subj-red (app x y) (β-app₂ p) = app x (subj-red y p)
  subj-red (lam x) (β-lam p) = lam (subj-red x p)

module Q₄ where
  -- The BNF grammar i use is:
  --
  --  <NF> ::= "λ" <VAR> "." <NF> | <NE>
  --  <NE> ::= <NE> <NF> | <VAR>
  --
  -- I implemented this grammar as a judgment on untyped lambda terms
  -- with the datatypes `lambda.untyped.norm` and `lambda.untyped.neut`.

  -- Proof that NF and NE don't allow further derivation
  -- This proof as well as the reciprocical were quite mechanized but still
  -- a bit cumbersome.
  nf-last : ∀ {n} → {x : term n} → norm x → ¬ ∃[ y ] (x →β y)
  ne-last : ∀ {n} → {x : term n} → neut x → ¬ ∃[ y ] (x →β y)

  nf-last (lam x) (lam y , β-lam p) = nf-last x (y , p)
  nf-last (gnd x) (lam y , p) = ne-last x (lam y , p)
  nf-last (gnd x) (var i , p) = ne-last x (var i , p)
  nf-last (gnd x) (app a b , p) = ne-last x (app a b , p)

  ne-last var (y , ())
  ne-last (app () y) (_ , β-beta)
  ne-last (app x y) (app a b , β-app₁ p) = ne-last x (a , p)
  ne-last (app x y) (app a b , β-app₂ p) = nf-last y (b , p)

  -- Proof that terms with no further derivation are in NF
  last-nf : ∀ {n} → (x : term n) → ¬ ∃[ y ] (x →β y) → norm x
  last-ne : ∀ {n y} → (x : term n) → ¬ ∃[ z ] (app x y →β z) → neut x

  last-nf (lam x) p = lam (last-nf x λ { (y , p₂) → p (lam y , β-lam p₂) })
  last-nf (var x) p = gnd var
  last-nf (app x y) p = gnd (app
    (last-ne x λ { (z , p₁) → p (z , p₁) })
    (last-nf y λ { (a , b) → p (app x a , β-app₂ b) }))

  last-ne {y = y} (lam x) p with p (subst₁ x y , β-beta)
  ...               | ()
  last-ne (var x) p = var
  last-ne {y = y} (app x z) p = app
    (last-ne x λ { (a , b) → p (app a y , β-app₁ b) })
    (last-nf z λ { (a , b) → p (app (app x a) y , (β-app₁ (β-app₂ b))) })

  const : ∀ {n} → contextD n
  const {zero} = ε
  const {suc n} = const ▸ base 0

  -- Again because i messed up the renaming/substitution on ⊢D terms, i
  -- did not get to formalize the typing properly here.
  type-n : ∀ {n} → {x : term n} → norm x → ∃ (λ Γ → ∃ (λ T → Γ ⊢D x ∶ T))
  type-e : ∀ {n} → {x : term n} → neut x → ∃ (λ Γ → ∃ (λ T → Γ ⊢D x ∶ T))

  -- Here we compute inductively on the subterm, then "unload" the top of
  -- the context A and the result type B into the type A ⇒ B.
  type-n (lam x) = {!   !}
  type-n (gnd x) = type-e x

  -- Here we create a context with fresh base types, assigning the matching
  -- one to the term.
  type-e (var {i}) = {!   !}

  -- Here we compute inductively on both subterms:
  --   Γx ⊢D x ∶ Tx    Γy ⊢D y ∶ Ty
  -- x is a neutral term so it has a type looking like
  --   T ⇒ A₁ ∧ T ⇒ A₁ ⇒ A₂ ∧ …
  -- We then simply extend it with An = Ty. This requires some proof
  -- rewriting with ∧ᵉ*.
  type-e (app x y) = {!   !}

-- Question 5
-- a) The definition of the conjunction in system F is:
--     conjⁱ : Γ ⊢F x ∶ A → Γ ⊢F y ∶ B → Γ ⊢F (x , y) ∶ A ∧F B
--     conjᵉʳ : Γ ⊢F x ∶ A ∧F B → Γ ⊢F π₀ x ∶ A
--     conjᵉˡ : Γ ⊢F x : A ∧F B → Γ ⊢F π₁ x ∶ B
--    The difference is that in system D, the conjunction is more of
--    an intersection: if a single term has 2 type judgements, then
--    it has a judgment for the intersection, whereas for system F
--    it is a couple of 2 different terms.


{-

A parameterized family of structures S can be combined into a single structure:
X ↦ (a : A) → S a X

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Relational.Parameterized where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Structure
open import Cubical.Foundations.RelationalStructure
open import Cubical.Functions.FunExtEquiv
open import Cubical.Data.Sigma
open import Cubical.HITs.PropositionalTruncation
open import Cubical.HITs.SetQuotients

open import Cubical.Structures.Parameterized

private
  variable
    ℓ ℓ₀ ℓ₁ ℓ₁' ℓ₁'' : Level

-- Structured relations

module _ (A : Type ℓ₀) where

  ParamRelStr : {S : A → Type ℓ → Type ℓ₁}
    → (∀ a → StrRel (S a) ℓ₁')
    → StrRel (ParamStructure A S) (ℓ-max ℓ₀ ℓ₁')
  ParamRelStr ρ R s t =
    (a : A) → ρ a R (s a) (t a)

  paramSuitableRel : {S : A → Type ℓ → Type ℓ₁} {ρ : ∀ a → StrRel (S a) ℓ₁'}
    → (∀ a → SuitableStrRel (S a) (ρ a))
    → SuitableStrRel (ParamStructure A S) (ParamRelStr ρ)
  paramSuitableRel {ρ = ρ} θ .quo (X , f) R r .fst .fst a =
    θ a .quo (X , f a) R (r a) .fst .fst
  paramSuitableRel {ρ = ρ} θ .quo (X , f) R r .fst .snd a =
    θ a .quo (X , f a) R (r a) .fst .snd
  paramSuitableRel {ρ = ρ} θ .quo (X , f) R r .snd (q , c) i .fst a =
    θ a .quo (X , f a) R (r a) .snd (q a , c a) i .fst
  paramSuitableRel {ρ = ρ} θ .quo (X , f) R r .snd (q , c) i .snd a =
    θ a .quo (X , f a) R (r a) .snd (q a , c a) i .snd
  paramSuitableRel {ρ = ρ} θ .symmetric R r a =
    θ a .symmetric R (r a)
  paramSuitableRel {ρ = ρ} θ .transitive R R' r r' a =
    θ a .transitive R R' (r a) (r' a)
  paramSuitableRel {ρ = ρ} θ .set setX =
    isSetΠ λ a → θ a .set setX
  paramSuitableRel {ρ = ρ} θ .prop propR s t =
    isPropΠ λ a → θ a .prop propR (s a) (t a)

  paramRelMatchesEquiv : {S : A → Type ℓ → Type ℓ₁}
    (ρ : ∀ a → StrRel (S a) ℓ₁') {ι : ∀ a → StrEquiv (S a) ℓ₁''}
    → (∀ a → StrRelMatchesEquiv (ρ a) (ι a))
    → StrRelMatchesEquiv (ParamRelStr ρ) (ParamEquivStr A ι)
  paramRelMatchesEquiv ρ μ _ _ e = equivΠCod λ a → μ a _ _ e

  paramRelAction : {S : A → Type ℓ → Type ℓ₁} {ρ : ∀ a → StrRel (S a) ℓ₁'}
    → (∀ a → StrRelAction (ρ a))
    → StrRelAction (ParamRelStr ρ)
  paramRelAction α .actStr f s a = α a .actStr f (s a)
  paramRelAction α .actStrId s = funExt λ a → α a .actStrId (s a)
  paramRelAction α .actRel h _ _ r a = α a .actRel h _ _ (r a)

  -- Detransitivity of ParamRelStr would depend on choice in general, so
  -- we don't get positivity


------------------------------------------------------------------------------
-- Testing various arguments in the ATP pragmas
------------------------------------------------------------------------------

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

module VariousArguments where

postulate
  D       : Set
  _≡_     : D → D → Set
  a b c d : D
  a≡b     : a ≡ b
  b≡c     : b ≡ c
  c≡d     : c ≡ d
{-# ATP axioms a≡b b≡c c≡d #-}

postulate a≡d : a ≡ d
{-# ATP prove a≡d #-}


{-# OPTIONS --cubical --safe --no-import-sorts #-}
module Cubical.Algebra.Algebra.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Function
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Structures.Macro
open import Cubical.Algebra.Module    renaming (⟨_⟩ to ⟨_⟩m)
open import Cubical.Algebra.Ring      renaming (⟨_⟩ to ⟨_⟩r)
open import Cubical.Algebra.AbGroup   hiding (⟨_⟩)
open import Cubical.Algebra.Group     hiding (⟨_⟩)
open import Cubical.Algebra.Monoid       hiding (⟨_⟩)

open Iso

private
  variable
    ℓ : Level

record IsAlgebra (R : Ring {ℓ}) {A : Type ℓ}
                 (0a 1a : A) (_+_ _·_ : A → A → A) (-_ : A → A)
                 (_⋆_ : ⟨ R ⟩r → A → A) : Type ℓ where

  constructor isalgebra

  open Ring R using (1r) renaming (_+_ to _+r_; _·_ to _·r_)

  field
    isLeftModule : IsLeftModule R 0a _+_ -_ _⋆_
    ·-isMonoid  : IsMonoid 1a _·_
    dist        : (x y z : A) → (x · (y + z) ≡ (x · y) + (x · z))
                              × ((x + y) · z ≡ (x · z) + (y · z))
    ⋆-lassoc     : (r : ⟨ R ⟩r) (x y : A) → (r ⋆ x) · y ≡ r ⋆ (x · y)
    ⋆-rassoc     : (r : ⟨ R ⟩r) (x y : A) → r ⋆ (x · y) ≡ x · (r ⋆ y)

  open IsLeftModule isLeftModule public

  isRing : IsRing _ _ _ _ _
  isRing = isring (IsLeftModule.+-isAbGroup isLeftModule) ·-isMonoid dist
  open IsRing isRing public hiding (_-_; +-assoc; +-lid; +-linv; +-rid; +-rinv; +-comm)

record Algebra (R : Ring {ℓ}) : Type (ℓ-suc ℓ) where

  constructor algebra

  field
    Carrier        : Type ℓ
    0a             : Carrier
    1a             : Carrier
    _+_            : Carrier → Carrier → Carrier
    _·_            : Carrier → Carrier → Carrier
    -_             : Carrier → Carrier
    _⋆_            : ⟨ R ⟩r → Carrier → Carrier
    isAlgebra      : IsAlgebra R 0a 1a _+_ _·_ -_ _⋆_

  open IsAlgebra isAlgebra public

module commonExtractors {R : Ring {ℓ}} where
  ⟨_⟩ : Algebra R → Type ℓ
  ⟨_⟩ = Algebra.Carrier

  Algebra→Module : (A : Algebra R) → LeftModule R
  Algebra→Module (algebra A _ _ _ _ _ _ (isalgebra isLeftModule _ _ _ _)) =
    leftmodule A _ _ _ _ isLeftModule

  Algebra→Ring : (A : Algebra R) → Ring {ℓ}
  Algebra→Ring A = ring _ _ _ _ _ _ (IsAlgebra.isRing (Algebra.isAlgebra A))

  Algebra→AbGroup : (A : Algebra R) → AbGroup {ℓ}
  Algebra→AbGroup A = LeftModule→AbGroup (Algebra→Module A)

  Algebra→Monoid : (A : Algebra R) → Monoid {ℓ}
  Algebra→Monoid A = Ring→Monoid (Algebra→Ring A)

  isSetAlgebra : (A : Algebra R) → isSet ⟨ A ⟩
  isSetAlgebra A = isSetAbGroup (Algebra→AbGroup A)

  open Ring R using (1r; ·-ldist-+) renaming (_+_ to _+r_; _·_ to _·s_)

  makeIsAlgebra : {A : Type ℓ} {0a 1a : A}
                  {_+_ _·_ : A → A → A} { -_ : A → A} {_⋆_ : ⟨ R ⟩r → A → A}
                  (isSet-A : isSet A)
                  (+-assoc :  (x y z : A) → x + (y + z) ≡ (x + y) + z)
                  (+-rid : (x : A) → x + 0a ≡ x)
                  (+-rinv : (x : A) → x + (- x) ≡ 0a)
                  (+-comm : (x y : A) → x + y ≡ y + x)
                  (·-assoc :  (x y z : A) → x · (y · z) ≡ (x · y) · z)
                  (·-rid : (x : A) → x · 1a ≡ x)
                  (·-lid : (x : A) → 1a · x ≡ x)
                  (·-rdist-+ : (x y z : A) → x · (y + z) ≡ (x · y) + (x · z))
                  (·-ldist-+ : (x y z : A) → (x + y) · z ≡ (x · z) + (y · z))
                  (⋆-assoc : (r s : ⟨ R ⟩r) (x : A) → (r ·s s) ⋆ x ≡ r ⋆ (s ⋆ x))
                  (⋆-ldist : (r s : ⟨ R ⟩r) (x : A) → (r +r s) ⋆ x ≡ (r ⋆ x) + (s ⋆ x))
                  (⋆-rdist : (r : ⟨ R ⟩r) (x y : A) → r ⋆ (x + y) ≡ (r ⋆ x) + (r ⋆ y))
                  (⋆-lid   : (x : A) → 1r ⋆ x ≡ x)
                  (⋆-lassoc : (r : ⟨ R ⟩r) (x y : A) → (r ⋆ x) · y ≡ r ⋆ (x · y))
                  (⋆-rassoc : (r : ⟨ R ⟩r) (x y : A) → r ⋆ (x · y) ≡ x · (r ⋆ y))
                → IsAlgebra R 0a 1a _+_ _·_ -_ _⋆_
  makeIsAlgebra isSet-A
                +-assoc +-rid +-rinv +-comm
                ·-assoc ·-rid ·-lid ·-rdist-+ ·-ldist-+
                ⋆-assoc ⋆-ldist ⋆-rdist ⋆-lid ⋆-lassoc ⋆-rassoc =
                isalgebra
                  (makeIsLeftModule isSet-A
                                    +-assoc +-rid +-rinv +-comm
                                    ⋆-assoc ⋆-ldist ⋆-rdist ⋆-lid)
                  (makeIsMonoid isSet-A ·-assoc ·-rid ·-lid)
                  (λ x y z → ·-rdist-+ x y z , ·-ldist-+ x y z)
                  ⋆-lassoc ⋆-rassoc

open commonExtractors public

record AlgebraEquiv {R : Ring {ℓ}} (A B : Algebra R) : Type ℓ where

  constructor algebraiso

  instance
    _ : Algebra R
    _ = A
    _ : Algebra R
    _ = B

  open Algebra {{...}}

  field
    e      : ⟨ A ⟩ ≃ ⟨ B ⟩
    isHom+ : (x y : ⟨ A ⟩) → equivFun e (x + y) ≡ equivFun e x + equivFun e y
    isHom· : (x y : ⟨ A ⟩) → equivFun e (x · y) ≡ equivFun e x · equivFun e y
    pres1  : equivFun e 1a ≡ 1a
    comm⋆  : (r : ⟨ R ⟩r) (x : ⟨ A ⟩) → equivFun e (r ⋆ x) ≡ r ⋆ equivFun e x

record AlgebraHom {R : Ring {ℓ}} (A B : Algebra R) : Type ℓ where

  constructor algebrahom

  private
    instance
      _ : Algebra R
      _ = A
      _ : Algebra R
      _ = B

  open Algebra {{...}}

  field
    f      : ⟨ A ⟩ → ⟨ B ⟩
    isHom+ : (x y : ⟨ A ⟩) → f (x + y) ≡ f x + f y
    isHom· : (x y : ⟨ A ⟩) → f (x · y) ≡ f x · f y
    pres1  : f 1a ≡ 1a
    comm⋆  : (r : ⟨ R ⟩r) (x : ⟨ A ⟩) → f (r ⋆ x) ≡ r ⋆ f x

  pres0 : f 0a ≡ 0a
  pres0 = sym (Theory.+-idempotency→0 (Algebra→Ring B) (f 0a)
          (f 0a        ≡⟨ cong f (sym (+-rid _)) ⟩
           f (0a + 0a) ≡⟨ isHom+ _ _ ⟩
           f 0a + f 0a ∎))

  isHom- : (x : ⟨ A ⟩) → f (- x) ≡ - f x
  isHom- x = Theory.implicitInverse (Algebra→Ring B) (f x) (f (- x))
             (f (x) + f (- x)  ≡⟨ sym (isHom+ _ _) ⟩
             f (x - x)         ≡⟨ cong f (+-rinv _) ⟩
             f 0a              ≡⟨ pres0 ⟩
             0a ∎)

_$a_ : {R : Ring {ℓ}} {A B : Algebra R}
       → AlgebraHom A B
       → ⟨ A ⟩ → ⟨ B ⟩
f $a x = AlgebraHom.f f x

_∘a_ : {R : Ring {ℓ}} {A B C : Algebra R}
       → AlgebraHom B C → AlgebraHom A B → AlgebraHom A C
_∘a_ {ℓ} {R} {A} {B} {C}
  (algebrahom f isHom+f isHom·f pres1f comm⋆f)
  (algebrahom g isHom+g isHom·g pres1g comm⋆g)
  =
  let
    open Algebra ⦃...⦄
    instance
      _ : Algebra R
      _ = A
      _ : Algebra R
      _ = B
      _ : Algebra R
      _ = C
  in algebrahom (f ∘ g)
    (λ x y → f (g (x + y))      ≡⟨ cong f (isHom+g x y) ⟩
             f (g x + g y)      ≡⟨ isHom+f _ _  ⟩
             f (g x) + f (g y)  ∎)
    (λ x y → f (g (x · y))      ≡⟨ cong f (isHom·g x y) ⟩
             f (g x · g y)      ≡⟨ isHom·f _ _  ⟩
             f (g x) · f (g y)  ∎)
    (f (g 1a) ≡⟨ cong f pres1g ⟩ f 1a ≡⟨ pres1f ⟩ 1a ∎)
    λ r x → f (g (r ⋆ x))  ≡⟨ cong f (comm⋆g _ _) ⟩
            f (r ⋆ (g x))  ≡⟨ comm⋆f _ _ ⟩
            r ⋆ (f (g x))  ∎

module AlgebraΣTheory (R : Ring {ℓ}) where

  RawAlgebraStructure = λ (A : Type ℓ) → (A → A → A) × (A → A → A) × A × (⟨ R ⟩r → A → A)

  RawAlgebraEquivStr = AutoEquivStr RawAlgebraStructure

  rawAlgebraUnivalentStr : UnivalentStr _ RawAlgebraEquivStr
  rawAlgebraUnivalentStr = autoUnivalentStr RawAlgebraStructure

  open Ring R using (1r) renaming (_+_ to _+r_; _·_ to _·r_)
  open RingΣTheory
  open LeftModuleΣTheory R
  open MonoidΣTheory

  AlgebraAxioms : (A : Type ℓ) (str : RawAlgebraStructure A) → Type ℓ
  AlgebraAxioms A (_+_ , _·_ , 1a , _⋆_) =
               LeftModuleAxioms A (_+_ , _⋆_)
               × (MonoidAxioms A (1a , _·_))
               × ((x y z : A) → (x · (y + z) ≡ (x · y) + (x · z))
                              × ((x + y) · z ≡ (x · z) + (y · z)))
               × ((r : ⟨ R ⟩r) (x y : A) → (r ⋆ x) · y ≡ r ⋆ (x · y))
               × ((r : ⟨ R ⟩r) (x y : A) → r ⋆ (x · y) ≡ x · (r ⋆ y))

  AlgebraStructure : Type ℓ → Type ℓ
  AlgebraStructure = AxiomsStructure RawAlgebraStructure AlgebraAxioms

  AlgebraΣ : Type (ℓ-suc ℓ)
  AlgebraΣ = TypeWithStr ℓ AlgebraStructure

  AlgebraEquivStr : StrEquiv AlgebraStructure ℓ
  AlgebraEquivStr = AxiomsEquivStr RawAlgebraEquivStr AlgebraAxioms

  isSetAlgebraΣ : (A : AlgebraΣ) → isSet _
  isSetAlgebraΣ (A , _ , (isLeftModule , _ , _) ) = isSetLeftModuleΣ (A , _ , isLeftModule)

  isPropAlgebraAxioms : (A : Type ℓ) (s : RawAlgebraStructure A)
                             → isProp (AlgebraAxioms A s)
  isPropAlgebraAxioms A (_+_ , _·_ , 1a , _⋆_) =
    isPropΣ (isPropLeftModuleAxioms A (_+_ , _⋆_))
    (λ isLeftModule →
     isProp× (isPropMonoidAxioms A (1a , _·_))
    (isProp× (isPropΠ3 (λ _ _ _ → isProp× ((isSetLeftModuleΣ (A , _ , isLeftModule)) _ _)
                                          ((isSetLeftModuleΣ (A , _ , isLeftModule)) _ _)))
    (isProp× (isPropΠ3 (λ _ _ _ → (isSetLeftModuleΣ (A , _ , isLeftModule)) _ _))
             (isPropΠ3 (λ _ _ _ → (isSetLeftModuleΣ (A , _ , isLeftModule)) _ _)))))

  Algebra→AlgebraΣ : Algebra R → AlgebraΣ
  Algebra→AlgebraΣ (algebra A 0a 1a _+_ _·_ -_ _⋆_
                            (isalgebra isLeftModule isMonoid dist ⋆-lassoc ⋆-rassoc)) =
    A , (_+_ , _·_ , 1a , _⋆_) ,
    (LeftModule→LeftModuleΣ (leftmodule A _ _ _ _ isLeftModule) .snd .snd) ,
    Monoid→MonoidΣ (monoid A _ _ isMonoid) .snd .snd ,
    dist ,
    ⋆-lassoc ,
    ⋆-rassoc

  AlgebraΣ→Algebra : AlgebraΣ → Algebra R
  AlgebraΣ→Algebra (A , (_+_ , _·_ , 1a , _⋆_) , isLeftModule , isMonoid , dist , lassoc , rassoc) =
    algebra A _ 1a _+_ _·_ _ _⋆_
    (isalgebra (LeftModule.isLeftModule (LeftModuleΣ→LeftModule (A , (_ , isLeftModule))))
               (Monoid.isMonoid (MonoidΣ→Monoid (A , (_ , isMonoid))))
               dist lassoc rassoc)

  AlgebraIsoAlgebraΣ : Iso (Algebra R) AlgebraΣ
  AlgebraIsoAlgebraΣ = iso Algebra→AlgebraΣ AlgebraΣ→Algebra (λ _ → refl) helper
    where
      -- helper will be refl, if eta-equality is activated for all structure-records
      open MonoidΣTheory
      monoid-helper : retract (Monoid→MonoidΣ {ℓ}) MonoidΣ→Monoid
      monoid-helper = Iso.leftInv MonoidIsoMonoidΣ
      module-helper : retract (LeftModule→LeftModuleΣ) LeftModuleΣ→LeftModule
      module-helper = Iso.leftInv LeftModuleIsoLeftModuleΣ

      open Algebra
      helper : _
      Carrier (helper a i) = Carrier a
      0a (helper a i) = 0a a
      1a (helper a i) = 1a a
      _+_ (helper a i) = _+_ a
      _·_ (helper a i) = _·_ a
      -_ (helper a i) = -_ a
      _⋆_ (helper a i) = _⋆_ a
      IsAlgebra.isLeftModule (isAlgebra (helper a i)) =
        LeftModule.isLeftModule (module-helper
        (leftmodule _ _ _ _ _ (isLeftModule a)) i)
      IsAlgebra.·-isMonoid (isAlgebra (helper a i)) =
        Monoid.isMonoid (monoid-helper (monoid _ _ _ (·-isMonoid a)) i)
      IsAlgebra.dist (isAlgebra (helper a i)) = dist a
      IsAlgebra.⋆-lassoc (isAlgebra (helper a i)) = ⋆-lassoc a
      IsAlgebra.⋆-rassoc (isAlgebra (helper a i)) = ⋆-rassoc a

  algebraUnivalentStr : UnivalentStr AlgebraStructure AlgebraEquivStr
  algebraUnivalentStr = axiomsUnivalentStr _ isPropAlgebraAxioms rawAlgebraUnivalentStr

  AlgebraΣPath : (M N : AlgebraΣ) → (M ≃[ AlgebraEquivStr ] N) ≃ (M ≡ N)
  AlgebraΣPath = SIP algebraUnivalentStr

  AlgebraEquivΣ : (M N : Algebra R) → Type ℓ
  AlgebraEquivΣ M N = Algebra→AlgebraΣ M ≃[ AlgebraEquivStr ] Algebra→AlgebraΣ N

  AlgebraEquivΣPath : {M N : Algebra R} → Iso (AlgebraEquiv M N) (AlgebraEquivΣ M N)
  fun AlgebraEquivΣPath (algebraiso e isHom+ isHom· pres1 comm⋆) =
    e , isHom+ , (isHom· , (pres1 , comm⋆))
  inv AlgebraEquivΣPath (f , isHom+ , isHom· , pres1 , comm⋆) =
    algebraiso f isHom+ isHom· pres1 comm⋆
  rightInv AlgebraEquivΣPath _ = refl
  leftInv AlgebraEquivΣPath _ = refl

  AlgebraPath : (M N : Algebra R) → (AlgebraEquiv M N) ≃ (M ≡ N)
  AlgebraPath M N =
    AlgebraEquiv M N                                    ≃⟨ isoToEquiv AlgebraEquivΣPath ⟩
    AlgebraEquivΣ M N                                   ≃⟨ AlgebraΣPath _ _ ⟩
    Algebra→AlgebraΣ M ≡ Algebra→AlgebraΣ N             ≃⟨ isoToEquiv
                                                             (invIso
                                                             (congIso
                                                             AlgebraIsoAlgebraΣ))
                                                           ⟩
    M ≡ N ■

AlgebraPath : {R : Ring {ℓ}} (M N : Algebra R) → (AlgebraEquiv M N) ≃ (M ≡ N)
AlgebraPath {ℓ} {R} = AlgebraΣTheory.AlgebraPath R

module AlgebraTheory (R : Ring {ℓ}) (A : Algebra R) where
  open Ring R renaming (_+_ to _+r_)
  open Algebra A

  0-actsNullifying : (x : ⟨ A ⟩) → 0r ⋆ x ≡ 0a
  0-actsNullifying x =
    let idempotent-+ = 0r ⋆ x              ≡⟨ cong (λ u → u ⋆ x) (sym (Theory.0-idempotent R)) ⟩
                       (0r +r 0r) ⋆ x      ≡⟨ ⋆-ldist 0r 0r x ⟩
                       (0r ⋆ x) + (0r ⋆ x) ∎
    in sym (Theory.+-idempotency→0 (Algebra→Ring A) (0r ⋆ x) idempotent-+)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Strictness combinators
------------------------------------------------------------------------

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

module Strict where

open import Level
open import Agda.Builtin.Equality

open import Agda.Builtin.Strict
     renaming ( primForce to force
              ; primForceLemma to force-≡) public

-- Derived combinators
module _ {ℓ ℓ′ : Level} {A : Set ℓ} {B : Set ℓ′} where

  force′ : A → (A → B) → B
  force′ = force

  force′-≡ : (a : A) (f : A → B) → force′ a f ≡ f a
  force′-≡ = force-≡

  seq : A → B → B
  seq a b = force a (λ _ → b)

  seq-≡ : (a : A) (b : B) → seq a b ≡ b
  seq-≡ a b = force-≡ a (λ _ → b)


-- The bug documented below was exposed by the fix to issue 274.

{-# OPTIONS --universe-polymorphism #-}

module Issue274 where

postulate
  Level : Set
  zero : Level
  suc  : Level → Level
  _⊔_ : Level → Level → Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}
{-# BUILTIN LEVELMAX  _⊔_   #-}

record Q a : Set (a ⊔ a) where

record R a : Set a where
  field q : Q a

  A : Set₁
  A = Set

postulate
  ℓ : Level
  r : R (ℓ ⊔ ℓ)

foo : R ℓ
foo = r

-- Issue274.agda:32,7-8
-- ℓ ⊔ ℓ !=< ℓ of type Level
-- when checking that the expression r has type R ℓ


module ShouldBeApplicationOf where

data One : Set where one : One
data Two : Set where two : Two

f : One -> Two
f two = two