module Structure.LinearAlgebra where

import      Lvl
open import Data
open import Data.Tuple
open import Functional hiding (id)
open import Function.Equals
open import Function.Proofs
open import Logic
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Logic.Predicate
open import Numeral.CoordinateVector as Vec using () renaming (Vector to Vec)
open import Numeral.Finite
open import Numeral.Natural
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Proofs
-- open import Relator.Equals
-- open import Relator.Equals.Proofs
open import Structure.Setoid
open import Structure.Setoid.Uniqueness
open import Structure.Setoid.Uniqueness.Proofs
open import Structure.Function.Domain
import      Structure.Function.Linear as Linear
open import Structure.Operator.Field
open import Structure.Operator.Group
open import Structure.Operator.Properties hiding (commutativity)
open import Structure.Operator.Vector
open import Syntax.Number
open import Type

-- Finite dimensional linear algebra
-- TODO: Apparently, most of linear algebra will not work in constructive logic

module _
  {ℓᵥ ℓₛ : Lvl.Level}
  {V : Type{ℓᵥ}}
  ⦃ equiv-V : Equiv(V) ⦄
  {S : Type{ℓₛ}}
  ⦃ equiv-S : Equiv(S) ⦄
  {_+ᵥ_ : V → V → V}
  {_⋅ₛᵥ_ : S → V → V}
  {_+ₛ_ _⋅ₛ_ : S → S → S}
  ⦃ vectorSpace : VectorSpace(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_) ⦄
  where

  module _ where
    open VectorSpace(vectorSpace)

    -- A list of scalars
    Scalars : ℕ → Type
    Scalars(n) = Vec(n)(S) -- TODO: Prove that this type is a group if its underlying type (S) is a group. THen proceed to prove that injective-kernelᵣ holds with LinearCombination(_) being a homomorphism, which one can deduce that LinearlyIndependent is equivalent to Injective.

    -- A list of vectors
    Vectors : ℕ → Type
    Vectors(n) = Vec(n)(V)

    module _ where
      -- TODO: Make this a record instead, and then define an "eval"-function and prove LinearCombination-addition for this eval function (homomorphism)
      -- A specific linear combination of vectors (specific as specified by scalars).
      -- Linear combination of 0 scalars and vectors are the zero vector.
      -- Linear combination of 1 scalar and vector is just scalar on vector multiplication.
      -- Example: LinearCombination {4} sf vf = (sf[0] ⋅ₛᵥ vf[0]) +ᵥ (sf[1] ⋅ₛᵥ vf[1]) +ᵥ (sf[2] ⋅ₛᵥ vf[2]) +ᵥ (sf[3] ⋅ₛᵥ vf[3])
      LinearCombination : ∀{n} → Vectors(n) → Scalars(n) → V
      LinearCombination {0}       _ _ = 𝟎ᵥ
      LinearCombination {1}       vf sf = Vec.proj(sf)(0) ⋅ₛᵥ Vec.proj(vf)(0)
      LinearCombination {𝐒(𝐒(n))} vf sf = (Vec.proj(sf)(0) ⋅ₛᵥ Vec.proj(vf)(0)) +ᵥ (LinearCombination {𝐒(n)} (Vec.tail vf) (Vec.tail sf))

      postulate LinearCombination-addition    : ∀{n}{sf₁ sf₂}{vf} → (LinearCombination{n}(vf)(sf₁) +ᵥ LinearCombination{n}(vf)(sf₂) ≡ LinearCombination{n}(vf)(sf₁ ⦗ Vec.map₂ (_+ₛ_) ⦘ sf₂))
      postulate LinearCombination-subtraction : ∀{n}{sf₁ sf₂}{vf} → (LinearCombination{n}(vf)(sf₁) −ᵥ LinearCombination{n}(vf)(sf₂) ≡ LinearCombination{n}(vf)(sf₁ ⦗ Vec.map₂ (_−ₛ_) ⦘ sf₂))

      -- Spanning(vf) ⇔ (VSP = Span(vf))
      -- A set of vectors is spanning the vector space when every vector in the vector space can be represented as a linear combination of the set of vectors.
      Spanning : ∀{n} → Vectors(n) → Stmt
      Spanning(vf) = (∀{v} → ∃(sf ↦ LinearCombination(vf)(sf) ≡ v))

      -- Basis(vf) ⇔ (vf is a basis)
      -- A set of vectors is a basis when every vector in the vector space can be represented as a unique linear combination of the set of vectors.
      -- A set of vectors is a basis when they span the vector space and is linearly independent.
      Basis : ∀{n} → Vectors(n) → Stmt
      Basis(vf) = (∀{v} → ∃!(sf ↦ LinearCombination(vf)(sf) ≡ v)) -- TODO: Should be some kind of set equality. Could be impossible to prove the uniqueness otherwise because one can just permute for commutative scalars

      -- A set of vectors is linearly independent when there is no vector that can be represented as a linear combination by the others.
      LinearlyIndependent : ∀{n} → Vectors(n) → Stmt
      LinearlyIndependent{n}(vf) = ∀{sf} → (LinearCombination(vf)(sf) ≡ 𝟎ᵥ) → (∀{i} → Vec.proj(sf)(i) ≡ 𝟎ₛ) -- sf ⊜ fill(𝟎ₛ)

      postulate independent-injective : ∀{n}{vf} → LinearlyIndependent{n}(vf) ↔ (∀{sf₁ sf₂} → (LinearCombination(vf)(sf₁) ≡ LinearCombination(vf)(sf₂)) → (∀{i}→ Vec.proj(sf₁)(i) ≡ Vec.proj(sf₂)(i))) -- TODO: Vec.proj(sf₁) ⊜ Vec.proj(sf₂)
      -- TODO: Is there some axioms that make this happen? I remember this pattern from somewhere, that injectivity is equivalent to stuff being the identity of something. Maybe it is usually expressed using a kernel? See the note written above
      -- TODO: Express this as injectivity when `Injective` is general over setoids

      basis-span-independent : ∀{n}{vf : Vectors(n)} → Basis(vf) ↔ (Spanning(vf) ∧ LinearlyIndependent(vf))
      basis-span-independent{n}{vf} = [↔]-intro (uncurry l) (([↔]-to-[←] [→][∧]-distributivityₗ) ([∧]-intro r₁ r₂)) where
        l : Spanning(vf) → LinearlyIndependent(vf) → Basis(vf)
        l spanning indep {v} = [∃!]-intro existence uniqueness where
          existence : ∃(sf ↦ LinearCombination(vf)(sf) ≡ v)
          existence = spanning

          postulate uniqueness : Unique(sf ↦ LinearCombination(vf)(sf) ≡ v)
          -- uniqueness = ([↔]-elimₗ Uniqueness-Injectivity) (([↔]-elimᵣ independent-injective) indep)
          -- TODO: `Injective` over setoids is blocking this proof. It is at the moment proving something incorrect

        r₁ : Basis(vf) → Spanning(vf)
        r₁(proof) {v} = [∃!]-existence(proof{v})

        postulate r₂ : Basis(vf) → LinearlyIndependent(vf)
        -- TODO: `Injective` over setoids is blocking this proof. It is at the moment proving something incorrect

      -- Cardinality of a set of linearly independent vectors is always less than the cardinality of a set of spanning vectors
      postulate independent-less-than-spanning : ∀{n₁ n₂} → ∀{vf₁} → LinearlyIndependent{n₁}(vf₁) → ∀{vf₂} → Spanning{n₂}(vf₂) → (n₁ ≤ n₂)

      -- Existence of a subset of spanning vectors which is a basis
      -- TODO: postulate basis-from-spanning : ∀{n}{vf} → ⦃ _ : Spanning{n}(vf) ⦄ → ∃(m ↦ (m ≤ n) ∧ ∃(f ↦ Basis{n}(vf ∘ f) ∧ Injective(f)))

      -- Existence of a finite set of vectors which spans the vector space
      -- A "finite dimensional vector space" is sometimes defined as a vector space which satisfies this proposition.
      postulate span-existence : ∃(n ↦ ∃(vf ↦ Spanning{n}(vf)))
      -- TODO: Usually, this exists because one can take the whole set

      -- Existence of a basis
      postulate basis-existence : ∃(n ↦ ∃(vf ↦ Basis{n}(vf)))

      -- A set of linearly independent vectors is smaller than a set of basis vectors
      postulate independent-lesser-than-basis-number : ∀{m n} → {vfₘ : Vectors(m)} → LinearlyIndependent(vfₘ) → {vfₙ : Vectors(n)} → Basis(vfₙ) → (m ≤ n)

      -- Every set of basis vectors are equal in size
      postulate basis-equal-number : ∀{m n} → {vfₘ : Vectors(m)} → Basis(vfₘ) → {vfₙ : Vectors(n)} → Basis(vfₙ) → (m ≡ n)

      -- The dimension of the vector space
      dim :  ℕ
      dim = [∃]-witness(basis-existence)

      -- Existence of a superset of linearly independent vectors which is a basis
      -- TODO: basis-from-linearly-independent : ∀{n}{vf} → ⦃ _ : Spanning{n}(vf) ⦄ → ∃(m ↦ (m ≥ n) ∧ ∃(f ↦ Basis{n}(vf ∘ f) ∧ Injective(f)))

      postulate basis-from-dim-spanning : ∀{vf} → Spanning{dim}(vf) → Basis{dim}(vf)

      postulate basis-from-dim-independent : ∀{vf} → LinearlyIndependent{dim}(vf) → Basis{dim}(vf)

      -- TODO: Move to some algebraic structure?
      -- Nilpotent(f) = ∃(n ↦ ∀{v} → (f ^ n ≡ 𝟎ᵥ))

    module _ where
      private LinearMap = Linear.LinearMap(_+ᵥ_)(_⋅ₛᵥ_)(_+ᵥ_)(_⋅ₛᵥ_)

      postulate linear-map-id : LinearMap(Function.id)

      -- v is a eigenvector for the eigenvalue 𝜆 of the linear transformation f
      Eigenvector : (V → V) → S → V → Stmt
      Eigenvector(f)(𝜆)(v) = ((v ≢ 𝟎ᵥ) → (f(v) ≡ 𝜆 ⋅ₛᵥ v))

      -- 𝜆 is a eigenvalue of the linear transformation f
      -- Multiplication by an eigenvalue can replace a linear transformation for certain vectors.
      Eigenvalue : (V → V) → S → Stmt
      Eigenvalue(f)(𝜆) = (∀{v : V} → Eigenvector(f)(𝜆)(v))

      -- Two linear mappings are similiar when there is a basis in which they are equal.
      -- Similiar : (f : V → V) → ⦃ _ : LinearMap(f) ⦄ → (g : V → V) → ⦃ _ : LinearMap(g) ⦄ → Stmt
      -- Similiar(f)(g) = (∀{v} → ∃(b ↦ Bijective(b) ∧ (f(v) ≡ (b ∘ g ∘ (inv(b)))(v))))

    record DotProductSpace (_∙_ : V → V → S) (_≤_ : S → S → Stmt) : Stmt where
      field
        commutativity     : Commutativity(_∙_)
        linearmapₗ        : ∀{v₂} → Linear.LinearMap(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_) (_∙ v₂)
        positive          : ∀{v} → (𝟎ₛ ≤ (v ∙ v))
        injective-zero    : ∀{v} → ((v ∙ v) ≡ 𝟎ₛ) → (v ≡ 𝟎ᵥ)

      postulate [⋅ₛᵥ]-commuting : ∀{s}{v₁ v₂} → ((s ⋅ₛᵥ v₁) ∙ v₂) ≡ (v₁ ∙ (s ⋅ₛᵥ v₂))
      postulate almost-injectivity-zeroₗ : ∀{v₁} → (∀{v₂} → ((v₁ ∙ v₂) ≡ 𝟎ₛ)) → (v₁ ≡ 𝟎ᵥ)
      postulate injectivityₗ : ∀{v₁ v₂} → (∀{v₃} → ((v₁ ∙ v₃) ≡ (v₂ ∙ v₃))) → (v₁ ≡ v₂)

      module Norm (√ : S → S) where
        -- The length of a vector
        norm : V → S
        norm(v) = √(v ∙ v)

        -- The positive part of a scalar
        abs : S → S
        abs(s) = √(s ⋅ₛ s)

        postulate homogeneity : ∀{s}{v} → norm(s ⋅ₛᵥ v) ≡ abs(s) ⋅ₛ norm(v)
        postulate triangle-inequality : ∀{v₁ v₂} → (norm(v₁ +ᵥ v₂) ≤ (norm(v₁) +ₛ norm(v₂)))
        postulate positivity : ∀{v} → (𝟎ₛ ≤ norm(v))
        postulate injectivity-zero : ∀{v} → (norm(v) ≡ 𝟎ₛ) → (v ≡ 𝟎ᵥ)
        postulate mult-inequality : ∀{v₁ v₂} → (abs(v₁ ∙ v₂) ≤ (norm(v₁) ⋅ₛ norm(v₂)))

        -- Two vectors are orthogonal when they are perpendicular.
        Orthogonal : V → V → Stmt
        Orthogonal(v₁)(v₂) = (v₁ ∙ v₂ ≡ 𝟎ₛ)

        {-
        OrthogonalAll : ∀{n} → Vectors(n) → Stmt
        OrthogonalAll{0}       (vf) = ⊤
        OrthogonalAll{1}       (vf) = Orthogonal(vf(0))(vf(1))
        OrthogonalAll{𝐒(𝐒(n))} (vf) = (OrthogonalAll{n} (vf)) ∧ Orthogonal(vf(n))(vf(𝐒(n)))
        -}

        postulate hypotenuse-length : ∀{v₁ v₂} → ⦃ _ : Orthogonal(v₁)(v₂) ⦄ → ((v₁ +ᵥ v₂) ∙ (v₁ +ᵥ v₂) ≡ (v₁ ∙ v₁) +ₛ (v₂ ∙ v₂))

        -- Transforms a vector to an unit vector in the same direction.
        normalize : (v : V) → ⦃ _ : v ≢ 𝟎ᵥ ⦄ → V
        normalize(v) ⦃ proof ⦄ = (⅟ₛ (norm(v)) ⦃ contrapositiveᵣ (injectivity-zero) (proof) ⦄) ⋅ₛᵥ v

        postulate norm-of-normalize : ∀{v} → ⦃ nonzero : (v ≢ 𝟎ᵥ) ⦄ → (norm(normalize(v) ⦃ nonzero ⦄) ≡ 𝟏ₛ)

--  -- TODO: Is it okay for VSP₂ to have a different scalar field compared to VSP? Some stuff will not be compatible (like addition for the same scalar type)?
--  module _ {V₂} ⦃ lang₂ ⦄ (VSP₂ : VectorSpace(V₂)(S) ⦃ lang₂ ⦄) where
--    open Language ⦃ ... ⦄
--    open VectorSpace ⦃ ... ⦄
--
--    private _+ᵥ₁_ = _+ᵥ_ ⦃ lang ⦄
--    private _⋅ₛᵥ₁_ = _⋅ₛᵥ_ ⦃ lang ⦄
--    private _+ᵥ₂_ = _+ᵥ_ ⦃ lang₂ ⦄
--    private _⋅ₛᵥ₂_ = _⋅ₛᵥ_ ⦃ lang₂ ⦄
--
--    private LinearMap₁₂ = Linear.LinearMap(_+ᵥ₁_)(_⋅ₛᵥ₁_)(_+ᵥ₂_)(_⋅ₛᵥ₂_)
--    private LinearMap₂₁ = Linear.LinearMap(_+ᵥ₂_)(_⋅ₛᵥ₂_)(_+ᵥ₁_)(_⋅ₛᵥ₁_)
--
--    module _ where
--      -- Kernel(f)(v) ⇔ (v ∈ Kernel(f))
--      Kernel : (f : V → V₂) → ⦃ _ : LinearMap₁₂(f) ⦄ → V → Stmt
--      Kernel(f)(v) = (f(v) ≡ 𝟎ᵥ ⦃ lang₂ ⦄ ⦃ VSP₂ ⦄)
--
--      -- TODO: Move away the module for two vector spaces from one so that dim is not bound to V
--      -- rank : (V → V₂) → ℕ
--      -- rank(_) = dim ⦃ VSP₂ ⦄
--
--    module _ where
--      postulate linear-map-const-zero : LinearMap₁₂(const(𝟎ᵥ ⦃ lang₂ ⦄ ⦃ VSP₂ ⦄))
--
--      -- The inverse of an invertible linear mapping is a linear mapping
--      postulate linear-inverse : ∀{f} → ⦃ _ : Bijective(f) ⦄ → LinearMap₁₂(f) → LinearMap₂₁(inv(f))
--
--      -- Injectivity for only the zero vector implies injectivity
--      postulate injective-zero : ∀{f} → ⦃ _ : LinearMap₁₂(f) ⦄ → (∀{v} → (f(v) ≡ 𝟎ᵥ ⦃ lang₂ ⦄ ⦃ VSP₂ ⦄) → (v ≡ 𝟎ᵥ ⦃ lang ⦄ ⦃ VSP ⦄)) → Injective(f)
--
--    -- module _ {_∙₁_ : V → V → S}{_≤₁_} {_∙₂_ : V₂ → V₂ → S}{_≤₂_} (DPSP₁ : DotProductSpace(_∙₁_)(_≤₁_)) (DPSP₂ : DotProductSpace(_∙₂_)(_≤₂_)) where
--    --   Adjoint : (f : V → V₂) → ⦃ _ : LinearMap₁₂(f) ⦄ → (g : V₂ → V) → ⦃ _ : LinearMap₂₁(g) ⦄ → Stmt
--    --   Adjoint(f)(g) = (∀{v₁ : V}{v₂ : V₂} → (f(v₁) ∙₂ v₂ ≡ v₁ ∙₁ g(v₂)))


{-
   FP Lunch, Nottingham
   July 27, 2007
   Conor McBride
-}

module Binary where

data Bit : Set where
  O : Bit
  I : Bit

infixl 80 _<<_

data Pos : Set where
  <<I  : Pos
  _<<_ : Pos -> Bit -> Pos

bsuc : Pos -> Pos
bsuc <<I      = <<I << O
bsuc (n << O) = n << I
bsuc (n << I) = bsuc n << O

data Peano : Pos -> Set where
  pI   : Peano <<I
  psuc : {n : Pos} -> Peano n -> Peano (bsuc n)

pdouble : {n : Pos} -> Peano n -> Peano (n << O)
pdouble pI       = psuc pI
pdouble (psuc p) = psuc (psuc (pdouble p))

peano : (n : Pos) -> Peano n
peano <<I      = pI
peano (n << O) = pdouble (peano n)
peano (n << I) = psuc (pdouble (peano n))

-- Slow addition (yay!)
_+_ : Pos -> Pos -> Pos
_+_ n m = peano n <+> m
  where
    _<+>_ : {n : Pos} -> Peano n -> Pos -> Pos
    pI     <+> m = bsuc m
    psuc p <+> m = bsuc (p <+> m)

infixl 60 _+_
infix  40 _==_

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

{-
test : (<<I << I << O << O << O) == (<<I << I << O << I) + (<<I << O << I << I)
test = refl
-}

{-
simple : (<<I << O) == (<<I) + (<<I)
simple = refl
-}

{-
t : Peano _
t = peano (<<I)
-}

{-
t : Pos
t = bsuc (<<I)
-}

{-
t : Pos
t = peano (<<I << O) <+> (<<I << I)
-- t = psuc pI <+> (<<I)
  where
    _<+>_ : {n : Pos} -> Peano n -> Pos -> Pos
    pI     <+> m = bsuc m
    psuc p <+> m = bsuc (p <+> m)
-}

t1 : Pos
t1 = (<<I << O) + (<<I << O)

t2 : (<<I) + (<<I) == (<<I) + (<<I)
t2 = refl


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

open import Categories.Category

module Categories.Functor.Hom.Properties.Contra {o ℓ e} (C : Category o ℓ e) where

private
  module C = Category C

open import Level
open import Function.Equality renaming (id to idFun)

open import Categories.Category.Instance.Setoids
open import Categories.Diagram.Limit
open import Categories.Diagram.Limit.Properties
open import Categories.Diagram.Colimit
open import Categories.Diagram.Duality
open import Categories.Functor
open import Categories.Functor.Hom
open import Categories.Functor.Hom.Properties.Covariant C.op
open import Categories.NaturalTransformation
open import Categories.NaturalTransformation.NaturalIsomorphism

private
  variable
    o′ ℓ′ e′ : Level
    J : Category o′ ℓ′ e′

open C
open Hom C

-- contravariant hom functor sends colimit of F to its limit.
module _ (W : Obj) {F : Functor J C} (col : Colimit F) where
  private
    module F = Functor F
    module J = Category J
    open HomReasoning

    HomF : Functor J.op (Setoids ℓ e)
    HomF = Hom[-, W ] ∘F F.op

  hom-colimit⇒limit : Limit HomF
  hom-colimit⇒limit = ≃-resp-lim (Hom≃ ⓘʳ F.op) (hom-resp-limit W (Colimit⇒coLimit _ col))
    where Hom≃ : Hom[ op ][ W ,-] ≃ Hom[-, W ]
          Hom≃ = record
            { F⇒G = ntHelper record
              { η       = λ _ → idFun
              ; commute = λ _ eq → C.∘-resp-≈ˡ (C.∘-resp-≈ʳ eq) ○ C.assoc
              }
            ; F⇐G = ntHelper record
              { η       = λ _ → idFun
              ; commute = λ _ eq → C.sym-assoc ○ C.∘-resp-≈ˡ (C.∘-resp-≈ʳ eq)
              }
            ; iso = λ _ → record
              { isoˡ = λ eq → eq
              ; isoʳ = λ eq → eq
              }
            }


{-
  Definition of various kinds of categories.

  This library follows the UniMath terminology, that is:

  Concept              Ob C   Hom C  Univalence

  Precategory          Type   Type   No
  Category             Type   Set    No
  Univalent Category   Type   Set    Yes

  This file also contains
    - pathToIso : Turns a path between two objects into an isomorphism between them
    - opposite categories

-}

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

module Cubical.Categories.Category where

open import Cubical.Categories.Category.Base public
open import Cubical.Categories.Category.Properties public


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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Data.Sigma
open import Cubical.Data.Nat using (ℕ ; suc ; zero)
open import Cubical.Data.Fin using (Fin ; isSetFin)
open import Cubical.Data.Empty
open import Cubical.Relation.Nullary using (¬_)

open import Cubical.Algebra.Group

private
  variable
    ℓ : Level

Symmetric-Group : (X : Type ℓ) → isSet X → Group {ℓ}
Symmetric-Group X isSetX = makeGroup (idEquiv X) compEquiv invEquiv (isOfHLevel≃ 2 isSetX isSetX)
  compEquiv-assoc compEquivEquivId compEquivIdEquiv invEquiv-is-rinv invEquiv-is-linv

-- Finite symmetrics groups

Sym : ℕ → Group
Sym n = Symmetric-Group (Fin n) isSetFin


------------------------------------------------------------------------
-- The Agda standard library
--
-- Closures of a unary relation with respect to a binary one.
------------------------------------------------------------------------

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

open import Relation.Binary

module Relation.Unary.Closure.Base {a b} {A : Set a} (R : Rel A b) where

open import Level
open import Relation.Unary using (Pred)

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

-- We start with the definition of □ ("box") which is named after the box
-- modality in modal logic. `□ T x` states that all the elements one step
-- away from `x` with respect to the relation R satisfy `T`.

□ : ∀ {t} → Pred A t → Pred A (a ⊔ b ⊔ t)
□ T x = ∀ {y} → R x y → T y

-- Use cases of □ include:
-- * The definition of the accessibility predicate corresponding to R:
--   data Acc (x : A) : Set (a ⊔ b) where
--     step : □ Acc x → Acc x

-- * The characterization of stability under weakening: picking R to be
--   `Data.List.Relation.Sublist.Inductive`, `∀ {Γ} → Tm Γ → □ T Γ`
--   corresponds to the fact that we have a notion of weakening for `Tm`.

-- Closed: whenever we have a value in one context, we can get one in any
-- related context.

record Closed {t} (T : Pred A t) : Set (a ⊔ b ⊔ t) where
  field next : ∀ {x} → T x → □ T x

------------------------------------------------------------------------
-- Properties

module _ {t} {T : Pred A t} where

  reindex : Transitive R → ∀ {x y} → R x y → □ T x → □ T y
  reindex trans x∼y □Tx y∼z = □Tx (trans x∼y y∼z)

  -- Provided that R is reflexive and Transitive, □ is a comonad
  map : ∀ {u} {U : Pred A u} {x} → (∀ {x} → T x → U x) → □ T x → □ U x
  map f □Tx x~y = f (□Tx x~y)

  extract : Reflexive R → ∀ {x} → □ T x → T x
  extract refl □Tx = □Tx refl

  duplicate : Transitive R → ∀ {x} → □ T x → □ (□ T) x
  duplicate trans □Tx x∼y y∼z = □Tx (trans x∼y y∼z)

-- Provided that R is transitive, □ is the Closure operator
-- i.e. for any `T`, `□ T` is closed.
□-closed : Transitive R → ∀ {t} {T : Pred A t} → Closed (□ T)
□-closed trans = record { next = duplicate trans }


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

module Categories.Bicategory where

open import Level
open import Data.Product using (_,_)
open import Relation.Binary using (Rel)

open import Categories.Category using (Category; module Commutation)
open import Categories.Category.Monoidal.Instance.Cats using (module Product)
open import Categories.Enriched.Category using () renaming (Category to Enriched)
open import Categories.Functor using (module Functor)
open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism)

-- https://ncatlab.org/nlab/show/bicategory
-- notice that some axioms in nLab are inconsistent. they have been fixed in this definition.
record Bicategory o ℓ e t : Set (suc (o ⊔ ℓ ⊔ e ⊔ t)) where
  field
    enriched : Enriched (Product.Cats-Monoidal {o} {ℓ} {e}) t

  open Enriched enriched public
  module hom {A B} = Category (hom A B)
  module ComHom {A B} = Commutation (hom A B)

  infix 4 _⇒₁_ _⇒₂_ _≈_
  infixr 7 _∘ᵥ_ _∘₁_
  infixr 9 _▷_
  infixl 9 _◁_
  infixr 11 _⊚₀_ _⊚₁_  _∘ₕ_

  _⇒₁_ : Obj → Obj → Set o
  A ⇒₁ B = Category.Obj (hom A B)

  _⇒₂_ : {A B : Obj} → A ⇒₁ B → A ⇒₁ B → Set ℓ
  _⇒₂_ = hom._⇒_

  _⊚₀_ : {A B C : Obj} → B ⇒₁ C → A ⇒₁ B → A ⇒₁ C
  f ⊚₀ g = Functor.F₀ ⊚ (f , g)

  _⊚₁_ : {A B C : Obj} {f h : B ⇒₁ C} {g i : A ⇒₁ B} → f ⇒₂ h → g ⇒₂ i → f ⊚₀ g ⇒₂ h ⊚₀ i
  α ⊚₁ β = Functor.F₁ ⊚ (α , β)

  _≈_ : {A B : Obj} {f g : A ⇒₁ B} → Rel (f ⇒₂ g) e
  _≈_ = hom._≈_

  id₁ : {A : Obj} → A ⇒₁ A
  id₁ {_} = Functor.F₀ id _

  id₂ : {A B : Obj} {f : A ⇒₁ B} → f ⇒₂ f
  id₂ {A} {B} = Category.id (hom A B)

  -- 1-cell composition
  _∘₁_ : {A B C : Obj} → B ⇒₁ C → A ⇒₁ B → A ⇒₁ C
  _∘₁_ = _⊚₀_

  -- horizontal composition
  _∘ₕ_ : {A B C : Obj} {f h : B ⇒₁ C} {g i : A ⇒₁ B} → f ⇒₂ h → g ⇒₂ i → f ⊚₀ g ⇒₂ h ⊚₀ i
  _∘ₕ_ = _⊚₁_

  -- vertical composition
  _∘ᵥ_ : {A B : Obj} {f g h : A ⇒₁ B} (α : g ⇒₂ h) (β : f ⇒₂ g) → f ⇒₂ h
  _∘ᵥ_ = hom._∘_

  _◁_ : {A B C : Obj} {g h : B ⇒₁ C} (α : g ⇒₂ h) (f : A ⇒₁ B) → g ∘₁ f ⇒₂ h ∘₁ f
  α ◁ _ = α ⊚₁ id₂

  _▷_ : {A B C : Obj} {f g : A ⇒₁ B} (h : B ⇒₁ C) (α : f ⇒₂ g) → h ∘₁ f ⇒₂ h ∘₁ g
  _ ▷ α = id₂ ⊚₁ α

  private
    λ⇒ : {A B : Obj} {f : A ⇒₁ B} → id₁ ⊚₀ f hom.⇒ f
    λ⇒ {_} {_} {f} = NaturalIsomorphism.⇒.η unitˡ (_ , f)

    ρ⇒ : {A B : Obj} {f : A ⇒₁ B} → f ⊚₀ id₁ hom.⇒ f
    ρ⇒ {_} {_} {f} = NaturalIsomorphism.⇒.η unitʳ (f , _)

    α⇒ : {A B C D : Obj} {f : D ⇒₁ B} {g : C ⇒₁ D} {h : A ⇒₁ C} →
          ((f ⊚₀ g) ⊚₀ h) hom.⇒ (f ⊚₀ (g ⊚₀ h))
    α⇒ {_} {_} {_} {_} {f} {g} {h} = NaturalIsomorphism.⇒.η ⊚-assoc ((f , g) , h)

  field
    triangle : {A B C : Obj} {f : A ⇒₁ B} {g : B ⇒₁ C} →
                 let open ComHom {A} {C} in
                 [ (g ∘₁ id₁) ∘₁ f ⇒ g ∘₁ f ]⟨
                   α⇒                 ⇒⟨ g ∘₁ id₁ ∘₁ f ⟩
                   g ▷ λ⇒
                 ≈ ρ⇒ ◁ f
                 ⟩
    pentagon : {A B C D E : Obj} {f : A ⇒₁ B} {g : B ⇒₁ C} {h : C ⇒₁ D} {i : D ⇒₁ E} →
                 let open ComHom {A} {E} in
                 [ ((i ∘₁ h) ∘₁ g) ∘₁ f ⇒ i ∘₁ h ∘₁ g ∘₁ f ]⟨
                   α⇒ ◁ f                     ⇒⟨ (i ∘₁ h ∘₁ g) ∘₁ f ⟩
                   α⇒                         ⇒⟨ i ∘₁ (h ∘₁ g) ∘₁ f ⟩
                   i ▷ α⇒
                 ≈ α⇒                         ⇒⟨ (i ∘₁ h) ∘₁ g ∘₁ f ⟩
                   α⇒
                 ⟩


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

module Categories.Product where

open import Prelude hiding (_×_)
open import Categories

module _ {ℓ₁ ℓ₂} (C : Category ℓ₁ ℓ₂) where
  open Category C

  module _ (X Y : Ob) where
    record Product : Type (ℓ₁ ℓ⊔ ℓ₂) where
      field
        obj : Ob
        proj₁ : C [ obj , X ]
        proj₂ : C [ obj , Y ]
        ump : (f : C [ Z , X ]) (g : C [ Z , Y ]) →
              ∃![ f×g ] ((C [ proj₁ ∘ f×g ] ≡ f) Prelude.× (C [ proj₂ ∘ f×g ] ≡ g))
      _P[_×_] : ∀ {Z} → (π₁ : C [ Z , X ]) (π₂ : C [ Z , Y ]) →
                C [ Z , obj ]
      _P[_×_] π₁ π₂ = fst (ump π₁ π₂)

  record HasProducts : Type (ℓ₁ ℓ⊔ ℓ₂) where
    field product : (X Y : Ob) → Product X Y

    _×_ : Ob → Ob → Ob
    A × B = Product.obj (product A B)

    module _ {A A′ B B′ : Ob} where
      open Product using (_P[_×_])
      open Product (product A B) hiding (_P[_×_])

      _|×|_ : C [ A , A′ ] → C [ B , B′ ] → C [ Product.obj (product A B) , Product.obj (product A′ B′) ]
      f |×| g = product A′ B′ P[ C [ f ∘ proj₁ ] × C [ g ∘ proj₂ ] ]


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Unit.Properties where

open import Cubical.Core.Everything

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

open import Cubical.Data.Nat
open import Cubical.Data.Unit.Base
open import Cubical.Data.Prod.Base

open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv

isContr⊤ : isContr ⊤
isContr⊤ = tt , λ {tt → refl}

isProp⊤ : isProp ⊤
isProp⊤ _ _ i = tt -- definitionally equal to: isContr→isProp isContrUnit

isSet⊤ : isSet ⊤
isSet⊤ = isProp→isSet isProp⊤

isOfHLevel⊤ : (n : HLevel) → isOfHLevel n ⊤
isOfHLevel⊤ n = isContr→isOfHLevel n isContr⊤

diagonal-unit : ⊤ ≡ ⊤ × ⊤
diagonal-unit = isoToPath (iso (λ x → tt , tt) (λ x → tt) (λ {(tt , tt) i → tt , tt}) λ {tt i → tt})

fibId : ∀ {ℓ} (A : Type ℓ) → (fiber (λ (x : A) → tt) tt) ≡ A
fibId A = isoToPath
            (iso fst
                 (λ a → a , refl)
                 (λ _ → refl)
                 (λ a i → fst a
                         , isOfHLevelSuc 1 isProp⊤ _ _ (snd a) refl i))


{-# OPTIONS --cubical --no-import-sorts --no-exact-split --safe #-}
module Cubical.Experiments.NatMinusTwo.Base where

open import Cubical.Core.Primitives
open import Cubical.Data.Nat
open import Cubical.Data.Empty

record ℕ₋₂ : Type₀ where
  constructor -2+_
  field
    n : ℕ

pattern neg2 = -2+ zero
pattern neg1 = -2+ (suc zero)
pattern ℕ→ℕ₋₂ n = -2+ (suc (suc n))
pattern -1+_ n = -2+ (suc n)

2+_ : ℕ₋₂ → ℕ
2+ (-2+ n) = n

pred₋₂ : ℕ₋₂ → ℕ₋₂
pred₋₂ neg2 = neg2
pred₋₂ neg1 = neg2
pred₋₂ (ℕ→ℕ₋₂ zero) = neg1
pred₋₂ (ℕ→ℕ₋₂ (suc n)) = (ℕ→ℕ₋₂ n)

suc₋₂ : ℕ₋₂ → ℕ₋₂
suc₋₂ (-2+ n) = -2+ (suc n)

-- Natural number and negative integer literals for ℕ₋₂

open import Cubical.Data.Nat.Literals public

instance
  fromNatℕ₋₂ : HasFromNat ℕ₋₂
  fromNatℕ₋₂ = record { Constraint = λ _ → Unit ; fromNat = ℕ→ℕ₋₂ }

instance
  fromNegℕ₋₂ : HasFromNeg ℕ₋₂
  fromNegℕ₋₂ = record { Constraint = λ { (suc (suc (suc _))) → ⊥ ; _ → Unit }
                       ; fromNeg = λ { zero → 0 ; (suc zero) → neg1 ; (suc (suc zero)) → neg2 } }


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

open import Algebra.Structures.Bundles.Field

module Algebra.Linear.Construct.Matrix.Square
  {k ℓ} (K : Field k ℓ)
  where

open import Level using (_⊔_)
open import Data.Nat using (ℕ)
open import Data.Fin
open import Data.Product

open import Algebra.Structures.Field.Utils K
open import Algebra.Linear.Construct.Matrix K public

module F = Field K

private
  M : ℕ -> Set k
  M n = Matrix n n

  K' : Set k
  K' = F.Carrier

UpperTriangular : ℕ -> Set (k ⊔ ℓ)
UpperTriangular n = ∃ λ (A : M n) -> ∀ {i j} -> j ≤ i -> (A ⟪ i , j ⟫) F.≈ F.0#

LowerTriangular : ℕ -> Set (k ⊔ ℓ)
LowerTriangular n = ∃ λ (A : M n) -> ∀ {i j} -> i ≤ j -> (A ⟪ i , j ⟫) F.≈ F.0#

Invertible : ℕ -> Set (k ⊔ ℓ)
Invertible n = ∃₂ λ (A B : M n) -> (A * B) ≈ I n ×  (B * A) ≈ I n

trace : ∀ {n} -> M n n -> K'
trace A = vsum (V.tabulate λ i → A ⟪ i , i ⟫)

det : ∀ {n} -> M n -> K'
det A = {!!}


{-

Part 3: Transport and composition

- Cubical transport
- Subst as a special case of cubical transport
- Path induction from subst?
- Homogeneous composition (hcomp)
- Binary composition of paths as special case of hcomp

-}

{-# OPTIONS --cubical #-}
module Part2 where

open import Part1 public

-- Transport is more complex as ≡ isn't inductively defined (so we
-- can't define it by pattern-matching on p)
transport : {A B : Type ℓ} → A ≡ B → A → B
transport p a = transp (λ i → p i) i0 a

-- This lets us define subst (which is called "transport" in the HoTT book)
subst : {A : Type ℓ} (P : A → Type ℓ') {x y : A} (p : x ≡ y) → P x → P y
subst P p pa = transport (λ i → P (p i)) pa

-- The transp operation reduces differently for different types
-- formers. For paths it reduces to another primitive operation called
-- hcomp.

-- We can also define the J eliminator (aka path induction)
-- TODO: rewrite using subst?
-- TODO: talk about ∧
J : {A : Type ℓ} {B : A → Type ℓ'} {x : A}
    (P : (z : A) → x ≡ z → Type ℓ'')
    (d : P x refl) {y : A} (p : x ≡ y) → P y p
J P d p = transport (λ i → P (p i) (λ j → p (i ∧ j))) d

-- So J is provable, but it doesn't satisfy computation rule
-- definitionally. This is almost never a problem in practice as the
-- cubical primitives satisfy many new definitional equalities.


{-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.data:25 #-}
-- {-# OPTIONS -v tc.conv.coerce:0 -v tc.with:25 #-}

module FilterSub where

open import Common.Level
open import Common.Equality

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

data Bool : Set where
  true false : Bool

if_then_else_ : ∀ {a}{A : Set a} → Bool → A → A → A
if true  then t else e = t
if false then t else e = e

data Maybe {a} (A : Set a) : Set a where
  nothing : Maybe A
  just    : A → Maybe A

infixr 5 _∷_

data List {a} (A : Set a) : Set a where
  []  : List A
  _∷_ : (x : A) (xs : List A) → List A

data Any {a p} {A : Set a}
         (P : A → Set p) : List A → Set (a ⊔ p) where
  here  : ∀ {x xs} (px  : P x)      → Any P (x ∷ xs)
  there : ∀ {x xs} (pxs : Any P xs) → Any P (x ∷ xs)

infix 4 _⊆_ _∈_

_∈_ : ∀ {a}{A : Set a} → A → List A → Set _
x ∈ xs = Any (_≡_ x) xs

_⊆_ : ∀ {a}{A : Set a} → List A → List A → Set _
xs ⊆ ys = ∀ {x} → x ∈ xs → x ∈ ys

filter : ∀ {a} {A : Set a} → (A → Bool) → List A → List A
filter p []       = []
filter p (x ∷ xs) with p x
... | true  = x ∷ filter p xs
... | false =     filter p xs

filter-⊆ : ∀ {a} {A : Set a} (p : A → Bool) →
           (xs : List A) → filter p xs ⊆ xs
filter-⊆ _ []       = λ ()
filter-⊆ p (x ∷ xs) with p x | filter-⊆ p xs
... | false | hyp = there ∘ hyp
... | true  | hyp =
  λ { (here  eq)      → here eq
    ; (there ∈filter) → there (hyp ∈filter)
    }


{-# OPTIONS --without-K --safe #-}
open import Categories.Category

module Categories.Category.CartesianClosed {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level
open import Function using (_$_; flip)
open import Data.Product using (Σ; _,_; uncurry)

open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Bifunctor
open import Categories.NaturalTransformation hiding (id)
open import Categories.NaturalTransformation.Properties
open import Categories.Category.Cartesian 𝒞
open import Categories.Category.Monoidal.Closed
open import Categories.Object.Product 𝒞
  hiding (repack≡id; repack∘; repack-cancel; up-to-iso; transport-by-iso)
open import Categories.Object.Exponential 𝒞 hiding (repack)
open import Categories.Morphism 𝒞
open import Categories.Morphism.Reasoning 𝒞

private
  module 𝒞 = Category 𝒞
  open Category 𝒞
  open HomReasoning
  variable
    A B C   : Obj
    f g h i : A ⇒ B

-- Cartesian closed category
--   is a category with all products and exponentials
record CartesianClosed : Set (levelOfTerm 𝒞) where
  infixr 9 _^_
  -- an alternative notation for exponential, which emphasizes its internal hom natural
  infixr 5 _⇨_

  field
    cartesian : Cartesian
    exp       : Exponential A B

  module exp {A B} = Exponential (exp {A} {B})

  _^_ : Obj → Obj → Obj
  B ^ A = exp.B^A {A} {B}

  _⇨_ : Obj → Obj → Obj
  _⇨_ = flip _^_

  module cartesian = Cartesian cartesian

  open cartesian public

  B^A×A : ∀ B A → Product (B ^ A) A
  B^A×A B A = exp.product {A} {B}

  eval : Product.A×B (B^A×A B A) ⇒ B
  eval = exp.eval

  λg : C × A ⇒ B → C ⇒ B ^ A
  λg f = exp.λg product f

  λ-cong : f ≈ g → λg f ≈ λg g
  λ-cong eq = exp.λ-cong product eq

  _×id : (f : C ⇒ B ^ A) → C × A ⇒ [[ B^A×A B A ]]
  f ×id = [ product ⇒ exp.product ] f ×id

  β : eval ∘ λg f ×id ≈ f
  β = exp.β product

  η-exp : λg (eval ∘ f ×id) ≈ f
  η-exp = exp.η product

  λ-unique : eval ∘ f ×id ≈ g → f ≈ λg g
  λ-unique = exp.λ-unique product

  λ-unique₂ : eval ∘ f ×id ≈ eval ∘ g ×id → f ≈ g
  λ-unique₂ = exp.λ-unique′ product

  -- the annoying detail is that B^A×A is NOT the same as B ^ A × A, but they are isomorphic.
  -- make some infra so that the latter (which is more intuitive) can be used.

  B^A×A-iso : Product.A×B (B^A×A B A) ≅ B ^ A × A
  B^A×A-iso {B = B} {A = A} = record
    { from = repack exp.product product
    ; to   = repack product exp.product
    ; iso  = record
      { isoˡ = begin
        repack product exp.product ∘ repack exp.product product
          ≈⟨ [ exp.product ]⟨⟩∘ ⟩
        [ exp.product ]⟨ π₁ ∘ repack exp.product product , π₂ ∘ repack exp.product product ⟩
          ≈⟨ Product.⟨⟩-cong₂ exp.product project₁ project₂ ⟩
        [ exp.product ]⟨ [ exp.product ]π₁ , [ exp.product ]π₂ ⟩
          ≈⟨ Product.η exp.product ⟩
        id
          ∎
      ; isoʳ = begin
        repack exp.product product ∘ repack product exp.product
          ≈⟨ ⟨⟩∘ ⟩
        ⟨ [ exp.product ]π₁ ∘ repack product exp.product , [ exp.product ]π₂ ∘ repack product exp.product ⟩
          ≈⟨ ⟨⟩-cong₂ (Product.project₁ exp.product) (Product.project₂ exp.product) ⟩
        ⟨ π₁ , π₂ ⟩
          ≈⟨ η ⟩
        id
          ∎
      }
    }

  eval′ : B ^ A × A ⇒ B
  eval′ = eval ∘ to
    where open _≅_ B^A×A-iso

  λ-unique′ : eval′ ∘ (f ⁂ id) ≈ g → f ≈ λg g
  λ-unique′ eq = exp.λ-unique product (⟺ (pullʳ [ product ⇒ product ⇒ exp.product ]repack∘×) ○ eq)

  λ-unique₂′ : eval′ ∘ (f ⁂ id) ≈ eval′ ∘ (g ⁂ id) → f ≈ g
  λ-unique₂′ eq = (λ-unique′ eq) ○ ⟺ (λ-unique′ refl)

  β′ : eval′ ∘ (λg f ⁂ id) ≈ f
  β′ {f = f} = begin
    eval′ ∘ (λg f ⁂ id) ≈⟨ pullʳ [ product ⇒ product ⇒ exp.product ]repack∘× ⟩
    eval ∘ λg f ×id     ≈⟨ β ⟩
    f                   ∎

  η-exp′ : λg (eval′ ∘ (f ⁂ id)) ≈ f
  η-exp′ = sym (λ-unique′ refl)

  η-id′ : λg (eval′ {B = B} {A = A}) ≈ id
  η-id′ = sym (λ-unique′ (elimʳ (id×id product)))

  ⊤^A≅⊤ : ⊤ ^ A ≅ ⊤
  ⊤^A≅⊤ = record
    { from = !
    ; to   = λg !
    ; iso  = record
      { isoˡ = λ-unique₂ !-unique₂
      ; isoʳ = ⊤-id _
      }
    }

  A^⊤≅A : A ^ ⊤ ≅ A
  A^⊤≅A = record
    { from = let open _≅_ A×⊤≅A in eval′ ∘ to
    ; to   = let open _≅_ A×⊤≅A in λg from
    ; iso  = record
      { isoˡ = λ-unique₂′ $ begin
        eval′ ∘ ((λg π₁ ∘ eval′ ∘ ⟨ id , ! ⟩) ⁂ id)          ≈˘⟨ refl⟩∘⟨ first∘first ⟩
        eval′ ∘ ((λg π₁ ⁂ id) ∘ ((eval′ ∘ ⟨ id , ! ⟩) ⁂ id)) ≈⟨ pullˡ β′ ⟩
        π₁ ∘ ((eval′ ∘ ⟨ id , ! ⟩) ⁂ id)                     ≈⟨ helper ⟩
        eval′ ∘ (id ⁂ id)                                    ∎
      ; isoʳ = firstid ! $ begin
        ((eval′ ∘ ⟨ id , ! ⟩) ∘ λg π₁) ⁂ id                  ≈˘⟨ first∘first ⟩
        (eval′ ∘ ⟨ id , ! ⟩ ⁂ id) ∘ (λg π₁ ⁂ id)             ≈⟨ helper′ ⟩∘⟨refl ⟩
        (⟨ id , ! ⟩ ∘ eval′) ∘ (λg π₁ ⁂ id)                  ≈⟨ pullʳ β′ ⟩
        ⟨ id , ! ⟩ ∘ π₁                                      ≈⟨ ⟨⟩∘ ⟩
        ⟨ id ∘ π₁ , ! ∘ π₁ ⟩                                 ≈⟨ ⟨⟩-cong₂ identityˡ !-unique₂ ⟩
        ⟨ π₁ , π₂ ⟩                                          ≈⟨ η ⟩
        id                                                   ∎
      }
    }
    where helper = begin
            π₁ ∘ ((eval′ ∘ ⟨ id , ! ⟩) ⁂ id)                 ≈⟨ project₁ ⟩
            (eval′ ∘ ⟨ id , ! ⟩) ∘ π₁                        ≈⟨ pullʳ ⟨⟩∘ ⟩
            eval′ ∘ ⟨ id ∘ π₁ , ! ∘ π₁ ⟩                     ≈⟨ refl⟩∘⟨ ⟨⟩-congˡ !-unique₂ ⟩
            eval′ ∘ (id ⁂ id)                                ∎
          helper′ = let open _≅_ A×⊤≅A in begin
            (eval′ ∘ ⟨ id , ! ⟩) ⁂ id                        ≈⟨ introˡ isoˡ ⟩
            (⟨ id , ! ⟩ ∘ π₁) ∘ ((eval′ ∘ ⟨ id , ! ⟩) ⁂ id)  ≈⟨ pullʳ helper ⟩
            ⟨ id , ! ⟩ ∘ (eval′ ∘ (id ⁂ id))                 ≈⟨ refl⟩∘⟨ elimʳ (id×id product) ⟩
            ⟨ id , ! ⟩ ∘ eval′                               ∎

  -- we use -⇨- to represent the bifunctor.
  -- -^- would generate a bifunctor of type Bifunctor 𝒞 𝒞.op 𝒞 which is not very typical.
  -⇨- : Bifunctor 𝒞.op 𝒞 𝒞
  -⇨- = record
    { F₀           = uncurry _⇨_
    ; F₁           = λ where
      (f , g) → λg (g ∘ eval′ ∘ second f)
    ; identity     = λ-cong (identityˡ ○ (elimʳ (id×id product))) ○ η-id′
    ; homomorphism = λ-unique₂′ helper
    ; F-resp-≈     = λ where
      (eq₁ , eq₂) → λ-cong (∘-resp-≈ eq₂ (∘-resp-≈ʳ (⁂-cong₂ refl eq₁)))
    }
    where helper : eval′ ∘ first (λg ((g ∘ f) ∘ eval′ ∘ second (h ∘ i)))
                 ≈ eval′ ∘ first (λg (g ∘ eval′ ∘ second i) ∘ λg (f ∘ eval′ ∘ second h))
          helper {g = g} {f = f} {h = h} {i = i} = begin
            eval′ ∘ first (λg ((g ∘ f) ∘ eval′ ∘ second (h ∘ i)))                         ≈⟨ β′ ⟩
            (g ∘ f) ∘ eval′ ∘ second (h ∘ i)                                              ≈˘⟨ refl⟩∘⟨ pullʳ second∘second ⟩
            (g ∘ f) ∘ (eval′ ∘ second h) ∘ second i                                       ≈˘⟨ pullˡ refl ⟩
            g ∘ f ∘ (eval′ ∘ second h) ∘ second i                                         ≈˘⟨ refl⟩∘⟨ assoc ⟩
            g ∘ (f ∘ eval′ ∘ second h) ∘ second i                                         ≈˘⟨ refl⟩∘⟨ pullˡ β′ ⟩
            g ∘ eval′ ∘ first (λg (f ∘ eval′ ∘ second h)) ∘ second i                      ≈⟨ refl⟩∘⟨ pushʳ first↔second ⟩
            g ∘ (eval′ ∘ second i) ∘ first (λg (f ∘ eval′ ∘ second h))                    ≈˘⟨ assoc ⟩
            (g ∘ eval′ ∘ second i) ∘ first (λg (f ∘ eval′ ∘ second h))                    ≈˘⟨ pullˡ β′ ⟩
            eval′ ∘ first (λg (g ∘ eval′ ∘ second i)) ∘ first (λg (f ∘ eval′ ∘ second h)) ≈⟨ refl⟩∘⟨ first∘first ⟩
            eval′ ∘ first (λg (g ∘ eval′ ∘ second i) ∘ λg (f ∘ eval′ ∘ second h))         ∎

  _⇨- : Obj → Endofunctor 𝒞
  _⇨- = appˡ -⇨-

  -⇨_ : Obj → Functor 𝒞.op 𝒞
  -⇨_ = appʳ -⇨-

  module _ where
    private
      A⇨[-×A] : Obj → Endofunctor 𝒞
      A⇨[-×A] A = A ⇨- ∘F -× A

      module A⇨[-×A] {A} = Functor (A⇨[-×A] A)

      [A⇨-]×A : Obj → Endofunctor 𝒞
      [A⇨-]×A A = -× A ∘F A ⇨-

      module [A⇨-]×A {A} = Functor ([A⇨-]×A A)

    closedMonoidal : Closed monoidal
    closedMonoidal = record
      { [-,-]   = -⇨-
      ; adjoint = λ {A} → record
        { unit   = ntHelper record
          { η       = λ _ → λg id
          ; commute = λ f → λ-unique₂′ $ begin
            eval′ ∘ first (λg id ∘ f)                     ≈˘⟨ refl⟩∘⟨ first∘first ⟩
            eval′ ∘ first (λg id) ∘ first f               ≈⟨ cancelˡ β′ ⟩
            first f                                       ≈˘⟨ cancelʳ β′ ⟩
            (first f ∘ eval′)  ∘ first (λg id)            ≈˘⟨ ∘-resp-≈ʳ (elimʳ (id×id product)) ⟩∘⟨refl ⟩
            (first f ∘ eval′ ∘ first id)  ∘ first (λg id) ≈˘⟨ pullˡ β′ ⟩
            eval′ ∘ first (A⇨[-×A].F₁ f) ∘ first (λg id)  ≈⟨ refl⟩∘⟨ first∘first ⟩
            eval′ ∘ first (A⇨[-×A].F₁ f ∘ λg id)          ∎
          }
        ; counit = ntHelper record
          { η       = λ _ → eval′
          ; commute = λ f → begin
            eval′ ∘ [A⇨-]×A.F₁ f ≈⟨ β′ ⟩
            f ∘ eval′ ∘ first id ≈⟨ refl⟩∘⟨ elimʳ (id×id product) ⟩
            f ∘ eval′            ∎
          }
        ; zig    = β′
        ; zag    = λ-unique₂′ $ begin
          eval′ ∘ first (λg (eval′ ∘ eval′ ∘ second id) ∘ λg id)
                                          ≈˘⟨ refl⟩∘⟨ first∘first ⟩
          eval′ ∘ first (λg (eval′ ∘ eval′ ∘ second id)) ∘ first (λg id)
                                          ≈⟨ pullˡ β′ ⟩
          (eval′ ∘ eval′ ∘ second id) ∘ first (λg id)
                                          ≈⟨ ∘-resp-≈ʳ (elimʳ (id×id product)) ⟩∘⟨refl ⟩
          (eval′ ∘ eval′) ∘ first (λg id) ≈⟨ cancelʳ β′ ⟩
          eval′                           ≈˘⟨ elimʳ (id×id product) ⟩
          eval′ ∘ first id                ∎
        }
      ; mate    = λ {X Y} f → record
        { commute₁ = λ-unique₂′ $ begin
          eval′ ∘ first (λg (second f ∘ eval′ ∘ second id) ∘ λg id)         ≈˘⟨ refl⟩∘⟨ first∘first ⟩
          eval′ ∘ first (λg (second f ∘ eval′ ∘ second id)) ∘ first (λg id) ≈⟨ pullˡ β′ ⟩
          (second f ∘ eval′ ∘ second id) ∘ first (λg id)                    ≈⟨ ∘-resp-≈ʳ (elimʳ (id×id product)) ⟩∘⟨refl ⟩
          (second f ∘ eval′) ∘ first (λg id)                                ≈⟨ cancelʳ β′ ⟩
          second f                                                          ≈˘⟨ cancelˡ β′ ⟩
          eval′ ∘ first (λg id) ∘ second f                                  ≈⟨ pushʳ first↔second ⟩
          (eval′ ∘ second f) ∘ first (λg id)                                ≈˘⟨ identityˡ ⟩∘⟨refl ⟩
          (id ∘ eval′ ∘ second f) ∘ first (λg id)                           ≈˘⟨ pullˡ β′ ⟩
          eval′ ∘ first (λg (id ∘ eval′ ∘ second f)) ∘ first (λg id)        ≈⟨ refl⟩∘⟨ first∘first ⟩
          eval′ ∘ first (λg (id ∘ eval′ ∘ second f) ∘ λg id)                ∎
        ; commute₂ = begin
          eval′ ∘ first (λg (id ∘ eval′ ∘ second f)) ≈⟨ β′ ⟩
          id ∘ eval′ ∘ second f                      ≈⟨ identityˡ ⟩
          eval′ ∘ second f                           ∎
        }
      }

  module closedMonoidal = Closed closedMonoidal


-- Operator example

module Operators where

data True : Set where
  tt : True

data False : Set where

data Bool : Set where
  false : Bool
  true  : Bool

-- An operator is declared with '_' where the arguments go
if_then_else_ : Bool -> {A : Set} -> A -> A -> A
if true  then x else y = x
if false then x else y = y

-- The actual name of the operator is obtained by removing all the spaces from
-- the declared version.
infix 1 if_then_else_

-- This name can be used in normal applications, for instance, if a hidden argument
-- needs to be supplied.
_&&_ : Bool -> Bool -> Bool
x && y = if_then_else_ x {Bool} y false

-- Operators can be prefix...
¬_ : Bool -> Bool
¬ true  = false
¬ false = true

-- ...or postfix...
_valid : Bool -> Set
true  valid = True
false valid = False

-- ...or roundfix
⟦_⟧ : Bool -> Set
⟦ x ⟧ = x valid


{-

An simpler definition of truncation ∥ A ∥ n from n ≥ -1

Note that this uses the HoTT book's indexing, so it will be off
 from `∥_∥_` in HITs.Truncation.Base by -2

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

open import Cubical.Data.NatMinusOne renaming (suc₋₁ to suc)
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.HITs.Sn

data  ∥_∥_ {ℓ} (A : Type ℓ) (n : ℕ₋₁) : Type ℓ where
  ∣_∣ : A  → ∥ A ∥ n
  hub : (f : S (suc n) → ∥ A ∥ n) → ∥ A ∥ n
  spoke : (f : S (suc n) → ∥ A ∥ n) (x : S (suc n)) → hub f ≡ f x


-- This module is used to illustrate how to import a parameterised module.
module examples.syntax.ModuleB
	(A : Set)
	((==) : A -> A -> Prop)
	(refl : (x : A) -> x == x)
    where

  infix 5 /\

  module SubModule where
    postulate dummy : A

  data True : Prop where
    tt : True

  data False : Prop where

  data (/\) (P, Q : Prop) : Prop where
    andI : P -> Q -> P /\ Q

  data List : Set where
    nil	  : List
    cons  : A -> List -> List

  eqList : List -> List -> Prop
  eqList nil         nil	  =  True
  eqList (cons x xs) nil          =  False
  eqList nil         (cons y ys)  =  False
  eqList (cons x xs) (cons y ys)  =  x == y /\ eqList xs ys

  reflEqList : (xs : List) -> eqList xs xs
  reflEqList nil	  = tt
  reflEqList (cons x xs)  = andI (refl x) (reflEqList xs)


module Type.Quotient where

open import Logic
open import Relator.Equals
open import Type
open import Lvl

private variable ℓ₁ : Lvl.Level
private variable ℓ₂ : Lvl.Level

data _/_  (T : Type{ℓ₁}) (_≅_ : T → T → Stmt{ℓ₂}) : Type{ℓ₁ Lvl.⊔ ℓ₂} where
  [_] : T → (T / (_≅_))
  [/]-equiv-to-eq : ∀{x y : T} → (x ≅ y) → ([ x ] ≡ [ y ])
  [/]-uip : ∀{X Y : (T / (_≅_))} → (proof₁ proof₂ : (X ≡ Y)) → (proof₁ ≡ proof₂)

  -- TODO: [/]-eq-to-equiv : (x y : A) → (x ≅ y) ← ([ x ] ≡ [ y ])


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

open import LogicalFormulae
open import Numbers.Naturals.Definition
open import Maybe

module Numbers.Naturals.Subtraction where

_-N'_ : (a b : ℕ) → Maybe ℕ
zero -N' zero = yes 0
zero -N' succ b = no
succ a -N' zero = yes (succ a)
succ a -N' succ b = a -N' b

subtractZero : (a : ℕ) → a -N' 0 ≡ yes a
subtractZero zero = refl
subtractZero (succ a) = refl


module Miscellaneous.associative-side where

private variable T : Set
private variable _▫_ : T → T → T
private variable id : T

data _≡_ {ℓ}{T : Set(ℓ)} : T → T → Set(ℓ) where
  [≡]-intro : ∀{x : T} → (x ≡ x)

Associativity : (T → T → T) → Set
Associativity(_▫_) = ∀{a b c} → ((a ▫ (b ▫ c)) ≡ ((a ▫ b) ▫ c))

Identityₗ : (T → T → T) → T → Set
Identityₗ(_▫_)(id) = ∀{a} → ((id ▫ a) ≡ a)

Identityᵣ : (T → T → T) → T → Set
Identityᵣ(_▫_)(id) = ∀{a} → ((a ▫ id) ≡ a)

right-op₂-associativity : Associativity{T}(\x y → y)
right-op₂-associativity = [≡]-intro

right-op₂-identityₗ : Identityₗ{T}(\x y → y)(id)
right-op₂-identityₗ {a = a} = [≡]-intro

right-op₂-when-identityᵣₗ : (∀{a} → (id ≡ a)) → Identityᵣ{T}(\x y → y)(id)
right-op₂-when-identityᵣₗ p = p

right-op₂-when-identityᵣᵣ : Identityᵣ{T}(\x y → y)(id) → (∀{a} → (id ≡ a))
right-op₂-when-identityᵣᵣ p = p


{- SAMPLE PROGRAMS IN SOURCE LANGUAGE -}

{-# OPTIONS --no-termination-check #-}

open import Preliminaries
open import Source

module Samples where

  {- dbl (n : nat) : nat = 2 * n -}
  dbl : ∀ {Γ} → Γ |- (nat ->s nat)
  dbl = lam (rec (var i0) z (suc (suc (force (var (iS i0))))))

  {- add (m n : nat) : nat = m + n -}
  add : ∀ {Γ} → Γ |- (nat ->s (nat ->s nat))
  add = lam (lam (rec (var (iS i0)) (var i0) (suc (force (var (iS i0))))))

  {- mult (m n : nat) : nat = m * n -}
  mult : ∀ {Γ} → Γ |- (nat ->s (nat ->s nat))
  mult = lam (lam (rec (var (iS i0)) z (app (app add (var (iS (iS i0)))) (force (var (iS i0))))))

  -- hack : instead of having bool case analysis just do natural number recursion and return 1/0

  {- iszero (n : nat) : nat = z -> 1 | _ -> 0 -}
  isz : ∀ {Γ} → Γ |- (nat ->s nat)
  isz = lam (rec (var i0) (suc z) z)

  {- leq (m n : nat) : nat = m ≤ n -}
  leq : ∀ {Γ} → Γ |- (nat ->s (nat ->s nat))
  leq = lam (lam (rec (var (iS i0))
          (app isz (var (iS i0)))
          (rec (var (iS (iS (iS i0)))) (suc z) (force (var (iS i0))))))

  {- len (l : list τ) : nat = [] -> z | x :: xs -> 1 + len xs -}
  len : ∀ {Γ τ} → Γ |- (list τ ->s nat)
  len = lam (listrec (var i0) z (suc (force (var (iS (iS i0))))))

  {- insert (l : list nat) (el : nat) : list nat = [] -> [el] | x :: xs -> (leq el x -> el :: x :: xs | x :: (insert el xs)) -}
  insert : ∀ {Γ} → Γ |- (list nat ->s (nat ->s list nat))
  insert = lam (lam (listrec (var (iS i0))
             (var i0 ::s nil)
             (rec (app (app leq (var (iS (iS (iS i0))))) (var i0))
               (var i0 ::s force (var (iS (iS i0))))
               (var (iS (iS (iS (iS (iS i0))))) ::s var (iS (iS (iS (iS (iS (iS i0))))))))))

  {- insertion sort (l : list nat) : list nat = [] -> [] | x :: xs -> insert x (isort xs) -}
  isort : ∀ {Γ} → Γ |- (list nat ->s list nat)
  isort = lam (listrec (var i0) nil (app (app insert (force (var (iS (iS i0))))) (var i0)))

  {- halve (l : list nat) : (list nat * list nat) = splits a list in half -}
  halve : ∀ {Γ} → Γ |- (list nat ->s (list nat ×s list nat))
  halve = lam (listrec (var i0)
            (prod nil nil)
            (listrec (var (iS i0))
              (prod (var i0 ::s nil) nil)
              (prod (var (iS (iS (iS i0))) ::s split (force (var (iS (iS i0)))) (var i0)) (var i0 ::s split (force (var (iS (iS i0)))) (var (iS i0))))))

  {- merge (l1 l2 : list nat) : list nat =
       match l1 with
       [] -> l2
       x :: xs ->
         match l2 with
           [] -> x :: xs
           y :: ys ->
             x <= y -> x :: merge xs l2
             _ -> y :: merge l1 ys -}
  merge : ∀ {Γ} → Γ |- ((list nat ×s list nat) ->s list nat)
  merge = lam (listrec (split (var i0) (var i0))
            (split (var i0) (var (iS i0)))
            (listrec (split (var (iS (iS (iS i0)))) (var (iS i0)))
              (split (var (iS (iS (iS i0)))) (var i0))
              (rec (app (app leq (var (iS (iS (iS i0))))) (var i0))
                (var (iS (iS (iS i0))) ::s force (var (iS (iS (iS (iS (iS i0)))))))
                (var i0 ::s app merge (prod (split (var (iS (iS (iS (iS (iS (iS (iS (iS i0))))))))) (var (iS i0))) (var (iS (iS (iS i0)))))))))

  {- mergesort (l : list nat) : list nat -}
  msort : ∀ {Γ} → Γ |- (list nat ->s list nat)
  msort = lam (listrec (var i0)
            nil
            (listrec (var (iS i0))
              (var i0 ::s nil)
              (app merge (prod
                (app msort (split (app halve (var (iS (iS (iS (iS (iS (iS i0)))))))) (var i0)))
                (app msort (split (app halve (var (iS (iS (iS (iS (iS (iS i0)))))))) (var (iS i0))))))))


module +-example where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _∎)
open import Naturals using (suc; _+_)

+-example : 3 + 4 ≡ 7
+-example =
  begin
    3 + 4
  ≡⟨⟩
    suc (2 + 4)
  ≡⟨⟩
    suc (suc (1 + 4))
  ≡⟨⟩
    suc (suc (suc (0 + 4)))
  ≡⟨⟩
    suc (suc (suc 4))
  ≡⟨⟩
    7
  ∎


------------------------------------------------------------------------
-- Definitions of functions that generate list
------------------------------------------------------------------------

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

module Math.Combinatorics.ListFunction where

open import Data.List
open import Data.List.NonEmpty as NE using (List⁺)
open import Data.Nat
open import Data.Product as Prod using (_×_; _,_)
open import Function
open import Relation.Binary.PropositionalEquality hiding ([_])

module _ {a} {A : Set a} where
  -- applyEach (_+ 10) (upTo 3)
  -- >>> (10 ∷ 1 ∷ 2 ∷ []) ∷ (0 ∷ 11 ∷ 2 ∷ []) ∷ (0 ∷ 1 ∷ 12 ∷ []) ∷ []
  applyEach : (A → A) → List A → List (List A)
  applyEach f []       = []
  applyEach f (x ∷ xs) = (f x ∷ xs) ∷ map (x ∷_) (applyEach f xs)

module _ {a} {A : Set a} where
  -- Combinations
  -- combinations 2 (upTo 3)
  -- >>> (0 ∷ 1 ∷ []) ∷ (0 ∷ 2 ∷ []) ∷
  -- >>> (0 ∷ 3 ∷ []) ∷ (1 ∷ 2 ∷ []) ∷ (1 ∷ 3 ∷ []) ∷ (2 ∷ 3 ∷ []) ∷ []
  combinations : ℕ → List A → List (List A)
  combinations 0       xs       = [ [] ]
  combinations (suc k) []       = []
  combinations (suc k) (x ∷ xs) =
    map (x ∷_) (combinations k xs) ++ combinations (suc k) xs

  -- combinationsWithComplement 2 (upTo 2)
  -- >>> (0 ∷ 1 ∷ [] , 2 ∷ []) ∷
  -- >>> (0 ∷ 2 ∷ [] , 1 ∷ []) ∷ (1 ∷ 2 ∷ [] , 0 ∷ []) ∷ []
  combinationsWithComplement : ℕ → List A → List (List A × List A)
  combinationsWithComplement 0       xs       = [ [] , xs ]
  combinationsWithComplement (suc k) []       = []
  combinationsWithComplement (suc k) (x ∷ xs) =
    map (Prod.map₁ (x ∷_)) (combinationsWithComplement k xs) ++
    map (Prod.map₂ (x ∷_)) (combinationsWithComplement (suc k) xs)

  -- split list into two list (include empty list and order is preserved)
  -- splits₂ (upTo 3)
  -- >>> ([] , 0 ∷ 1 ∷ 2 ∷ []) ∷
  -- >>> (0 ∷ [] , 1 ∷ 2 ∷ []) ∷
  -- >>> (0 ∷ 1 ∷ [] , 2 ∷ []) ∷ (0 ∷ 1 ∷ 2 ∷ [] , []) ∷ []
  splits₂ : List A → List (List A × List A)
  splits₂ []       = ([] , []) ∷ []
  splits₂ (x ∷ xs) = ([] , x ∷ xs) ∷ map (Prod.map₁ (x ∷_)) (splits₂ xs)

  splits : ℕ → List A → List (List (List A))
  splits 0             xs = []
  splits 1             xs = [ xs ∷ [] ]
  splits (suc (suc k)) xs = concatMap f (splits (suc k) xs)
    where
    f : List (List A) → List (List (List A))
    f []         = []
    f (ys ∷ yss) = map (λ { (as , bs) → as ∷ bs ∷ yss }) (splits₂ ys)

  splits⁺₂Acc : A → List A → List (List⁺ A × List⁺ A)
  splits⁺₂Acc x []       = []
  splits⁺₂Acc x (y ∷ xs) = (x NE.∷ [] , y NE.∷ xs) ∷
                           map (Prod.map₁ (x NE.∷⁺_)) (splits⁺₂Acc y xs)

  -- split list into two list (exclude empty list and order is preserved)
  splits⁺₂ : List⁺ A → List (List⁺ A × List⁺ A)
  splits⁺₂ (x NE.∷ xs) = splits⁺₂Acc x xs

  splits⁺ : ℕ → List⁺ A → List (List (List⁺ A))
  splits⁺ 0             xs = []
  splits⁺ 1             xs = [ xs ∷ [] ]
  splits⁺ (suc (suc k)) xs = concatMap f (splits⁺ (suc k) xs)
    where
    f : List (List⁺ A) → List (List (List⁺ A))
    f []         = []
    f (ys ∷ yss) =
      map (λ { (as , bs) → as ∷ bs ∷ yss }) (splits⁺₂ ys)

  splits⁺AllAcc : A → List A → List⁺ (List⁺ (List⁺ A))
  splits⁺AllAcc x []       = ((x NE.∷ []) NE.∷ []) NE.∷ []
  splits⁺AllAcc x (y ∷ xs) =
    NE.map (λ zs → (x NE.∷ []) NE.∷⁺ zs) yss NE.⁺++⁺
    NE.map (λ { (z NE.∷ zs) → (x NE.∷⁺ z) NE.∷ zs} ) yss
    where yss = splits⁺AllAcc y xs

  splits⁺All : List⁺ A → List⁺ (List⁺ (List⁺ A))
  splits⁺All (x NE.∷ xs) = splits⁺AllAcc x xs

  -- Partition of set
  -- Generalization of `combinationsWithComplement`
  -- partitions 2 (upTo 3)
  -- >>> ((0 ∷ []) ∷ (1 ∷ 2 ∷ []) ∷ []) ∷
  -- >>> ((0 ∷ 1 ∷ []) ∷ (2 ∷ []) ∷ []) ∷
  -- >>> ((1 ∷ []) ∷ (0 ∷ 2 ∷ []) ∷ []) ∷ []
  partitions : ℕ → List A → List (List (List A))
  partitions 0       []       = [ [] ]
  partitions 0       (x ∷ xs) = []
  partitions (suc k) []       = []
  partitions (suc k) (x ∷ xs) =
    map ([ x ] ∷_) (partitions k xs) ++
    concatMap (applyEach (x ∷_)) (partitions (suc k) xs)

  partitionsAll : List A → List (List (List A))
  partitionsAll []       = [ [] ]
  partitionsAll (x ∷ xs) =
    map ([ x ] ∷_) yss ++ concatMap (applyEach (x ∷_)) yss
    where yss = partitionsAll xs

module _ {a} {A : Set a} where
  -- insertEverywhere 100 (upTo 2)
  -- >>> (100 ∷ 0 ∷ 1 ∷ []) ∷ (0 ∷ 100 ∷ 1 ∷ []) ∷ (0 ∷ 1 ∷ 100 ∷ []) ∷ []
  insertEverywhere : A → List A → List (List A)
  insertEverywhere x []       = [ [ x ] ]
  insertEverywhere x (y ∷ ys) = (x ∷ y ∷ ys) ∷ map (y ∷_) (insertEverywhere x ys)

module _ {a} {A : Set a} where
  -- permutations (upTo 2)
  -- >>> (0 ∷ 1 ∷ []) ∷ (1 ∷ 0 ∷ []) ∷ []
  permutations : List A → List (List A)
  permutations []       = [ [] ]
  permutations (x ∷ xs) = concatMap (insertEverywhere x) (permutations xs)


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

open import LogicalFormulae
open import Groups.DirectSum.Definition
open import Setoids.Setoids
open import Rings.Definition

module Rings.DirectSum {a b c d : _} {A : Set a} {S : Setoid {a} {b} A} {_+1_ : A → A → A} {_*1_ : A → A → A} {C : Set c} {T : Setoid {c} {d} C} {_+2_ : C → C → C} {_*2_ : C → C → C} (R1 : Ring S _+1_ _*1_) (R2 : Ring T _+2_ _*2_) where

open import Setoids.Product S T

pairPlus : A && C → A && C → A && C
pairPlus (a ,, b) (c ,, d) = (a +1 c) ,, (b +2 d)

pairTimes : A && C → A && C → A && C
pairTimes (a ,, b) (c ,, d) = (a *1 c) ,, (b *2 d)

directSumRing : Ring productSetoid pairPlus pairTimes
Ring.additiveGroup directSumRing = directSumGroup (Ring.additiveGroup R1) (Ring.additiveGroup R2)
Ring.*WellDefined directSumRing r=t s=u = productLift (Ring.*WellDefined R1 (_&&_.fst r=t) (_&&_.fst s=u)) (Ring.*WellDefined R2 (_&&_.snd r=t) (_&&_.snd s=u))
Ring.1R directSumRing = Ring.1R R1 ,, Ring.1R R2
Ring.groupIsAbelian directSumRing = productLift (Ring.groupIsAbelian R1) (Ring.groupIsAbelian R2)
Ring.*Associative directSumRing = productLift (Ring.*Associative R1) (Ring.*Associative R2)
Ring.*Commutative directSumRing = productLift (Ring.*Commutative R1) (Ring.*Commutative R2)
Ring.*DistributesOver+ directSumRing = productLift (Ring.*DistributesOver+ R1) (Ring.*DistributesOver+ R2)
Ring.identIsIdent directSumRing = productLift (Ring.identIsIdent R1) (Ring.identIsIdent R2)


-- Minimal implicational modal logic, PHOAS approach, final encoding

module Pf.BoxMp where

open import Lib using (Nat; suc)

-- Types

infixr 0 _=>_
data Ty : Set where
  UNIT :             Ty
  _=>_ : Ty -> Ty -> Ty
  BOX  : Ty       -> Ty

-- Context and truth judgement with modal depth

Cx : Set1
Cx = Ty -> Nat -> Set

isTrue : Ty -> Nat -> Cx -> Set
isTrue a d tc = tc a d

-- Terms

TmRepr : Set1
TmRepr = Nat -> Cx -> Ty -> Set

module ArrMp where
  record Tm (tr : TmRepr) : Set1 where
    infixl 1 _$_
    field
      var  : forall {d tc a}   -> isTrue a d tc                 -> tr d tc a
      lam' : forall {d tc a b} -> (isTrue a d tc -> tr d tc b)  -> tr d tc (a => b)
      _$_  : forall {d tc a b} -> tr d tc (a => b) -> tr d tc a -> tr d tc b

    lam'' : forall {d tc a b} -> (tr d tc a -> tr d tc b) -> tr d tc (a => b)
    lam'' f = lam' \x -> f (var x)

    syntax lam'' (\a -> b) = lam a => b
  open Tm {{...}} public

module BoxMp where
  record Tm (tr : TmRepr) : Set1 where
    field
      box    : forall {d tc a}      -> tr (suc d) tc a          -> tr d tc (BOX a)
      unbox' : forall {d >d tc a b} -> tr d tc (BOX a) -> (isTrue a >d tc -> tr d tc b) -> tr d tc b

      isArrMp : ArrMp.Tm tr
    open ArrMp.Tm isArrMp public

    unbox'' : forall {d >d tc a b} -> tr d tc (BOX a) -> (tr >d tc a -> tr d tc b) -> tr d tc b
    unbox'' x' f = unbox' x' \x -> f (var x)

    syntax unbox'' x' (\x -> y) = unbox x' as x => y
  open Tm {{...}} public

  Thm : Ty -> Set1
  Thm a = forall {tr d tc} {{_ : Tm tr}} -> tr d tc a
open BoxMp public

-- Example theorems

rNec : forall {a} -> Thm a -> Thm (BOX a)
rNec x =
  box x

aK : forall {a b} -> Thm (BOX (a => b) => BOX a => BOX b)
aK =
  lam f' =>
    lam x' =>
      unbox f' as f =>
        unbox x' as x =>
          box (f $ x)

aT : forall {a} -> Thm (BOX a => a)
aT =
  lam x' =>
    unbox x' as x => x

a4 : forall {a} -> Thm (BOX a => BOX (BOX a))
a4 =
  lam x' =>
    unbox x' as x => box (box x)

t1 : forall {a} -> Thm (a => BOX (a => a))
t1 =
  lam _ => box (lam y => y)


{-# OPTIONS --without-K --safe #-}
module Categories.Category.Instance.PointedSets where

-- Category of Pointed Sets

open import Level
open import Relation.Binary
open import Function using (_∘′_; _$_) renaming (id to idf)
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_; refl)
open import Data.Product

open import Categories.Category
open import Categories.Category.Instance.Sets
open import Categories.Functor using (Functor)

PointedSets : ∀ o → Category (suc o) o o
PointedSets o = record
  { Obj       = Σ (Set o) idf
  ; _⇒_       = λ c d → Σ (proj₁ c → proj₁ d) (λ f → f (proj₂ c) ≡ proj₂ d)
  ; _≈_       = λ f g → ∀ x → proj₁ f x ≡ proj₁ g x
  ; id        = idf , refl
  ; _∘_       = λ { (f , f-pres-pt) (g , g-pres-pt) → f ∘′ g , ≡.trans (≡.cong f g-pres-pt) f-pres-pt}
  ; assoc     = λ _ → refl
  ; sym-assoc = λ _ → refl
  ; identityˡ = λ _ → refl
  ; identityʳ = λ _ → refl
  ; identity² = λ _ → refl
  ; equiv     = record { refl = λ _ → refl ; sym = λ pf x → ≡.sym $ pf x ; trans = λ i≡j j≡k x → ≡.trans (i≡j x) (j≡k x) }
  ; ∘-resp-≈  = λ {_} {_} {_} {_} {h} {g} f≡h g≡i x → ≡.trans (f≡h (proj₁ g x)) (≡.cong (proj₁ h) $ g≡i x)
  }

Underlying : {o : Level} → Functor (PointedSets o) (Sets o)
Underlying = record
  { F₀           = proj₁
  ; F₁           = proj₁
  ; identity     = refl
  ; homomorphism = refl
  ; F-resp-≈     = λ f≈g {x} → f≈g x
  }


------------------------------------------------------------------------
-- Homotopy groups of pointed types
------------------------------------------------------------------------

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

import Equality.Path as P

module Pointed-type.Homotopy-group
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude

open import Equality.Groupoid equality-with-J
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J
open import Group equality-with-J as G using (Group; Abelian; _≃ᴳ_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation eq as T
open import Pointed-type equality-with-J as PT
  using (Pointed-type; _≃ᴮ_; Ω; Ω[_])

private
  variable
    a p q : Level
    P     : Pointed-type p
    n     : ℕ

-- Homotopy-group-[1+ n ] P is the (1+n)-th homotopy group of the
-- pointed type P.
--
-- This definition is taken from the HoTT book.

Homotopy-group-[1+_] : ℕ → Pointed-type a → Group a
Homotopy-group-[1+ n ] P = λ where
    .Group.Carrier        → Carrier
    .Group.Carrier-is-set → Carrier-is-set
    .Group._∘_            → _∘′_
    .Group.id             → id′
    .Group._⁻¹            → _⁻¹
    .Group.left-identity  → left-identity
    .Group.right-identity → right-identity
    .Group.assoc          → assoc
    .Group.left-inverse   → left-inverse
    .Group.right-inverse  → right-inverse
  where
  Carrier = ∥ proj₁ (Ω[ 1 + n ] P) ∥[1+ 1 ]
  _∘′_    = ∥∥-zip trans
  id′     = ∣ refl _ ∣
  _⁻¹     = ∥∥-map sym

  abstract

    Carrier-is-set : Is-set Carrier
    Carrier-is-set = truncation-has-correct-h-level 1

    left-identity : (x : Carrier) → (id′ ∘′ x) ≡ x
    left-identity = T.elim λ where
      .T.∣∣ʳ _      → cong ∣_∣ $ trans-reflˡ _
      .T.h-levelʳ _ → mono₁ 2 $ truncation-has-correct-h-level 1

    right-identity : (x : Carrier) → (x ∘′ id′) ≡ x
    right-identity = T.elim λ where
      .T.∣∣ʳ _      → cong ∣_∣ $ trans-reflʳ _
      .T.h-levelʳ _ → mono₁ 2 $ truncation-has-correct-h-level 1

    assoc : (x y z : Carrier) → (x ∘′ (y ∘′ z)) ≡ ((x ∘′ y) ∘′ z)
    assoc = T.elim λ where
      .T.h-levelʳ _ → Π-closure ext 2 λ _ →
                      Π-closure ext 2 λ _ →
                      mono₁ 2 $ truncation-has-correct-h-level 1
      .T.∣∣ʳ _      → T.elim λ where
        .T.h-levelʳ _ → Π-closure ext 2 λ _ →
                        mono₁ 2 $ truncation-has-correct-h-level 1
        .T.∣∣ʳ _      → T.elim λ where
          .T.h-levelʳ _ → mono₁ 2 $ truncation-has-correct-h-level 1
          .T.∣∣ʳ _      → cong ∣_∣ $ sym $ trans-assoc _ _ _

    left-inverse : (x : Carrier) → ((x ⁻¹) ∘′ x) ≡ id′
    left-inverse = T.elim λ where
      .T.∣∣ʳ _      → cong ∣_∣ $ trans-symˡ _
      .T.h-levelʳ _ → mono₁ 2 $ truncation-has-correct-h-level 1

    right-inverse : (x : Carrier) → (x ∘′ (x ⁻¹)) ≡ id′
    right-inverse = T.elim λ where
      .T.∣∣ʳ _      → cong ∣_∣ $ trans-symʳ _
      .T.h-levelʳ _ → mono₁ 2 $ truncation-has-correct-h-level 1

-- The fundamental group of a pointed type.
--
-- This definition is taken from the HoTT book.

Fundamental-group : Pointed-type a → Group a
Fundamental-group = Homotopy-group-[1+ 0 ]

-- The n-th homotopy group of a pointed type is abelian when n is at
-- least two.
--
-- (This result is stated in the HoTT book.)

abelian : ∀ n → Abelian (Homotopy-group-[1+ suc n ] P)
abelian n = T.elim λ where
  .T.h-levelʳ _ → Π-closure ext 2 λ _ →
                  mono₁ 2 $ truncation-has-correct-h-level 1
  .T.∣∣ʳ p      → T.elim λ where
    .T.h-levelʳ _ → mono₁ 2 $ truncation-has-correct-h-level 1
    .T.∣∣ʳ q      → cong ∣_∣ $ Ω[2+n]-commutative n p q

-- If there is a based equivalence between P and Q, then their
-- homotopy groups are isomorphic.

≃ᴮ→≃ᴳ :
  ∀ (P : Pointed-type p) (Q : Pointed-type q) n →
  P ≃ᴮ Q → Homotopy-group-[1+ n ] P ≃ᴳ Homotopy-group-[1+ n ] Q
≃ᴮ→≃ᴳ P Q n P≃Q = λ where
  .G.Homomorphic.related →
    ∥∥-cong (proj₁ (PT.Ω[ suc n ]-cong-≃ᴮ P≃Q))
  .G.Homomorphic.homomorphic → T.elim λ where
    .T.h-levelʳ _ → Π-closure ext 2 λ _ →
                    mono₁ 2 $ truncation-has-correct-h-level 1
    .T.∣∣ʳ _      → T.elim λ where
      .T.h-levelʳ _ → mono₁ 2 $ truncation-has-correct-h-level 1
      .T.∣∣ʳ _      → cong ∣_∣ (PT.Ω[1+ n ]-cong-≃ᴮ-trans P≃Q)

-- Homotopy-group-[1+ n ] commutes with PT._×_/G._×_.

Homotopy-group-[1+_]-× :
  ∀ n (P : Pointed-type p) (Q : Pointed-type q) →
  Homotopy-group-[1+ n ] (P PT.× Q) ≃ᴳ
  (Homotopy-group-[1+ n ] P G.× Homotopy-group-[1+ n ] Q)
Homotopy-group-[1+ n ]-× P Q = λ where
    .G.Homomorphic.related →
      ∥ proj₁ (Ω[ 1 + n ] (P PT.× Q)) ∥[1+ 1 ]                           ↝⟨ T.∥∥-cong (proj₁ PT.Ω[ 1 + n ]-×) ⟩
      ∥ proj₁ (Ω[ 1 + n ] P) × proj₁ (Ω[ 1 + n ] Q) ∥[1+ 1 ]             ↝⟨ inverse T.∥∥×∥∥≃∥×∥ ⟩□
      ∥ proj₁ (Ω[ 1 + n ] P) ∥[1+ 1 ] × ∥ proj₁ (Ω[ 1 + n ] Q) ∥[1+ 1 ]  □
    .G.Homomorphic.homomorphic → T.elim λ where
      .T.h-levelʳ _ → Π-closure ext 2 λ _ → s
      .T.∣∣ʳ p → T.elim λ where
        .T.h-levelʳ _ → s
        .T.∣∣ʳ q →
          Σ-map ∣_∣ ∣_∣ (_≃_.to (proj₁ PT.Ω[ 1 + n ]-×) (trans p q))  ≡⟨ cong (Σ-map ∣_∣ ∣_∣) PT.Ω[1+ n ]-×-trans ⟩∎

          (Σ-map ∣_∣ ∣_∣ $ Σ-zip trans trans
             (_≃_.to (proj₁ PT.Ω[ 1 + n ]-×) p)
             (_≃_.to (proj₁ PT.Ω[ 1 + n ]-×) q))                      ∎
  where
  s =
    mono₁ 2 $
    ×-closure 2
      (truncation-has-correct-h-level 1)
      (truncation-has-correct-h-level 1)

-- Homotopy-group-[1+ n ]′ P s is the (1+n)-th homotopy group of the
-- pointed type P.
--
-- The definition does not use set truncation. Instead a certain loop
-- space is required to be a set.

Homotopy-group-[1+_]′ :
  ∀ n (P : Pointed-type a) → Is-set (proj₁ (Ω[ 1 + n ] P)) → Group a
Homotopy-group-[1+ n ]′ P s = λ where
    .Group.Carrier        → Carrier
    .Group.Carrier-is-set → Carrier-is-set
    .Group._∘_            → _∘′_
    .Group.id             → id′
    .Group._⁻¹            → _⁻¹
    .Group.left-identity  → left-identity
    .Group.right-identity → right-identity
    .Group.assoc          → assoc
    .Group.left-inverse   → left-inverse
    .Group.right-inverse  → right-inverse
  where
  Carrier = proj₁ (Ω[ 1 + n ] P)
  _∘′_    = trans
  id′     = refl _
  _⁻¹     = sym

  abstract

    Carrier-is-set : Is-set Carrier
    Carrier-is-set = s

    left-identity : (x : Carrier) → (id′ ∘′ x) ≡ x
    left-identity _ = trans-reflˡ _

    right-identity : (x : Carrier) → (x ∘′ id′) ≡ x
    right-identity _ = trans-reflʳ _

    assoc : (x y z : Carrier) → (x ∘′ (y ∘′ z)) ≡ ((x ∘′ y) ∘′ z)
    assoc _ _ _ = sym $ trans-assoc _ _ _

    left-inverse : (x : Carrier) → ((x ⁻¹) ∘′ x) ≡ id′
    left-inverse _ = trans-symˡ _

    right-inverse : (x : Carrier) → (x ∘′ (x ⁻¹)) ≡ id′
    right-inverse _ = trans-symʳ _

-- The fundamental group of a pointed type.
--
-- The definition does not use set truncation. Instead a certain loop
-- space is required to be a set.

Fundamental-group′ :
  (P : Pointed-type a) → Is-set (proj₁ (Ω P)) → Group a
Fundamental-group′ = Homotopy-group-[1+ 0 ]′

-- Homotopy-group-[1+ n ]′ P s is isomorphic to
-- Homotopy-group-[1+ n ] P.

Homotopy-group-[1+]′≃ᴳHomotopy-group-[1+] :
  {s : Is-set (proj₁ (Ω[ 1 + n ] P))} →
  Homotopy-group-[1+ n ]′ P s ≃ᴳ Homotopy-group-[1+ n ] P
Homotopy-group-[1+]′≃ᴳHomotopy-group-[1+] {s = s} = λ where
  .G.Homomorphic.related →
    inverse $ Eq.↔⇒≃ $ _⇔_.to T.+⇔∥∥↔ (λ {_ _} → s)
  .G.Homomorphic.homomorphic p q →
    ∣ trans p q ∣  ≡⟨⟩
    ∣ trans p q ∣  ∎


------------------------------------------------------------------------
-- The Agda standard library
--
-- Every respectful binary relation induces a preorder. No claim is
-- made that this preorder is unique.
------------------------------------------------------------------------

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

open import Relation.Binary
open Setoid using (Carrier)

module Relation.Binary.Construct.FromRel
  {s₁ s₂} (S : Setoid s₁ s₂)                    -- The underlying equality
  {a r} {A : Set a} (_R_ : REL A (Carrier S) r) -- The relation
  where

open import Data.Product
open import Function
open import Level using (_⊔_)

open module Eq = Setoid S using (_≈_) renaming (Carrier to B)

------------------------------------------------------------------------
-- Definition

Resp : Rel B (a ⊔ r)
Resp x y = ∀ {a} → a R x → a R y

------------------------------------------------------------------------
-- Properties

reflexive : (∀ {a} → (a R_) Respects _≈_) → _≈_ ⇒ Resp
reflexive resp x≈y = resp x≈y

trans : Transitive Resp
trans x∼y y∼z = y∼z ∘ x∼y

isPreorder : (∀ {a} → (a R_) Respects _≈_) → IsPreorder _≈_ Resp
isPreorder resp = record
  { isEquivalence = Eq.isEquivalence
  ; reflexive     = reflexive resp
  ; trans         = trans
  }

preorder : (∀ {a} → (a R_) Respects _≈_) → Preorder _ _ _
preorder resp = record
  { isPreorder = isPreorder resp
  }


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

open import Categories.Category
open import Categories.Functor
open import Categories.Adjoint

-- Right Adjoint Preserves Limits.
module Categories.Adjoint.RAPL {o o′ ℓ ℓ′ e e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′}
  {L : Functor C D} {R : Functor D C} (L⊣R : L ⊣ R) where

open import Categories.Functor.Properties

import Categories.Morphism.Reasoning as MR
import Categories.Diagram.Limit as Lim
import Categories.Category.Construction.Cones as Con

private
  module C = Category C
  module D = Category D
  module L = Functor L
  module R = Functor R

open Adjoint L⊣R

module _ {o″ ℓ″ e″} {J : Category o″ ℓ″ e″} (F : Functor J D) where
  private
    module F = Functor F
    module LF = Lim F
    module CF = Con F

    RF = R ∘F F

    module LRF = Lim RF
    module CRF = Con RF

  rapl : LF.Limit → LRF.Limit
  rapl lim = record
    { terminal = record
      { ⊤        = ⊤
      ; !        = !
      ; !-unique = !-unique
      }
    }
    where module lim = LF.Limit lim
          open lim

          ⊤ : CRF.Cone
          ⊤ = record
            { N    = R.F₀ apex
            ; apex = record
              { ψ       = λ X → R.F₁ (proj X)
              ; commute = λ f → [ R ]-resp-∘ (limit-commute f)
              }
            }

          K′ : CRF.Cone → CF.Cone
          K′ K = record
            { N    = L.F₀ K.N
            ; apex = record
              { ψ       = λ X → counit.η (F.F₀ X) D.∘ L.F₁ (K.ψ X)
              ; commute = λ {X Y} f → begin
                F.F₁ f D.∘ counit.η (F.F₀ X) D.∘ L.F₁ (K.ψ X)
                  ≈˘⟨ pushˡ (counit.commute (F.F₁ f)) ⟩
                (counit.η (F.F₀ Y) D.∘ L.F₁ (R.F₁ (F.F₁ f))) D.∘ L.F₁ (K.ψ X)
                  ≈⟨ pullʳ ([ L ]-resp-∘ (K.commute f)) ⟩
                counit.η (F.F₀ Y) D.∘ L.F₁ (K.ψ Y)
                  ∎
              }
            }
            where module K = CRF.Cone K
                  open D.HomReasoning
                  open MR D

          module K′ K = CF.Cone (K′ K)

          ! : ∀ {K : CRF.Cone} → CRF.Cones [ K , ⊤ ]
          ! {K} = record
            { arr     = R.F₁ (rep (K′ K)) C.∘ unit.η K.N
            ; commute = commute′
            }
            where module K = CRF.Cone K
                  commute′ : ∀ {X} → R.F₁ (proj X) C.∘ R.F₁ (rep (K′ K)) C.∘ unit.η K.N C.≈ K.ψ X
                  commute′ {X} = begin
                    R.F₁ (proj X) C.∘ R.F₁ (rep (K′ K)) C.∘ unit.η K.N
                      ≈⟨ pullˡ ([ R ]-resp-∘ commute) ⟩
                    R.F₁ (K′.ψ K X) C.∘ unit.η K.N
                      ≈⟨ LRadjunct≈id ⟩
                    K.ψ X
                      ∎
                    where open C.HomReasoning
                          open MR C

          module ! {K} = CRF.Cone⇒ (! {K})

          !-unique : ∀ {K : CRF.Cone} (f : CRF.Cones [ K , ⊤ ]) → CRF.Cones [ ! ≈ f ]
          !-unique {K} f =
            let open C.HomReasoning
                open MR C
             in begin
               R.F₁ (rep (K′ K)) C.∘ unit.η K.N ≈⟨ R.F-resp-≈ (terminal.!-unique f′) ⟩∘⟨refl ⟩
               Ladjunct (Radjunct f.arr)        ≈⟨ LRadjunct≈id ⟩
               f.arr                            ∎
            where module K = CRF.Cone K
                  module f = CRF.Cone⇒ f

                  f′ : CF.Cones [ K′ K , limit ]
                  f′ = record
                    { arr     = Radjunct f.arr
                    ; commute = λ {X} → begin
                      proj X D.∘ Radjunct f.arr                                   ≈˘⟨ pushˡ (counit.commute (proj X)) ⟩
                      (counit.η (F.F₀ X) D.∘ L.F₁ (R.F₁ (proj X))) D.∘ L.F₁ f.arr ≈˘⟨ pushʳ L.homomorphism ⟩
                      Radjunct (R.F₁ (proj X) C.∘ f.arr)                          ≈⟨ Radjunct-resp-≈ f.commute ⟩
                      Radjunct (K.ψ X)                                            ∎
                    }
                    where open D.HomReasoning
                          open MR D


module BTA-ken where
-- specialize two-level typed terms to untyped lambda calculus

open import Data.Nat hiding (_<_)
open import Data.Bool
open import Data.Fin hiding (_≤_ ; pred; _+_)
open import Data.List
open import Data.Product

open import Function
open import Algebra.FunctionProperties using (Commutative; Identity; RightIdentity)
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; _≢_; refl; sym; cong; cong₂)
open PropEq.≡-Reasoning
open import Data.Nat.Properties

-- Binding times
data BT : Set where
  S : BT
  D : BT

-- defining a data type [BT],where two members are
-- [S] standing for "static" and [D] standing for dynamic.

-- ``subsumption'' binding times; static can be treated as dynamic,
-- but not vice versa
_≼_ : BT → BT → Bool
_≼_ D S  = false
_≼_ _ _  = true

record True : Set where
data False : Set where

isTrue : Bool → Set
isTrue true  = True
isTrue false = False

-- More general purpose definitions (should also be in standard library)
-- list membership
infix 4 _∈_
data _∈_ {A : Set} : A → List A → Set where
  hd : ∀ {x xs} → x ∈ (x ∷ xs)
  tl : ∀ {x y xs} → x ∈ xs → x ∈ (y ∷ xs)

-- Types of the calculus
mutual
  -- s ^ BT
  data AType : Set where
    Ann : BT → SType → AType

  -- int | t -> t
  data SType : Set where
    SInt  : SType
    SFun  : AType → AType → SType

-- aux definitions
ATInt : BT → AType
ATInt bt = Ann bt SInt
ATFun  : BT → AType → AType → AType
ATFun  bt at1 at2 = Ann bt (SFun at1 at2)

-- projection: get the BT from a type
btof : AType → BT
btof (Ann bt _) = bt

-- well-formedness
data wft : AType → Set where
  wf-int  : ∀ {bt} → wft (Ann bt SInt)
  wf-fun  : ∀ {bt at1 at2} → wft at1 → wft at2
          → isTrue (bt ≼ btof at1) → isTrue (bt ≼ btof at2) → wft (Ann bt (SFun at1 at2))

-- test for dynamic by wellformedness
data IsDynamic : AType → Set where
  is-dyn : ∀ σ → IsDynamic (Ann D σ)

lem-IsDynamic-by-wf : ∀ α → isTrue (D ≼ btof α) → IsDynamic α
lem-IsDynamic-by-wf (Ann S σ) ()
lem-IsDynamic-by-wf (Ann D σ) _ = is-dyn σ

-- typed annotated expressions
ACtx = List AType

data AExp (Δ : ACtx) : AType → Set where
  AVar : ∀ {α} → α ∈ Δ → AExp Δ α
  AInt : (bt : BT) → ℕ → AExp Δ (ATInt bt)
  ALam : ∀ {α₁ α₂} (bt : BT) → wft (ATFun bt α₂ α₁) → AExp (α₂ ∷ Δ) α₁ → AExp Δ (ATFun bt α₂ α₁)
  AApp : ∀ {α₁ α₂} (bt : BT) → wft (ATFun bt α₂ α₁) → AExp Δ (ATFun bt α₂ α₁) → AExp Δ α₂ → AExp Δ α₁

-- Untyped expression, but correctly scoped
data Exp' : ℕ → Set where
  EVar : ∀ {n} → Fin n → Exp' n
  EInt : ∀ {n} → ℕ → Exp' n
  ELam : ∀ {n} → Exp' (suc n) → Exp' n
  EApp : ∀ {n} → Exp' n → Exp' n → Exp' n

---

m+1+n≡1+m+n : ∀ m n → m + suc n ≡ suc (m + n)
m+1+n≡1+m+n zero    n = refl
m+1+n≡1+m+n (suc m) n = cong suc (m+1+n≡1+m+n m n)

n+0≡n : ∀ n → n + 0 ≡ n
n+0≡n zero    = refl
n+0≡n (suc n) = cong suc $ n+0≡n n

+-comm : ∀ m n → m + n ≡ n + m
+-comm zero    n = sym (n+0≡n n)
+-comm (suc m) n =
  begin
    suc m + n
  ≡⟨ refl ⟩
    suc (m + n)
  ≡⟨ cong suc (+-comm m n) ⟩
    suc (n + m)
  ≡⟨ sym (m+1+n≡1+m+n n m) ⟩
    n + suc m
  ∎

≤-refl : ∀ {n} → n ≤ n
≤-refl {zero} = z≤n
≤-refl {suc n} = s≤s ≤-refl

≤-trans : ∀ {a b c} → a ≤ b → b ≤ c → a ≤ c
≤-trans z≤n q = z≤n
≤-trans (s≤s p) (s≤s q) = s≤s (≤-trans p q)

≤-suc-right : ∀ {m n} → m ≤ n → m ≤ suc n
≤-suc-right z≤n = z≤n
≤-suc-right (s≤s p) = s≤s (≤-suc-right p)

≤-suc-left : ∀ {m n} → suc m ≤ n → m ≤ n
≤-suc-left (s≤s p) = ≤-suc-right p

xlate : ∀ {m} {n} → Exp' (m + suc n) → Exp' (suc (n + m))
xlate {m} {n} e rewrite m+1+n≡1+m+n m n | +-comm m n = e

shifter1 : ∀ {n} m → Exp' (suc n) → Exp' (suc (n + m))
shifter1 {n} m (EVar x) = xlate {m} (EVar (raise m x))
shifter1 m (EInt x) = EInt x
shifter1 m (ELam e) = ELam (shifter1 m e)
shifter1 m (EApp e e₁) = EApp (shifter1 m e) (shifter1 m e₁)

shifter0 : ∀ m → Exp' zero → Exp' m
shifter0 m (EVar ())
shifter0 m (EInt x) = EInt x
shifter0 m (ELam e) = ELam (shifter1 m e)
shifter0 m (EApp e e₁) = EApp (shifter0 m e) (shifter0 m e₁)

shifter : ∀ m d → Exp' m → Exp' (m + d)
shifter zero d e = shifter0 d e
shifter (suc m) d e = shifter1 d e

-- m+n∸m≡n : ∀ {m n} → m ≤ n → m + (n ∸ m) ≡ n
-- m+n∸m≡n p

helper : ∀ {m n} → n ≤ m → Exp' (n + (m ∸ n)) → Exp' m
helper p e rewrite m+n∸m≡n p = e

-- index m = nesting level of dynamic definitions
Imp : (m : ℕ) → AType → Set
Imp m (Ann S SInt) = ℕ
Imp m (Ann S (SFun α₁ α₂)) = ∀ n → m ≤ n → (Imp n α₁ → Imp n α₂)
Imp m (Ann D σ) = Exp' m

-- index = nesting level of dynamic definitions
data AEnv1 : ℕ → ACtx → Set where
  [] : AEnv1 0 []
  consS : ∀ {m Δ o} → m ≤ o → (α : AType) → Imp o α → AEnv1 m Δ → AEnv1 o (α ∷ Δ)
  consD : ∀ {m Δ} → (α : AType) → isTrue (D ≼ btof α) → Imp (suc m) α → AEnv1 m Δ → AEnv1 (suc m) (α ∷ Δ)

lift1 : ∀ {m n} α → m ≤ n → Imp m α → Imp n α
lift1 (Ann S SInt) p v = v
lift1 (Ann S (SFun x x₁)) p v = λ k n≤k → v k (≤-trans p n≤k)
lift1 {m} {n} (Ann D σ) p v = helper p (shifter m (n ∸ m) v)

lookup1 : ∀ {α Δ m n} → m  ≤ n → AEnv1 m Δ → α ∈ Δ → Imp n α
lookup1 {α} p (consS _ .α x env) hd = lift1 α p x
lookup1 {α} p (consD .α x x₁ env) hd = lift1 α p x₁
lookup1 p (consS p' .y x env) (tl {_} {y} x₁) = lookup1 (≤-trans p' p) env x₁
lookup1 p (consD .y x x₁ env) (tl {_} {y} x₂) = lookup1 (≤-suc-left p) env x₂

pe1 : ∀ {α Δ} m → AExp Δ α → AEnv1 m Δ → Imp m α
pe1 m (AVar x) env = lookup1 ≤-refl env x
pe1 m (AInt S x) env = x
pe1 m (AInt D x) env = EInt x
pe1 m (ALam S x e) env = λ o p → λ v → pe1 o e (consS p _ v env)
pe1 m (ALam {α₂} {α₁} D (wf-fun w₁ w₂ d≤bt₁ d≤bt₂) e) env
  with lem-IsDynamic-by-wf α₁ d≤bt₁ | lem-IsDynamic-by-wf α₂ d≤bt₂
pe1 m (ALam {.(Ann D σ₂)} {.(Ann D σ₁)} D (wf-fun _ _ d≤bt₁ d≤bt₂) e) env
  | is-dyn σ₁ | is-dyn σ₂ = ELam (pe1 (suc m) e (consD (Ann D σ₁) d≤bt₁ (EVar zero) env))
pe1 m (AApp S x e e₁) env = (pe1 m e env) m ≤-refl (pe1 m e₁ env)
pe1 m (AApp {α₂} {α₁} D (wf-fun w₁ w₂ d≤bt₁ d≤bt₂) e e₁) env
  with lem-IsDynamic-by-wf α₁ d≤bt₁ | lem-IsDynamic-by-wf α₂ d≤bt₂
pe1 m (AApp {.(Ann D σ₂)} {.(Ann D σ₁)} D (wf-fun w₁ w₂ d≤bt₁ d≤bt₂) e e₁) env
  | is-dyn σ₁ | is-dyn σ₂ = EApp (pe1 m e env) (pe1 m e₁ env)


{-
This second-order signature was created from the following second-order syntax description:

syntax STLC | Λ

type
  N   : 0-ary
  _↣_ : 2-ary | r30

term
  app : α ↣ β  α  ->  β | _$_ l20
  lam : α.β  ->  α ↣ β | ƛ_ r10

theory
  (ƛβ) b : α.β  a : α |> app (lam(x.b[x]), a) = b[a]
  (ƛη) f : α ↣ β      |> lam (x. app(f, x))   = f
-}

module STLC.Signature where

open import SOAS.Context

-- Type declaration
data ΛT : Set where
  N   : ΛT
  _↣_ : ΛT → ΛT → ΛT
infixr 30 _↣_

open import SOAS.Syntax.Signature ΛT public
open import SOAS.Syntax.Build ΛT public

-- Operator symbols
data Λₒ : Set where
  appₒ lamₒ : {α β : ΛT} → Λₒ

-- Term signature
Λ:Sig : Signature Λₒ
Λ:Sig = sig λ
  { (appₒ {α}{β}) → (⊢₀ α ↣ β) , (⊢₀ α) ⟼₂ β
  ; (lamₒ {α}{β}) → (α ⊢₁ β) ⟼₁ α ↣ β
  }

open Signature Λ:Sig public


{-# OPTIONS --without-K #-}
module sets.finite.infinite where

open import sum
open import equality.core
open import function.isomorphism.core
open import function.isomorphism.utils
open import sets.nat
open import sets.empty
open import sets.unit
open import sets.fin.core
open import sets.fin.properties
open import sets.fin.universe
open import sets.finite.core

ℕ-not-finite : ¬ (IsFinite ℕ)
ℕ-not-finite (n , fℕ) = suc-fixpoint (sym (Fin-inj iso-suc))
  where
    iso-suc : Fin n ≅ Fin (suc n)
    iso-suc = sym≅ fℕ
           ·≅ isoℕ
           ·≅ ⊎-ap-iso refl≅ fℕ
           ·≅ sym≅ fin-struct-iso


module InferrableFields where

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

data Vec A : ℕ → Set where
  []  : Vec A zero
  _∷_ : ∀ {n} → A → Vec A n → Vec A (suc n)

record SomeVec A : Set where
  field n      : ℕ
        unpack : Vec A n

open SomeVec using (unpack)

pack : ∀ {A n} → Vec A n -> SomeVec A
pack xs = record { unpack = xs }

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

lemPack : ∀ {A}(xs : SomeVec A) → pack (unpack xs) ≡ xs
lemPack xs = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Data.Vec.Any.Membership instantiated with propositional equality,
-- along with some additional definitions.
------------------------------------------------------------------------

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

module Data.Vec.Membership.Propositional {a} {A : Set a} where

open import Data.Vec using (Vec)
open import Data.Vec.Relation.Unary.Any using (Any)
open import Relation.Binary.PropositionalEquality using (setoid; subst)

import Data.Vec.Membership.Setoid as SetoidMembership

------------------------------------------------------------------------
-- Re-export contents of setoid membership

open SetoidMembership (setoid A) public hiding (lose)

------------------------------------------------------------------------
-- Other operations

lose : ∀ {p} {P : A → Set p} {x n} {xs : Vec A n} → x ∈ xs → P x → Any P xs
lose = SetoidMembership.lose (setoid A) (subst _)


module Type.Size.Finite where

import      Lvl
open import Functional
open import Logic
open import Logic.Predicate
open import Numeral.Finite
open import Numeral.Finite.Equiv
open import Numeral.Natural
open import Structure.Setoid
open import Type
open import Type.Size

private variable ℓ ℓₑ : Lvl.Level

-- A finitely enumerable type is a type where its inhabitants are finitely enumerable (alternatively: listable, able to collect to a finite list (a list containing all inhabitants is constructible)).
-- There is a finite upper bound on the number of inhabitants in the sense that the inverse of a mapping from a type of finite numbers is a function (TODO: Not sure if the implementation actually states this. Maybe Invertible should be used instead of Surjective?).
-- Also called: Finitely indexed.
FinitelyEnumerable : (T : Type{ℓ}) → ⦃ equiv : Equiv{ℓₑ}(T) ⦄ → Stmt
FinitelyEnumerable(T) = ∃(n ↦ 𝕟(n) ≽ T)

-- A finite type have a finite number of inhabitants, and this number is constructable.
Finite : (T : Type{ℓ}) → ⦃ equiv : Equiv{ℓₑ}(T) ⦄ → Stmt
Finite(T) = ∃(n ↦ 𝕟(n) ≍ T)

-- Cardinality of a finite type in the form of a number. Number of inhabitants of a type.
-- The witness of Finite is the exact number of inhabitants of the type (the count).
#_ : (T : Type{ℓ}) → ⦃ equiv : Equiv{ℓₑ}(T) ⦄ → ⦃ fin : Finite(T) ⦄ → ℕ
#_ _ ⦃ fin = [∃]-intro(n) ⦄ = n

enum : ∀{T : Type{ℓ}} → ⦃ equiv : Equiv{ℓₑ}(T) ⦄ → ⦃ fin : Finite(T) ⦄ → 𝕟(# T) → T
enum ⦃ fin = [∃]-intro _ ⦃ [∃]-intro f ⦄ ⦄ = f

module Finite where
  import      Data.Either as Type
  import      Data.Either.Equiv as Either
  import      Data.Tuple as Type
  import      Data.Tuple.Equiv as Tuple
  open import Numeral.Finite.Sequence
  open import Structure.Function.Domain
  import      Numeral.Natural.Oper as ℕ

  private variable A B : Type{ℓ}
  private variable ⦃ equiv-A ⦄ : Equiv{ℓₑ}(A)
  private variable ⦃ equiv-B ⦄ : Equiv{ℓₑ}(B)
  private variable ⦃ equiv-A‖B ⦄ : Equiv{ℓₑ}(A Type.‖ B)
  private variable ⦃ equiv-A⨯B ⦄ : Equiv{ℓₑ}(A Type.⨯ B)

  _+_ :  ⦃ ext : Either.Extensionality ⦃ equiv-A ⦄ ⦃ equiv-B ⦄ (equiv-A‖B) ⦄ → Finite(A) ⦃ equiv-A ⦄ → Finite(B) ⦃ equiv-B ⦄ → Finite(A Type.‖ B) ⦃ equiv-A‖B ⦄
  _+_ ([∃]-intro a ⦃ [∃]-intro af ⦄) ([∃]-intro b ⦃ [∃]-intro bf ⦄) = [∃]-intro (a ℕ.+ b) ⦃ [∃]-intro (interleave af bf) ⦃ interleave-bijective ⦄ ⦄

  -- TODO: Below
  _⋅_ :  ⦃ ext : Tuple.Extensionality ⦃ equiv-A ⦄ ⦃ equiv-B ⦄ (equiv-A⨯B) ⦄ → Finite(A) ⦃ equiv-A ⦄ → Finite(B) ⦃ equiv-B ⦄ → Finite(A Type.⨯ B) ⦃ equiv-A⨯B ⦄
  _⋅_ ([∃]-intro a ⦃ [∃]-intro af ⦄) ([∃]-intro b ⦃ [∃]-intro bf ⦄) = [∃]-intro (a ℕ.⋅ b) ⦃ [∃]-intro (f af bf) ⦃ p ⦄ ⦄ where
    postulate f : (𝕟(a) → _) → (𝕟(b) → _) → 𝕟(a ℕ.⋅ b) → (_ Type.⨯ _)
    postulate p : Bijective(f af bf)

  {-
  _^_ :  Finite(A) → Finite(B) → Finite(A ← B)
  _^_ ([∃]-intro a ⦃ [∃]-intro af ⦄) ([∃]-intro b ⦃ [∃]-intro bf ⦄) = [∃]-intro (a ℕ.^ b) ⦃ [∃]-intro (f af bf) ⦃ p ⦄ ⦄ where
    postulate f : (𝕟(a) → _) → (𝕟(b) → _) → 𝕟(a ℕ.^ b) → (_ ← _)
    postulate p : Bijective(f af bf)
  -}


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

module sets.bool where

open import sets.empty     using (⊥)
open import sets.unit      using (⊤)
open import decidable using (Dec; yes; no)
open import equality.core        using (_≡_; refl)
open import level     using (Level)

infixr 6 _∧_
infixr 5 _∨_ _xor_
infix  0 if_then_else_

data Bool : Set where
  true false : Bool

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

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

if_then_else_ : {a : Level} {A : Set a} → Bool → A → A → A
if true  then t else f = t
if false then t else f = f

_∧_ : Bool → Bool → Bool
true  ∧ b = b
false ∧ b = false

_∨_ : Bool → Bool → Bool
true  ∨ b = true
false ∨ b = b

_xor_ : Bool → Bool → Bool
true  xor b = not b
false xor b = b

_≟_ : (a b : Bool) → Dec (a ≡ b)
true  ≟ true  = yes refl
false ≟ false = yes refl
true  ≟ false = no λ ()
false ≟ true  = no λ ()


-- Agda program using the Iowa Agda library
{-# OPTIONS --termination-depth=2 #-}

module PROOF-gamelength
  where

open import eq
open import bool
open import nat
open import nat-thms
open import list
open import nondet
open import nondet-thms

---------------------------------------------------------------------------
-- Translated Curry operations:

data Move : Set where
   L : Move
   R : Move

solve2 : ℕ → ℕ → ND (𝕃 Move)
solve2 zero    zero    = Val []
solve2 (suc x) zero    = mapND (_::_ L) (solve2 x zero)
solve2 zero    (suc y) = mapND (_::_ R) (solve2 zero y)
solve2 (suc z) (suc u) = (mapND (_::_ L) (solve2 z (suc u)))
                      ?? (mapND (_::_ R) (solve2 (suc z) u))

len : {a : Set} → 𝕃 a → ℕ
len [] = zero
len (x :: y) = suc (len y)

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

-- Theorem: the length of every solution is the sum of the input arguments
gamelength : (x : ℕ) → (y : ℕ)
              → (solve2 x y) satisfy (λ xs → length xs =ℕ x + y) ≡ tt
gamelength zero zero = refl
gamelength zero (suc y)
 rewrite
    satisfy-mapND (_::_ R) (solve2 zero y) (λ xs → length xs =ℕ zero + suc y)
  | gamelength zero y = refl
gamelength (suc x) zero
 rewrite
   satisfy-mapND (_::_ L) (solve2 x zero) (λ xs → length xs =ℕ suc x + zero)
 | gamelength x zero = refl
gamelength (suc x) (suc y)
 rewrite
  satisfy-mapND (_::_ L) (solve2 x (suc y)) (λ xs → length xs =ℕ suc x + suc y)
 | satisfy-mapND (_::_ R) (solve2 (suc x) y) (λ xs → length xs =ℕ suc x + suc y)
 | gamelength x (suc y)
 | +suc x y
 | gamelength (suc x) y
 = refl

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


module Data.ListNonEmpty where

open import Data.Boolean
import      Data.IndexedList
open import Functional
import      Lvl
open import Numeral.Natural
open import Type

private variable ℓ : Lvl.Level
private variable T : Type{ℓ}

module _ (T : Type{ℓ}) where
  open Data.IndexedList(T){Bool} using (IndexedList ; intro)

  -- A non-empty list.
  List₊ : Type{ℓ}
  List₊ = IndexedList(intro 𝐹 (const(const 𝑇)))(𝑇)

module _ {T : Type{ℓ}} where
  open Data.IndexedList(T){Bool} using (∅ ; _⊰_ ; singleton) public

pattern ‥ = _ ⊰ _

open import Data.List
import      Data.List.Functions as List

-- A list from a non-empty list.
list : List₊(T) → List(T)
list (singleton(x)) = List.singleton(x)
list (x ⊰ l@‥)      = x List.⊰ list(l)

-- A list without its first element.
tail₀ : List₊(T) → List(T)
tail₀ (singleton(_)) = List.∅
tail₀ (_ ⊰ l@‥)      = list(l)

-- List concatenation.
_++_ : List₊(T) → List₊(T) → List₊(T)
singleton(x) ++ y = x ⊰ y
(x ⊰ xl@‥)   ++ y = x ⊰ (xl ++ y)

-- The first element of the list.
head : List₊(T) → T
head(singleton x)   = x
head(x ⊰ l@‥) = x

-- Applies a binary operator to each element in the list starting with the initial element.
-- Example:
--   reduceᵣ(_▫_) [a]         = a
--   reduceᵣ(_▫_) [a,b]       = a ▫ b
--   reduceᵣ(_▫_) [a,b,c]     = a ▫ (b ▫ c)
--   reduceᵣ(_▫_) [a,b,c,d,e] = a ▫ (b ▫ (c ▫ (d ▫ e)))
reduceᵣ : (T → T → T) → List₊(T) → T
reduceᵣ(_)   (singleton(x)) = x
reduceᵣ(_▫_) (x ⊰ l@‥)      = x ▫ (reduceᵣ(_▫_) l)


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

open import Categories.Category

module Categories.Morphism.IsoEquiv {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level
open import Function using (flip; _on_)
open import Relation.Binary hiding (_⇒_)
import Relation.Binary.Construct.On as On

open import Categories.Morphism 𝒞

open Category 𝒞

private
  variable
    A B C : Obj

-- Two lemmas to set things up: if they exist, inverses are unique.

to-unique : ∀ {f₁ f₂ : A ⇒ B} {g₁ g₂} →
            Iso f₁ g₁ → Iso f₂ g₂ → f₁ ≈ f₂ → g₁ ≈ g₂
to-unique {_} {_} {f₁} {f₂} {g₁} {g₂} iso₁ iso₂ hyp = begin
                 g₁   ≈˘⟨ identityˡ ⟩
     id        ∘ g₁   ≈˘⟨ ∘-resp-≈ˡ Iso₂.isoˡ ⟩
    (g₂ ∘  f₂) ∘ g₁   ≈˘⟨ ∘-resp-≈ˡ (∘-resp-≈ʳ hyp) ⟩
    (g₂ ∘  f₁) ∘ g₁   ≈⟨ assoc ⟩
     g₂ ∘ (f₁  ∘ g₁)  ≈⟨ ∘-resp-≈ʳ Iso₁.isoʳ ⟩
     g₂ ∘  id         ≈⟨ identityʳ ⟩
     g₂               ∎
  where
    open HomReasoning
    module Iso₁ = Iso iso₁
    module Iso₂ = Iso iso₂

from-unique : ∀ {f₁ f₂ : A ⇒ B} {g₁ g₂} →
              Iso f₁ g₁ → Iso f₂ g₂ → g₁ ≈ g₂ → f₁ ≈ f₂
from-unique iso₁ iso₂ hyp = to-unique iso₁⁻¹ iso₂⁻¹ hyp
  where
    iso₁⁻¹ = record { isoˡ = Iso.isoʳ iso₁  ; isoʳ = Iso.isoˡ iso₁ }
    iso₂⁻¹ = record { isoˡ = Iso.isoʳ iso₂  ; isoʳ = Iso.isoˡ iso₂ }

-- Equality of isomorphisms is just equality of the underlying morphism(s).
--
-- Only one equation needs to be given; the equation in the other
-- direction holds automatically (by the above lemmas).
--
-- The reason for wrapping the underlying equality in a record at all
-- is that this helps unification.  Concretely, it allows Agda to
-- infer the isos |i| and |j| being related in function applications
-- where only the equation |i ≃ j| is passed as an explicit argument.

infix 4 _≃_
record _≃_ (i j : A ≅ B) : Set e where
  constructor ⌞_⌟
  open _≅_
  field from-≈ : from i ≈ from j

  to-≈ : to i ≈ to j
  to-≈ = to-unique (iso i) (iso j) from-≈

open _≃_

≃-isEquivalence : IsEquivalence (_≃_ {A} {B})
≃-isEquivalence = record
  { refl  = ⌞ refl ⌟
  ; sym   = λ where ⌞ eq ⌟          → ⌞ sym eq ⌟
  ; trans = λ where ⌞ eq₁ ⌟ ⌞ eq₂ ⌟ → ⌞ trans eq₁ eq₂ ⌟
  }
  where open Equiv

≃-setoid : ∀ {A B : Obj} → Setoid _ _
≃-setoid {A} {B} = record
  { Carrier       = A ≅ B
  ; _≈_           = _≃_
  ; isEquivalence = ≃-isEquivalence
  }

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

-- An alternative, more direct notion of equality on isomorphisms that
-- involves no wrapping/unwrapping.

infix 4 _≃′_
_≃′_ : Rel (A ≅ B) e
_≃′_ = _≈_ on _≅_.from

≃′-isEquivalence : IsEquivalence (_≃′_ {A} {B})
≃′-isEquivalence = On.isEquivalence _≅_.from equiv

≃′-setoid : ∀ {A B : Obj} → Setoid _ _
≃′-setoid {A} {B} = record
  { Carrier       = A ≅ B
  ; _≈_           = _≃′_
  ; isEquivalence = ≃′-isEquivalence
  }

-- The two notions of equality are equivalent

≃⇒≃′ : ∀ {i j : A ≅ B} → i ≃ j → i ≃′ j
≃⇒≃′ eq = from-≈ eq

≃′⇒≃ : ∀ {i j : A ≅ B} → i ≃′ j → i ≃ j
≃′⇒≃ {_} {_} {i} {j} eq = ⌞ eq ⌟


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

open import Categories.Category
open import Categories.Object.Terminal

-- Various constructors of Product Objects

module Categories.Object.Product.Construction {o ℓ e} (C : Category o ℓ e) (T : Terminal C) where

open import Categories.Object.Exponential C hiding (repack)
open import Categories.Object.Product C
open Category C
open Terminal T
open HomReasoning

-- we can get some products
[⊤×⊤]-product : Product ⊤ ⊤
[⊤×⊤]-product = record
  { A×B       = ⊤
  ; π₁        = !
  ; π₂        = !
  ; ⟨_,_⟩     = λ _ _ → !
  ; project₁  = !-unique₂
  ; project₂  = !-unique₂
  ; unique = λ _ _ → !-unique _
  }

[⊤×_]-product : (X : Obj) → Product ⊤ X
[⊤×_]-product X = record
  { A×B = X
  ; π₁ = !
  ; π₂ = id
  ; ⟨_,_⟩ = λ _ y → y
  ; project₁ = !-unique₂
  ; project₂ = identityˡ
  ; unique = λ _ id∘h≈j → ⟺ id∘h≈j ○ identityˡ
  }

[_×⊤]-product : (X : Obj) → Product X ⊤
[_×⊤]-product X = Reversible [⊤× X ]-product

-- and some exponentials too
[_↑⊤]-exponential : (B : Obj) → Exponential ⊤ B
[ B ↑⊤]-exponential = record
  { B^A = B
  ; product = [ B ×⊤]-product
  ; eval = id
  ; λg = λ {X} X×⊤ X⇒B → X⇒B ∘ repack [ X ×⊤]-product X×⊤
  ; β = λ p {g} → begin
    id ∘ (g ∘ [ p ]⟨ id , ! ⟩) ∘ [ p ]π₁    ≈⟨ identityˡ ○ assoc ⟩
    g ∘ [ p ]⟨ id , ! ⟩ ∘ [ p ]π₁           ≈⟨ refl⟩∘⟨ [ p ]⟨⟩∘ ⟩
    g ∘ [ p ]⟨ id ∘ [ p ]π₁ , ! ∘ [ p ]π₁ ⟩ ≈⟨ refl⟩∘⟨ ⟨⟩-cong₂ p identityˡ !-unique₂ ⟩
    g ∘ [ p ]⟨ [ p ]π₁ , [ p ]π₂ ⟩          ≈⟨ refl⟩∘⟨ η p ○ identityʳ ⟩
    g                                      ∎
  ; λ-unique = λ {X} p {g} {h} h-comm → begin
    h                                   ≈˘⟨ identityʳ ⟩
    h ∘ id                              ≈˘⟨  refl⟩∘⟨ project₁ p ⟩
    h ∘ [ p ]π₁ ∘ [ p ]⟨ id , ! ⟩        ≈˘⟨ assoc ⟩
    (h ∘ [ p ]π₁) ∘ [ p ]⟨ id , ! ⟩      ≈˘⟨ identityˡ ⟩∘⟨refl ⟩
    (id ∘ h ∘ [ p ]π₁) ∘ [ p ]⟨ id , ! ⟩ ≈⟨ h-comm ⟩∘⟨refl ⟩
    g ∘ repack [ X ×⊤]-product p ∎
  }
  where open Product

[⊤↑_]-exponential : (A : Obj) → Exponential A ⊤
[⊤↑ A ]-exponential = record
  { B^A       = ⊤
  ; product   = [⊤× A ]-product
  ; eval      = !
  ; λg        = λ _ _ → !
  ; β         = λ _   → !-unique₂
  ; λ-unique  = λ _ _ → !-unique₂
  }


------------------------------------------------------------------------------
-- FOTC version of the domain predicate of quicksort given by the
-- Bove-Capretta method
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.QuickSort.DomainPredicate where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Nat.Inequalities hiding ( le ; gt )
open import FOTC.Data.Nat.List.Type
open import FOTC.Data.Nat.Type
open import FOTC.Data.List

------------------------------------------------------------------------------
-- We need to define monadic inequalities.
postulate
  le gt : D
  le-00 : le · zero · zero               ≡ false
  le-0S : ∀ d → le · zero · succ₁ d      ≡ true
  le-S0 : ∀ d → le · succ₁ d · zero      ≡ false
  le-SS : ∀ d e → le · succ₁ d · succ₁ e ≡ lt d e

postulate
  filter    : D → D → D
  filter-[] : ∀ f → filter f [] ≡ []
  filter-∷  : ∀ f d ds →
              filter f (d ∷ ds) ≡
              (if f · d then d ∷ filter f (d ∷ ds) else filter f (d ∷ ds))

postulate filter-List : ∀ f {xs} → List xs → List (filter f xs)

postulate
  qs    : D → D
  qs-[] : qs [] ≡ []
  qs-∷  : ∀ x xs → qs (x ∷ xs) ≡ qs (filter (gt · x) xs) ++
                                 x ∷ qs (filter (le · x) xs)

-- Domain predicate for quicksort.
data Dqs : {xs : D} → List xs → Set where
  dnil  : Dqs lnil
  dcons : ∀ {x xs} → (Lxs : List xs) →
                     Dqs (filter-List (gt · x) Lxs) →
                     Dqs (filter-List (le · x) Lxs) →
                     Dqs (lcons x Lxs)

-- Induction principle associated to the domain predicate of quicksort.
Dqs-ind : (P : {xs : D} → List xs → Set) →
          P lnil →
          (∀ {x xs} → (Lxs : List xs) →
                      Dqs (filter-List (gt · x) Lxs) →
                      P (filter-List (gt · x) Lxs) →
                      Dqs (filter-List (le · x) Lxs) →
                      P (filter-List (le · x) Lxs) →
                      P (lcons x Lxs)) →
          (∀ {xs} → {Lxs : List xs} → Dqs Lxs → P Lxs)
Dqs-ind P P[] ih dnil              = P[]
Dqs-ind P P[] ih (dcons Lxs h₁ h₂) =
  ih Lxs h₁ (Dqs-ind P P[] ih h₁) h₂ (Dqs-ind P P[] ih h₂)


{-
  Define finitely generated ideals of commutative rings and
  show that they are an ideal.
  Parts of this should be reusable for explicit constructions
  of free modules over a finite set.
-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRing.FGIdeal where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Powerset
open import Cubical.Foundations.HLevels

open import Cubical.Data.Sigma
open import Cubical.Data.FinData hiding (elim)
open import Cubical.Data.Nat using (ℕ)

open import Cubical.HITs.PropositionalTruncation

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.Ideal
open import Cubical.Algebra.Ring.QuotientRing
open import Cubical.Algebra.Ring.Properties
open import Cubical.Algebra.Ring.BigOps
open import Cubical.Algebra.RingSolver.ReflectionSolving

private
  variable
    ℓ : Level

module _ (Ring@(R , str) : CommRing ℓ) where
  infixr 5 _holds
  _holds : hProp ℓ → Type ℓ
  P holds = fst P
  open CommRingStr str
  open RingTheory (CommRing→Ring Ring)
  open Sum (CommRing→Ring Ring)

  linearCombination : {n : ℕ} → FinVec R n → FinVec R n → R
  linearCombination α V = ∑ (λ i → α i · V i)

  sumDist+ : ∀ {n : ℕ} (α β V : FinVec R n)
           → linearCombination (λ i → α i + β i) V ≡ linearCombination α V + linearCombination β V
  sumDist+ α β V = ∑Ext (λ i → ·Ldist+ (α i) (β i) (V i)) ∙ ∑Split (λ i → α i · V i) (λ i → β i · V i)

  dist- : ∀ {n : ℕ} (α V : FinVec R n)
        → linearCombination (λ i → - α i) V ≡ - linearCombination α V
  dist- α V = ∑Ext (λ i → -DistL· (α i) (V i)) ∙ ∑Dist- (λ i → α i · V i)

  dist0 : ∀ {n : ℕ} (V : FinVec R n)
        → linearCombination (replicateFinVec n 0r) V ≡ 0r
  dist0 {n = n} V = ∑Ext (λ i → 0LeftAnnihilates (V i)) ∙ ∑0r n

  isLinearCombination : {n : ℕ} → FinVec R n → R → Type ℓ
  isLinearCombination V x = ∃[ α ∈ FinVec R _ ] x ≡ linearCombination α V

  {- If x and y are linear combinations of l, then (x + y) is
     a linear combination. -}
  isLinearCombination+ : {n : ℕ} {x y : R} (V : FinVec R n)
                         → isLinearCombination V x
                         → isLinearCombination V y
                         → isLinearCombination V (x + y)
  isLinearCombination+ V = map2 λ α β → (λ i → α .fst i + β .fst i)
                                       , cong₂ (_+_) (α .snd) (β .snd) ∙ sym (sumDist+ _ _ V)

  {- If x is a linear combinations of l, then -x is
     a linear combination. -}
  isLinearCombination- : {n : ℕ} {x : R} (V : FinVec R n)
                       → isLinearCombination V x → isLinearCombination V (- x)
  isLinearCombination- V = map λ α → (λ i → - α .fst i) , cong (-_) (α .snd) ∙ sym (dist- _ V)

  {- 0r is the trivial linear Combination -}
  isLinearCombination0 : {n : ℕ} (V : FinVec R n)
                       → isLinearCombination V 0r
  isLinearCombination0 V = ∣ _ , sym (dist0 V) ∣

  {- Linear combinations are stable under left multiplication -}
  isLinearCombinationL· : {n : ℕ} (V : FinVec R n) (r : R) {x : R}
                        → isLinearCombination V x → isLinearCombination V (r · x)
  isLinearCombinationL· V r = map λ α → (λ i → r · α .fst i) , cong (r ·_) (α .snd)
                                                            ∙∙ ∑Mulrdist r (λ i → α .fst i · V i)
                                                            ∙∙ ∑Ext λ i → ·Assoc r (α .fst i) (V i)

  generatedIdeal : {n : ℕ} → FinVec R n → IdealsIn Ring
  generatedIdeal V = makeIdeal Ring
                               (λ x → isLinearCombination V x , isPropPropTrunc)
                               (isLinearCombination+ V)
                               (isLinearCombination0 V)
                               λ r → isLinearCombinationL· V r

open isCommIdeal
genIdeal : {n : ℕ} (R : CommRing ℓ) → FinVec (fst R) n → CommIdeal R
fst (genIdeal R V) x = isLinearCombination R V x , isPropPropTrunc
+Closed (snd (genIdeal R V)) = isLinearCombination+ R V
contains0 (snd (genIdeal R V)) = isLinearCombination0 R V
·Closed (snd (genIdeal R V)) r = isLinearCombinationL· R V r

syntax genIdeal R V = ⟨ V ⟩[ R ]

FGIdealIn : (R : CommRing ℓ) → Type (ℓ-suc ℓ)
FGIdealIn R = Σ[ I ∈ CommIdeal R ] ∃[ n ∈ ℕ ] ∃[ V ∈ FinVec (fst R) n ] I ≡ ⟨ V ⟩[ R ]


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

module Dodo.Binary.Functional where

-- Stdlib imports
open import Level using (Level; _⊔_)
open import Relation.Binary using (Rel; REL)
-- Local imports
open import Dodo.Binary.Equality

-- # Definitions #

Functional : ∀ {a b ℓ₁ ℓ₂ : Level} {A : Set a} {B : Set b}
  → Rel B ℓ₁
  → REL A B ℓ₂
    ---------------------
  → Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂)
Functional _≈_ r = ∀ x y₁ y₂ → r x y₁ → r x y₂ → y₁ ≈ y₂
-- The /explicit/ x, y₁, and y₂ are crucial. If they're implicit, Agda will attempt to
-- instantiate them when absent, which often fails to resolve. Not sure why.

-- # Operations #

module _ {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {≈ : Rel A ℓ₁} {P : Rel A ℓ₂} {Q : Rel A ℓ₃} where

  functional-⊆₂ : P ⊆₂ Q → Functional ≈ Q → Functional ≈ P
  functional-⊆₂ P⊆Q funcQ x y₁ y₂ Pxy₁ Pxy₂ = funcQ x y₁ y₂ (⊆₂-apply P⊆Q Pxy₁) (⊆₂-apply P⊆Q Pxy₂)