------------------------------------------------------------------------
-- The Agda standard library
--
-- Definitions of algebraic structures like monoids and rings
-- (packed in records together with sets, operations, etc.)
------------------------------------------------------------------------

-- The contents of this module should be accessed via `Algebra`.

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

module Algebra.Bundles where

open import Algebra.Core
open import Algebra.Structures
open import Relation.Binary
open import Function.Base
open import Level

------------------------------------------------------------------------
-- Bundles with 1 binary operation
------------------------------------------------------------------------

record RawMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier

record Magma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isMagma : IsMagma _≈_ _∙_

  open IsMagma isMagma public

  rawMagma : RawMagma _ _
  rawMagma = record { _≈_ = _≈_; _∙_ = _∙_ }

record Semigroup c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier     : Set c
    _≈_         : Rel Carrier ℓ
    _∙_         : Op₂ Carrier
    isSemigroup : IsSemigroup _≈_ _∙_

  open IsSemigroup isSemigroup public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public using (rawMagma)

record Band c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    isBand  : IsBand _≈_ _∙_

  open IsBand isBand public

  semigroup : Semigroup c ℓ
  semigroup = record { isSemigroup = isSemigroup }

  open Semigroup semigroup public using (magma; rawMagma)

record CommutativeSemigroup c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier                 : Set c
    _≈_                     : Rel Carrier ℓ
    _∙_                     : Op₂ Carrier
    isCommutativeSemigroup  : IsCommutativeSemigroup _≈_ _∙_

  open IsCommutativeSemigroup isCommutativeSemigroup public

  semigroup : Semigroup c ℓ
  semigroup = record { isSemigroup = isSemigroup }

  open Semigroup semigroup public using (magma; rawMagma)

record Semilattice c ℓ : Set (suc (c ⊔ ℓ)) where
  infixr 7 _∧_
  infix  4 _≈_
  field
    Carrier       : Set c
    _≈_           : Rel Carrier ℓ
    _∧_           : Op₂ Carrier
    isSemilattice : IsSemilattice _≈_ _∧_

  open IsSemilattice isSemilattice public

  band : Band c ℓ
  band = record { isBand = isBand }

  open Band band public using (rawMagma; magma; semigroup)

record SelectiveMagma c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier          : Set c
    _≈_              : Rel Carrier ℓ
    _∙_              : Op₂ Carrier
    isSelectiveMagma : IsSelectiveMagma _≈_ _∙_

  open IsSelectiveMagma isSelectiveMagma public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public using (rawMagma)

------------------------------------------------------------------------
-- Bundles with 1 binary operation & 1 element
------------------------------------------------------------------------

-- A raw monoid is a monoid without any laws.

record RawMonoid c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    ε       : Carrier

  rawMagma : RawMagma c ℓ
  rawMagma = record
    { _≈_ = _≈_
    ; _∙_ = _∙_
    }

record Monoid c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier  : Set c
    _≈_      : Rel Carrier ℓ
    _∙_      : Op₂ Carrier
    ε        : Carrier
    isMonoid : IsMonoid _≈_ _∙_ ε

  open IsMonoid isMonoid public

  semigroup : Semigroup _ _
  semigroup = record { isSemigroup = isSemigroup }

  rawMonoid : RawMonoid _ _
  rawMonoid = record { _≈_ = _≈_; _∙_ = _∙_; ε = ε}

  open Semigroup semigroup public using (rawMagma; magma)

record CommutativeMonoid c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier             : Set c
    _≈_                 : Rel Carrier ℓ
    _∙_                 : Op₂ Carrier
    ε                   : Carrier
    isCommutativeMonoid : IsCommutativeMonoid _≈_ _∙_ ε

  open IsCommutativeMonoid isCommutativeMonoid public

  monoid : Monoid _ _
  monoid = record { isMonoid = isMonoid }

  commutativeSemigroup : CommutativeSemigroup _ _
  commutativeSemigroup = record { isCommutativeSemigroup = isCommutativeSemigroup }

  open Monoid monoid public using (rawMagma; magma; semigroup; rawMonoid)

record IdempotentCommutativeMonoid c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier                       : Set c
    _≈_                           : Rel Carrier ℓ
    _∙_                           : Op₂ Carrier
    ε                             : Carrier
    isIdempotentCommutativeMonoid : IsIdempotentCommutativeMonoid _≈_ _∙_ ε

  open IsIdempotentCommutativeMonoid isIdempotentCommutativeMonoid public

  commutativeMonoid : CommutativeMonoid _ _
  commutativeMonoid = record { isCommutativeMonoid = isCommutativeMonoid }

  open CommutativeMonoid commutativeMonoid public
    using (rawMagma; magma; semigroup; rawMonoid; monoid)

-- Idempotent commutative monoids are also known as bounded lattices.
-- Note that the BoundedLattice necessarily uses the notation inherited
-- from monoids rather than lattices.

BoundedLattice = IdempotentCommutativeMonoid

module BoundedLattice {c ℓ} (idemCommMonoid : IdempotentCommutativeMonoid c ℓ) =
       IdempotentCommutativeMonoid idemCommMonoid

------------------------------------------------------------------------
-- Bundles with 1 binary operation, 1 unary operation & 1 element
------------------------------------------------------------------------

record RawGroup c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 _⁻¹
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    ε       : Carrier
    _⁻¹     : Op₁ Carrier

  rawMonoid : RawMonoid c ℓ
  rawMonoid = record
    { _≈_ = _≈_
    ; _∙_ = _∙_
    ; ε   = ε
    }

  open RawMonoid rawMonoid public
    using (rawMagma)

record Group c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 _⁻¹
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _∙_     : Op₂ Carrier
    ε       : Carrier
    _⁻¹     : Op₁ Carrier
    isGroup : IsGroup _≈_ _∙_ ε _⁻¹

  open IsGroup isGroup public

  rawGroup : RawGroup _ _
  rawGroup = record { _≈_ = _≈_; _∙_ = _∙_; ε = ε; _⁻¹ = _⁻¹}

  monoid : Monoid _ _
  monoid = record { isMonoid = isMonoid }

  open Monoid monoid public using (rawMagma; magma; semigroup; rawMonoid)

record AbelianGroup c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 _⁻¹
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier        : Set c
    _≈_            : Rel Carrier ℓ
    _∙_            : Op₂ Carrier
    ε              : Carrier
    _⁻¹            : Op₁ Carrier
    isAbelianGroup : IsAbelianGroup _≈_ _∙_ ε _⁻¹

  open IsAbelianGroup isAbelianGroup public

  group : Group _ _
  group = record { isGroup = isGroup }

  open Group group public
    using (rawMagma; magma; semigroup; monoid; rawMonoid; rawGroup)

  commutativeMonoid : CommutativeMonoid _ _
  commutativeMonoid =
    record { isCommutativeMonoid = isCommutativeMonoid }

------------------------------------------------------------------------
-- Bundles with 2 binary operations
------------------------------------------------------------------------

record Lattice c ℓ : Set (suc (c ⊔ ℓ)) where
  infixr 7 _∧_
  infixr 6 _∨_
  infix  4 _≈_
  field
    Carrier   : Set c
    _≈_       : Rel Carrier ℓ
    _∨_       : Op₂ Carrier
    _∧_       : Op₂ Carrier
    isLattice : IsLattice _≈_ _∨_ _∧_

  open IsLattice isLattice public

  setoid : Setoid _ _
  setoid = record { isEquivalence = isEquivalence }

record DistributiveLattice c ℓ : Set (suc (c ⊔ ℓ)) where
  infixr 7 _∧_
  infixr 6 _∨_
  infix  4 _≈_
  field
    Carrier               : Set c
    _≈_                   : Rel Carrier ℓ
    _∨_                   : Op₂ Carrier
    _∧_                   : Op₂ Carrier
    isDistributiveLattice : IsDistributiveLattice _≈_ _∨_ _∧_

  open IsDistributiveLattice isDistributiveLattice public

  lattice : Lattice _ _
  lattice = record { isLattice = isLattice }

  open Lattice lattice public using (setoid)

------------------------------------------------------------------------
-- Bundles with 2 binary operations & 1 element
------------------------------------------------------------------------

record NearSemiring c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier        : Set c
    _≈_            : Rel Carrier ℓ
    _+_            : Op₂ Carrier
    _*_            : Op₂ Carrier
    0#             : Carrier
    isNearSemiring : IsNearSemiring _≈_ _+_ _*_ 0#

  open IsNearSemiring isNearSemiring public

  +-monoid : Monoid _ _
  +-monoid = record { isMonoid = +-isMonoid }

  open Monoid +-monoid public
    using ()
    renaming
    ( rawMagma  to +-rawMagma
    ; magma     to +-magma
    ; semigroup to +-semigroup
    ; rawMonoid to +-rawMonoid
    )

  *-semigroup : Semigroup _ _
  *-semigroup = record { isSemigroup = *-isSemigroup }

  open Semigroup *-semigroup public
    using ()
    renaming
    ( rawMagma to *-rawMagma
    ; magma    to *-magma
    )

record SemiringWithoutOne c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier              : Set c
    _≈_                  : Rel Carrier ℓ
    _+_                  : Op₂ Carrier
    _*_                  : Op₂ Carrier
    0#                   : Carrier
    isSemiringWithoutOne : IsSemiringWithoutOne _≈_ _+_ _*_ 0#

  open IsSemiringWithoutOne isSemiringWithoutOne public

  nearSemiring : NearSemiring _ _
  nearSemiring = record { isNearSemiring = isNearSemiring }

  open NearSemiring nearSemiring public
    using
    ( +-rawMagma; +-magma; +-semigroup; +-rawMonoid; +-monoid
    ; *-rawMagma; *-magma; *-semigroup
    )

  +-commutativeMonoid : CommutativeMonoid _ _
  +-commutativeMonoid =
    record { isCommutativeMonoid = +-isCommutativeMonoid }

record CommutativeSemiringWithoutOne c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier                         : Set c
    _≈_                             : Rel Carrier ℓ
    _+_                             : Op₂ Carrier
    _*_                             : Op₂ Carrier
    0#                              : Carrier
    isCommutativeSemiringWithoutOne :
      IsCommutativeSemiringWithoutOne _≈_ _+_ _*_ 0#

  open IsCommutativeSemiringWithoutOne
         isCommutativeSemiringWithoutOne public

  semiringWithoutOne : SemiringWithoutOne _ _
  semiringWithoutOne =
    record { isSemiringWithoutOne = isSemiringWithoutOne }

  open SemiringWithoutOne semiringWithoutOne public
    using
    ( +-rawMagma; +-magma; +-semigroup
    ; *-rawMagma; *-magma; *-semigroup
    ; +-rawMonoid; +-monoid; +-commutativeMonoid
    ; nearSemiring
    )

------------------------------------------------------------------------
-- Bundles with 2 binary operations & 2 elements
------------------------------------------------------------------------

record RawSemiring c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier    : Set c
    _≈_        : Rel Carrier ℓ
    _+_        : Op₂ Carrier
    _*_        : Op₂ Carrier
    0#         : Carrier
    1#         : Carrier

record SemiringWithoutAnnihilatingZero c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier                           : Set c
    _≈_                               : Rel Carrier ℓ
    _+_                               : Op₂ Carrier
    _*_                               : Op₂ Carrier
    0#                                : Carrier
    1#                                : Carrier
    isSemiringWithoutAnnihilatingZero :
      IsSemiringWithoutAnnihilatingZero _≈_ _+_ _*_ 0# 1#

  open IsSemiringWithoutAnnihilatingZero
         isSemiringWithoutAnnihilatingZero public

  +-commutativeMonoid : CommutativeMonoid _ _
  +-commutativeMonoid =
    record { isCommutativeMonoid = +-isCommutativeMonoid }

  open CommutativeMonoid +-commutativeMonoid public
    using ()
    renaming
    ( rawMagma  to +-rawMagma
    ; magma     to +-magma
    ; semigroup to +-semigroup
    ; rawMonoid to +-rawMonoid
    ; monoid    to +-monoid
    )

  *-monoid : Monoid _ _
  *-monoid = record { isMonoid = *-isMonoid }

  open Monoid *-monoid public
    using ()
    renaming
    ( rawMagma  to *-rawMagma
    ; magma     to *-magma
    ; semigroup to *-semigroup
    ; rawMonoid to *-rawMonoid
    )

record Semiring c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier    : Set c
    _≈_        : Rel Carrier ℓ
    _+_        : Op₂ Carrier
    _*_        : Op₂ Carrier
    0#         : Carrier
    1#         : Carrier
    isSemiring : IsSemiring _≈_ _+_ _*_ 0# 1#

  open IsSemiring isSemiring public

  rawSemiring : RawSemiring _ _
  rawSemiring = record
    { _≈_ = _≈_
    ; _+_ = _+_
    ; _*_ = _*_
    ; 0#  = 0#
    ; 1#  = 1#
    }

  semiringWithoutAnnihilatingZero : SemiringWithoutAnnihilatingZero _ _
  semiringWithoutAnnihilatingZero = record
    { isSemiringWithoutAnnihilatingZero =
        isSemiringWithoutAnnihilatingZero
    }

  open SemiringWithoutAnnihilatingZero
         semiringWithoutAnnihilatingZero public
    using
    ( +-rawMagma;  +-magma;  +-semigroup
    ; *-rawMagma;  *-magma;  *-semigroup
    ; +-rawMonoid; +-monoid; +-commutativeMonoid
    ; *-rawMonoid; *-monoid
    )

  semiringWithoutOne : SemiringWithoutOne _ _
  semiringWithoutOne =
    record { isSemiringWithoutOne = isSemiringWithoutOne }

  open SemiringWithoutOne semiringWithoutOne public
    using (nearSemiring)

record CommutativeSemiring c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier               : Set c
    _≈_                   : Rel Carrier ℓ
    _+_                   : Op₂ Carrier
    _*_                   : Op₂ Carrier
    0#                    : Carrier
    1#                    : Carrier
    isCommutativeSemiring : IsCommutativeSemiring _≈_ _+_ _*_ 0# 1#

  open IsCommutativeSemiring isCommutativeSemiring public

  semiring : Semiring _ _
  semiring = record { isSemiring = isSemiring }

  open Semiring semiring public
    using
    ( +-rawMagma; +-magma; +-semigroup
    ; *-rawMagma; *-magma; *-semigroup
    ; +-rawMonoid; +-monoid; +-commutativeMonoid
    ; *-rawMonoid; *-monoid
    ; nearSemiring; semiringWithoutOne
    ; semiringWithoutAnnihilatingZero
    ; rawSemiring
    )

  *-commutativeSemigroup : CommutativeSemigroup _ _
  *-commutativeSemigroup = record
    { isCommutativeSemigroup = *-isCommutativeSemigroup
    }

  *-commutativeMonoid : CommutativeMonoid _ _
  *-commutativeMonoid = record
    { isCommutativeMonoid = *-isCommutativeMonoid
    }

  commutativeSemiringWithoutOne : CommutativeSemiringWithoutOne _ _
  commutativeSemiringWithoutOne = record
    { isCommutativeSemiringWithoutOne = isCommutativeSemiringWithoutOne
    }

------------------------------------------------------------------------
-- Bundles with 2 binary operations, 1 unary operation & 2 elements
------------------------------------------------------------------------

-- A raw ring is a ring without any laws.

record RawRing c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 -_
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _+_     : Op₂ Carrier
    _*_     : Op₂ Carrier
    -_      : Op₁ Carrier
    0#      : Carrier
    1#      : Carrier

  +-rawGroup : RawGroup c ℓ
  +-rawGroup = record
    { _≈_ = _≈_
    ; _∙_ = _+_
    ; ε   = 0#
    ; _⁻¹ = -_
    }

  *-rawMonoid : RawMonoid c ℓ
  *-rawMonoid = record
    { _≈_     = _≈_
    ; _∙_     = _*_
    ; ε       = 1#
    }

record Ring c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 -_
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _+_     : Op₂ Carrier
    _*_     : Op₂ Carrier
    -_      : Op₁ Carrier
    0#      : Carrier
    1#      : Carrier
    isRing  : IsRing _≈_ _+_ _*_ -_ 0# 1#

  open IsRing isRing public

  +-abelianGroup : AbelianGroup _ _
  +-abelianGroup = record { isAbelianGroup = +-isAbelianGroup }

  semiring : Semiring _ _
  semiring = record { isSemiring = isSemiring }

  open Semiring semiring public
    using
    ( +-rawMagma; +-magma; +-semigroup
    ; *-rawMagma; *-magma; *-semigroup
    ; +-rawMonoid; +-monoid ; +-commutativeMonoid
    ; *-rawMonoid; *-monoid
    ; nearSemiring; semiringWithoutOne
    ; semiringWithoutAnnihilatingZero
    )

  open AbelianGroup +-abelianGroup public
    using () renaming (group to +-group)

  rawRing : RawRing _ _
  rawRing = record
    { _≈_ = _≈_
    ; _+_ = _+_
    ; _*_ = _*_
    ; -_  = -_
    ; 0#  = 0#
    ; 1#  = 1#
    }

record CommutativeRing c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 -_
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier           : Set c
    _≈_               : Rel Carrier ℓ
    _+_               : Op₂ Carrier
    _*_               : Op₂ Carrier
    -_                : Op₁ Carrier
    0#                : Carrier
    1#                : Carrier
    isCommutativeRing : IsCommutativeRing _≈_ _+_ _*_ -_ 0# 1#

  open IsCommutativeRing isCommutativeRing public

  ring : Ring _ _
  ring = record { isRing = isRing }

  commutativeSemiring : CommutativeSemiring _ _
  commutativeSemiring =
    record { isCommutativeSemiring = isCommutativeSemiring }

  open Ring ring public using (rawRing; +-group; +-abelianGroup)
  open CommutativeSemiring commutativeSemiring public
    using
    ( +-rawMagma; +-magma; +-semigroup
    ; *-rawMagma; *-magma; *-semigroup
    ; +-rawMonoid; +-monoid; +-commutativeMonoid
    ; *-rawMonoid; *-monoid; *-commutativeMonoid
    ; nearSemiring; semiringWithoutOne
    ; semiringWithoutAnnihilatingZero; semiring
    ; commutativeSemiringWithoutOne
    )

record BooleanAlgebra c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 ¬_
  infixr 7 _∧_
  infixr 6 _∨_
  infix  4 _≈_
  field
    Carrier          : Set c
    _≈_              : Rel Carrier ℓ
    _∨_              : Op₂ Carrier
    _∧_              : Op₂ Carrier
    ¬_               : Op₁ Carrier
    ⊤                : Carrier
    ⊥                : Carrier
    isBooleanAlgebra : IsBooleanAlgebra _≈_ _∨_ _∧_ ¬_ ⊤ ⊥

  open IsBooleanAlgebra isBooleanAlgebra public

  distributiveLattice : DistributiveLattice _ _
  distributiveLattice = record { isDistributiveLattice = isDistributiveLattice }

  open DistributiveLattice distributiveLattice public
    using (setoid; lattice)

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

-- Version 1.0

RawSemigroup = RawMagma
{-# WARNING_ON_USAGE RawSemigroup
"Warning: RawSemigroup was deprecated in v1.0.
Please use RawMagma instead."
#-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties related to Pointwise
------------------------------------------------------------------------

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

module Data.Vec.Functional.Relation.Binary.Pointwise.Properties where

open import Data.Fin.Base
open import Data.Fin.Properties
  hiding (isDecEquivalence; setoid; decSetoid)
open import Data.Nat.Base
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Data.Product.Relation.Binary.Pointwise.NonDependent
  using () renaming (Pointwise to ×-Pointwise)
open import Data.Sum.Base using (_⊎_; inj₁; inj₂; [_,_])
open import Data.Vec.Functional as VF hiding (map)
open import Data.Vec.Functional.Relation.Binary.Pointwise
open import Function
open import Level using (Level)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_)

private
  variable
    a a′ a″ b b′ b″ r s t ℓ : Level
    A : Set a
    B : Set b
    A′ : Set a′
    B′ : Set b′
    A″ : Set a″
    B″ : Set b″

------------------------------------------------------------------------
-- Relational properties

module _ {R : Rel A ℓ} where

  refl : Reflexive R → ∀ {n} → Reflexive (Pointwise R {n})
  refl r i = r

  sym : Symmetric R → ∀ {n} → Symmetric (Pointwise R {n})
  sym s xsys i = s (xsys i)

  trans : Transitive R → ∀ {n} → Transitive (Pointwise R {n})
  trans t xsys yszs i = t (xsys i) (yszs i)

  decidable : Decidable R → ∀ {n} → Decidable (Pointwise R {n})
  decidable r? xs ys = all? λ i → r? (xs i) (ys i)

------------------------------------------------------------------------
-- Structures

  isEquivalence : IsEquivalence R → ∀ n → IsEquivalence (Pointwise R {n})
  isEquivalence isEq n = record
    { refl  = refl  Eq.refl
    ; sym   = sym   Eq.sym
    ; trans = trans Eq.trans
    } where module Eq = IsEquivalence isEq

  isDecEquivalence : IsDecEquivalence R →
                     ∀ n → IsDecEquivalence (Pointwise R {n})
  isDecEquivalence isDecEq n = record
    { isEquivalence = isEquivalence Eq.isEquivalence n
    ; _≟_           = decidable Eq._≟_
    } where module Eq = IsDecEquivalence isDecEq

------------------------------------------------------------------------
-- Bundles

setoid : Setoid a ℓ → ℕ → Setoid a ℓ
setoid S n = record
  { isEquivalence = isEquivalence S.isEquivalence n
  } where module S = Setoid S

decSetoid : DecSetoid a ℓ → ℕ → DecSetoid a ℓ
decSetoid S n = record
  { isDecEquivalence = isDecEquivalence S.isDecEquivalence n
  } where module S = DecSetoid S

------------------------------------------------------------------------
-- map

module _ {R : REL A B r} {S : REL A′ B′ s} {f : A → A′} {g : B → B′} where

  map⁺ : (∀ {x y} → R x y → S (f x) (g y)) →
         ∀ {n} {xs : Vector A n} {ys : Vector B n} →
         Pointwise R xs ys → Pointwise S (VF.map f xs) (VF.map g ys)
  map⁺ f rs i = f (rs i)

------------------------------------------------------------------------
-- head

module _ (R : REL A B r) {n} {xs : Vector A (suc n)} {ys} where

  head⁺ : Pointwise R xs ys → R (head xs) (head ys)
  head⁺ rs = rs zero

------------------------------------------------------------------------
-- tail

module _ (R : REL A B r) {n} {xs : Vector A (suc n)} {ys} where

  tail⁺ : Pointwise R xs ys → Pointwise R (tail xs) (tail ys)
  tail⁺ rs = rs ∘ suc

------------------------------------------------------------------------
-- _++_

module _ (R : REL A B r) where

  ++⁺ : ∀ {m n xs ys xs′ ys′} →
        Pointwise R {n = m} xs ys → Pointwise R {n = n} xs′ ys′ →
        Pointwise R (xs ++ xs′) (ys ++ ys′)
  ++⁺ {m} rs rs′ i with splitAt m i
  ... | inj₁ i′ = rs i′
  ... | inj₂ j′ = rs′ j′

  ++⁻ˡ : ∀ {m n} (xs : Vector A m) (ys : Vector B m) {xs′ ys′} →
         Pointwise R (xs ++ xs′) (ys ++ ys′) → Pointwise R xs ys
  ++⁻ˡ {m} {n} _ _ rs i with rs (inject+ n i)
  ... | r rewrite splitAt-inject+ m n i = r

  ++⁻ʳ : ∀ {m n} (xs : Vector A m) (ys : Vector B m) {xs′ ys′} →
         Pointwise R (xs ++ xs′) (ys ++ ys′) → Pointwise R xs′ ys′
  ++⁻ʳ {m} {n} _ _ rs i with rs (raise m i)
  ... | r rewrite splitAt-raise m n i = r

  ++⁻ : ∀ {m n} xs ys {xs′ ys′} →
        Pointwise R (xs ++ xs′) (ys ++ ys′) →
        Pointwise R {n = m} xs ys × Pointwise R {n = n} xs′ ys′
  ++⁻ _ _ rs = ++⁻ˡ _ _ rs , ++⁻ʳ _ _ rs

------------------------------------------------------------------------
-- replicate

module _ {R : REL A B r} {x y n} where

  replicate⁺ : R x y → Pointwise R {n = n} (replicate x) (replicate y)
  replicate⁺ = const

------------------------------------------------------------------------
-- _⊛_

module _ {R : REL A B r} {S : REL A′ B′ s} {n} where

  ⊛⁺ : ∀ {fs : Vector (A → A′) n} {gs : Vector (B → B′) n} →
       Pointwise (λ f g → ∀ {x y} → R x y → S (f x) (g y)) fs gs →
       ∀ {xs ys} → Pointwise R xs ys → Pointwise S (fs ⊛ xs) (gs ⊛ ys)
  ⊛⁺ rss rs i = (rss i) (rs i)

------------------------------------------------------------------------
-- zipWith

module _ {R : REL A B r} {S : REL A′ B′ s} {T : REL A″ B″ t} where

  zipWith⁺ : ∀ {n xs ys xs′ ys′ f f′} →
             (∀ {x y x′ y′} → R x y → S x′ y′ → T (f x x′) (f′ y y′)) →
             Pointwise R xs ys → Pointwise S xs′ ys′ →
             Pointwise T (zipWith f xs xs′) (zipWith f′ {n = n} ys ys′)
  zipWith⁺ t rs ss i = t (rs i) (ss i)

------------------------------------------------------------------------
-- zip

module _ {R : REL A B r} {S : REL A′ B′ s} {n xs ys xs′ ys′} where

  zip⁺ : Pointwise R xs ys → Pointwise S xs′ ys′ →
         Pointwise (λ xx yy → R (proj₁ xx) (proj₁ yy) × S (proj₂ xx) (proj₂ yy))
                   (zip xs xs′) (zip {n = n} ys ys′)
  zip⁺ rs ss i = rs i , ss i

  zip⁻ : Pointwise (λ xx yy → R (proj₁ xx) (proj₁ yy) × S (proj₂ xx) (proj₂ yy))
                   (zip xs xs′) (zip {n = n} ys ys′) →
         Pointwise R xs ys × Pointwise S xs′ ys′
  zip⁻ rss = proj₁ ∘ rss , proj₂ ∘ rss

------------------------------------------------------------------------
-- foldr

module _ {R : REL A B r} {S : REL A′ B′ s}
         {f : A → A′ → A′} {g : B → B′ → B′}
         where

  foldr-cong : (∀ {w x y z} → R w x → S y z → S (f w y) (g x z)) →
               ∀ {d : A′} {e : B′} → S d e →
               ∀ {n} {xs : Vector A n} {ys : Vector B n} →
               Pointwise R xs ys → S (foldr f d xs) (foldr g e ys)
  foldr-cong fg-cong d~e {zero}  rss = d~e
  foldr-cong fg-cong d~e {suc n} rss =
    fg-cong (rss zero) (foldr-cong fg-cong d~e (rss ∘ suc))


module Common.Context  where

import Level
open import Data.Nat as Nat
open import Data.List as List
import Level
open import Relation.Binary.PropositionalEquality as PE hiding ([_])
open import Relation.Binary -- using (Setoid; Rel; IsEquivalence)
open ≡-Reasoning
open import Function as Fun hiding (_∘′_)
open import Data.Sum as Sum hiding ([_,_])
open import Categories.Category using (Category)

open import Common.SumProperties

-------------------------
---- Type contexts

Ctx : Set → Set
Ctx Ty = List Ty

-- | De Bruijn variable indexing
data Var {Ty : Set} : (Γ : Ctx Ty) (a : Ty) → Set where
  zero : ∀{Γ a}                          → Var (a ∷ Γ) a
  succ : ∀{Γ b} (a : Ty) → (x : Var Γ a) → Var (b ∷ Γ) a

data _≅V_ {Ty} : ∀ {Γ Γ' : Ctx Ty} {a a' : Ty} → Var Γ a → Var Γ' a' → Set where
  zero : ∀ {Γ Γ'} {a a'}
         → zero {Γ = Γ} {a} ≅V zero {Γ = Γ'} {a'}

  succ  : ∀ {Γ Γ'} {a a'}
          → ∀ {x : Var Γ a} {x' : Var Γ' a'} {b b' : Ty}
          → x ≅V x'
          → succ {b = b} a x ≅V succ {b = b'} a' x'

Vrefl : ∀ {Ty} {Γ} {a : Ty} {x : Var Γ a} → x ≅V x
Vrefl {x = zero}  = zero
Vrefl {x = succ _ t} = succ Vrefl

Vsym : ∀ {Ty} {Γ Γ'} {a a' : Ty} {x : Var Γ a} {x' : Var Γ' a'}
       → x ≅V x' → x' ≅V x
Vsym zero      = zero
Vsym {Ty} (succ [x]) = succ (Vsym [x])

Vtrans : ∀ {Ty} {Γ Γ' Γ''} {a a' a'' : Ty}
           {x : Var Γ a} {x' : Var Γ' a'} {x'' : Var Γ'' a''}
         → x ≅V x' → x' ≅V x'' → x ≅V x''
Vtrans zero     zero      = zero
Vtrans (succ eq) (succ eq') = succ (Vtrans eq eq')

-- Note: makes the equality homogeneous in Γ and a
≅V-setoid : ∀ {Ty} {Γ} {a : Ty} → Setoid _ _
≅V-setoid {Ty} {Γ} {a} = record
  { Carrier = Var Γ a
  ; _≈_ = _≅V_
  ; isEquivalence = record
    { refl = Vrefl ; sym = Vsym ; trans = Vtrans }
  }

arr : ∀ {Ty} → (Γ Δ : Ctx Ty) → Set
arr {Ty} Γ Δ = ∀ (a : Ty) → Var Γ a → Var Δ a

_►_ = arr
-- _▹_ = arr

infix 4 _≡C_

record _≡C_ {Ty} {Γ Δ : Ctx Ty} (ρ : arr Γ Δ) (γ : arr Γ Δ) : Set where
  field
    ≡C-proof : ∀ {a} {x} → ρ a x ≡ γ a x
open _≡C_

_≈_ = _≡C_

Crefl : ∀ {Ty} {Γ Δ : Ctx Ty} → Reflexive (_≡C_ {Γ = Γ} {Δ})
Crefl = record { ≡C-proof = PE.refl }
Csym : ∀ {Ty} {Γ Δ : Ctx Ty} → Symmetric (_≡C_ {Γ = Γ} {Δ})
Csym p = record { ≡C-proof = PE.sym (≡C-proof p) }
Ctrans : ∀ {Ty} {Γ Δ : Ctx Ty} → Transitive (_≡C_ {Γ = Γ} {Δ})
Ctrans p₁ p₂ = record { ≡C-proof = PE.trans (≡C-proof p₁) (≡C-proof p₂) }

≡C-equiv : ∀ {Ty} {Γ Δ : Ctx Ty} → IsEquivalence (_≡C_ {Γ = Γ} {Δ})
≡C-equiv =
  record
  { refl = Crefl
  ; sym = Csym
  ; trans = Ctrans
  }

≡C-setoid : ∀ {Ty} {Γ Δ : Ctx Ty} → Setoid _ _
≡C-setoid {_} {Γ} {Δ} = record
  { Carrier = arr Γ Δ
  ; _≈_ = _≡C_
  ; isEquivalence = ≡C-equiv
  }

_∘′_ : ∀ {Ty} {Γ Δ Ξ : Ctx Ty} (ρ : Δ ► Ξ) (γ : Γ ► Δ) → Γ ► Ξ
_∘′_ ρ γ = λ a x → ρ a (γ a x)

_●_ = _∘′_

ctx-id : ∀ {Ty} {Γ : Ctx Ty} →  arr Γ Γ
ctx-id = λ _ x → x

comp-resp-≡C : ∀ {Ty} {Γ Δ Ξ : Ctx Ty} {ρ ρ' : arr Δ Ξ} {γ γ' : arr Γ Δ} →
               ρ ≡C ρ' → γ ≡C γ' → ρ ∘′ γ ≡C ρ' ∘′ γ'
comp-resp-≡C {_} {Γ} {Δ} {Ξ} {ρ} {ρ'} {γ} {γ'} ρ≡ρ' γ≡γ'
  = record { ≡C-proof = p }
  where
    p : ∀ {a} {x} → (ρ ∘′ γ) a x ≡ (ρ' ∘′ γ') a x
    p {a} {x} =
      begin
        (ρ ∘′ γ) a x
      ≡⟨ refl ⟩
        ρ a (γ a x)
      ≡⟨ cong (λ u → ρ a u) (≡C-proof γ≡γ') ⟩
        ρ a (γ' a x)
      ≡⟨ ≡C-proof ρ≡ρ' ⟩
        ρ' a (γ' a x)
      ≡⟨ refl ⟩
        (ρ' ∘′ γ') a x
      ∎

-- | Contexts form a category
ctx-cat : Set → Category Level.zero Level.zero Level.zero
ctx-cat Ty = record
   { Obj = Ctx Ty
   ; _⇒_ = arr
   ; _≡_ = _≡C_
   ; _∘_ = _∘′_
   ; id = ctx-id
   ; assoc = record { ≡C-proof = refl }
   ; identityˡ = record { ≡C-proof = refl }
   ; identityʳ = record { ≡C-proof = refl }
   ; equiv = ≡C-equiv
   ; ∘-resp-≡ = comp-resp-≡C
   }

-------------------------
---- Coproduct structure on contexts

{-
_⊕_ : Ctx → Ctx → Ctx
Γ₁ ⊕ Γ₂ = Γ₁ ++ Γ₂

in₁ : {Γ₁ Γ₂ : Ctx} → Γ₁ ▹ (Γ₁ ⊕ Γ₂)
in₁ _ zero     = zero
in₁ a (succ .a x) = succ a (in₁ a x)

in₂ : {{Γ₁ Γ₂ : Ctx}} → Γ₂ ▹ (Γ₁ ⊕ Γ₂)
in₂ {{[]}}     _ x = x
in₂ {{b ∷ Γ₁}} a x = succ a (in₂ a x)

split : {Γ₁ Γ₂ : Ctx} {a : Ty} → Var (Γ₁ ⊕ Γ₂) a → Var Γ₁ a ⊎ Var Γ₂ a
split {[]}      {Γ₂}     x        = inj₂ x
split {a ∷ Γ₁'} {Γ₂}     zero     = inj₁ zero
split {b ∷ Γ₁'} {Γ₂} {a} (succ .a y) = (Sum.map (succ a) (ctx-id a)) (split {Γ₁'} y)

[_,_] : {Γ₁ Γ₂ Δ : Ctx} (f : Γ₁ ▹ Δ) (g : Γ₂ ▹ Δ)
      → ((Γ₁ ⊕ Γ₂) ▹ Δ)
[_,_] {Γ} {Γ₂} f g a x = ([ f a , g a ]′) (split x)

_-⊕-_ : {Γ Γ₂ Γ' Γ₂' : Ctx} (f : Γ ▹ Γ') (g : Γ₂ ▹ Γ₂')
      → ((Γ ⊕ Γ₂) ▹ (Γ' ⊕ Γ₂'))
_-⊕-_ {Γ} {Γ₂} {Γ'} {Γ₂'} f g = [ in₁ ● f , in₂ {{Γ'}} {{Γ₂'}} ● g ]

succ-distr-lemma : {Γ : Ctx} {a b : Ty} (Γ₂ : Ctx) (x : Var Γ a) →
                   (in₁ {b ∷ Γ} ● succ {Γ}) a x
                   ≡ (succ {Γ ⊕ Γ₂} ● in₁ {Γ} {Γ₂}) a x
succ-distr-lemma Γ₂ x = refl

split-lemma₁ : {a : Ty} (Γ₁ Γ₂ : Ctx) (x : Var Γ₁ a) →
               split {Γ₁} {Γ₂} (in₁ {Γ₁} a x) ≡ inj₁ x
split-lemma₁ (tt ∷ Γ₁) Γ₂ zero       = refl
split-lemma₁ (tt ∷ Γ₁) Γ₂ (succ a x) =
  begin
    split {tt ∷ Γ₁} (in₁ {tt ∷ Γ₁} a (succ a x))
  ≡⟨ refl ⟩
    (Sum.map (succ a) id) (split (in₁ a x))
  ≡⟨ cong (Sum.map (succ a) id) (split-lemma₁ Γ₁ Γ₂ x) ⟩
    (Sum.map (succ a) id) (inj₁ x)
  ≡⟨ refl ⟩
    inj₁ (succ a x)
  ∎

split-lemma₂ : {a : Ty} (Γ₁ Γ₂ : Ctx) (x : Var Γ₂ a) →
               split {Γ₁} {Γ₂} (in₂ a x) ≡ inj₂ x
split-lemma₂ [] Γ₂ x = refl
split-lemma₂ {a} (tt ∷ Γ₁) Γ₂ x =
  begin
    split {tt ∷ Γ₁} {Γ₂} (in₂ {{tt ∷ Γ₁}} a x)
  ≡⟨ refl ⟩
    Sum.map (succ a) id (split (in₂ {{Γ₁}} a x))
  ≡⟨ cong (λ u → Sum.map (succ a) id u) (split-lemma₂ Γ₁ Γ₂ x) ⟩
    Sum.map (succ a) id (inj₂ x)
  ≡⟨ refl ⟩
    inj₂ x
  ∎

split-lemma : (Γ₁ Γ₂ : Ctx) (a : Ty) (x : Var (Γ₁ ⊕ Γ₂) a) →
             [ in₁ {Γ₁} {Γ₂} a , in₂ a ]′ (split x) ≡ x
split-lemma []       Γ₂ _  x           = refl
split-lemma (a ∷ Γ₁) Γ₂ .a zero        = refl
split-lemma (b ∷ Γ₁) Γ₂ a  (succ .a x) =
  begin
    [ in₁ {b ∷ Γ₁} a , in₂ {{b ∷ Γ₁}} a ]′ (split (succ a x))
  ≡⟨ refl ⟩
    [ in₁ {b ∷ Γ₁} a , (succ {Γ₁ ⊕ Γ₂} ● in₂ {{Γ₁}} ) a ]′
      (Sum.map (succ {Γ₁} a) id (split x))
  ≡⟨ copair-sum-map-merge {f₁ = Var.succ {Γ₁} {b} a} (split x) ⟩
    [ (in₁ {b ∷ Γ₁} ● succ {Γ₁}) a , (succ {Γ₁ ⊕ Γ₂} ● in₂) a ]′ (split x)
  ≡⟨ copair-cong {f = (in₁ {b ∷ Γ₁} ● succ {Γ₁}) a}
                 (succ-distr-lemma Γ₂)
                 (split x) ⟩
    [ (succ {Γ₁ ⊕ Γ₂} ● in₁ {Γ₁}) a , (succ {Γ₁ ⊕ Γ₂} ● in₂) a ]′ (split x)
  ≡⟨ copair-distr {f = in₁ {Γ₁} {Γ₂} a} {h = succ {Γ₁ ⊕ Γ₂} a} (split x)⟩
    (Var.succ {Γ₁ ⊕ Γ₂} {b} a ∘ [ in₁ {Γ₁} a , in₂ a ]′) (split x)
  ≡⟨ cong (succ {Γ₁ ⊕ Γ₂} {b} a) (split-lemma Γ₁ Γ₂ a x) ⟩
     succ {Γ₁ ⊕ Γ₂} a x
  ∎

⊕-is-coprod-arg : ∀{Γ₁ Γ₂ : Ctx} (a : Ty) (x : Var (Γ₁ ⊕ Γ₂) a) →
                  [ in₁ {Γ₁} {Γ₂} , in₂ ] a x ≡ ctx-id a x
⊕-is-coprod-arg {Γ₁} {Γ₂} = split-lemma Γ₁ Γ₂

⊕-is-coprod : ∀{Γ₁ Γ₂ : Ctx} → [ in₁ {Γ₁} {Γ₂} , in₂ ] ≡C ctx-id
⊕-is-coprod {Γ₁} = {!!}
{-
  η-≡ {f₁ = [ in₁ {Γ₁} , in₂ ]}
      {f₂ = ctx-id}
      (λ (a : Ty) →
        η-≡ {f₁ = [ in₁ {Γ₁}, in₂ ] a}
            {f₂ = ctx-id a}
            (⊕-is-coprod-arg {Γ₁} a)
       )
-}

●-distr-copair₁ˡ : ∀{Γ₁ Γ₂ Δ : Ctx}
                   (h : (Γ₁ ⊕ Γ₂) ▹ Δ) (a : Ty) (x : Var (Γ₁ ⊕ Γ₂) a) →
                   [ h ● in₁ {Γ₁} {Γ₂} , h ● in₂ {{Γ₁}} {{Γ₂}} ] a x
                   ≡ (h ● [ in₁ {Γ₁} {Γ₂} , in₂ ]) a x
●-distr-copair₁ˡ {Γ₁} {Γ₂} {Δ} h a x =
  begin
    [ h ● in₁ {Γ₁} , h ● in₂ ] a x
  ≡⟨ refl ⟩
    ([ (h ● in₁ {Γ₁}) a , (h ● in₂) a ]′) (split x)
  ≡⟨ copair-distr {f = in₁ {Γ₁} a} {g = in₂ a} {h = h a} (split x) ⟩
    (h ● [ in₁ {Γ₁} , in₂ ]) a x
  ∎

●-distr-copairˡ : ∀{Γ₁ Γ₂ Δ : Ctx} (h : (Γ₁ ⊕ Γ₂) ▹ Δ) →
                 [ h ● in₁ {Γ₁} {Γ₂} , h ● in₂ {{Γ₁}} {{Γ₂}} ]
                 ≡ h ● [ in₁ {Γ₁} {Γ₂} , in₂ ]
●-distr-copairˡ {Γ₁} h = {!!}
  -- η-≡ (λ a → η-≡ (●-distr-copair₁ˡ {Γ₁} h a))

⊕-is-coprod₁ : ∀{Γ₁ Γ₂ Δ : Ctx} {f : Γ₁ ▹ Δ} {g : Γ₂ ▹ Δ} {h : (Γ₁ ⊕ Γ₂) ▹ Δ} →
               h ● in₁ ≡C f → h ● in₂ ≡C g → [ f , g ] ≡C h
⊕-is-coprod₁ {Γ₁} {Γ₂} {Δ} {f} {g} {h} h●in₁≡f h●in₂≡g
  = record { ≡C-proof = p }
  where
    p : ∀ {a} {x} → [ f , g ] a x ≡ h a x
    p {a} {x} =
      begin
        [ f , g ] a x
      ≡⟨ refl ⟩
        ([ f a , g a ]′) (split x)
      ≡⟨ cong (λ u → [ u , g a ]′ (split x)) {!!} ⟩
        ([ (h ● in₁ {Γ₁}) a , g a ]′) (split x)
      ≡⟨ {!!} ⟩
        h a x
      ∎
{-
        [ h ● in₁ {Γ₁} , g ]
      ≡⟨ cong (λ u → [ h ● in₁ {Γ₁} , u ]) (sym h●in₂≡g) ⟩
        [ h ● in₁ {Γ₁} , h ● in₂ ]
      ≡⟨ ●-distr-copairˡ {Γ₁} h ⟩
        h ● [ in₁ {Γ₁}, in₂ ]
      ≡⟨ cong (λ u → h ● u) (⊕-is-coprod {Γ₁}) ⟩
        h ● ctx-id
      ≡⟨ refl ⟩
        h
  -}

commute-in₁-arg : ∀ {Γ₁ Γ₂ Δ : Ctx} {f : Γ₁ ▹ Δ} {g : Γ₂ ▹ Δ}
                    (a : Ty) (x : Var Γ₁ a) →
                  ([ f , g ] ● in₁) a x ≡ f a x
commute-in₁-arg _ zero = refl
commute-in₁-arg {b ∷ Γ₁} {Γ₂} {Δ} {f} {g} a (succ .a x) =
  begin
    ([ f , g ] ● in₁ {b ∷ Γ₁}) a (succ {Γ₁} a x)
  ≡⟨ refl ⟩
    [ f , g ] a (succ {Γ₁ ⊕ Γ₂} a (in₁ {Γ₁} a x))
  ≡⟨ refl ⟩
    ([ f a , g a ]′) (split (succ {Γ₁ ⊕ Γ₂} a (in₁ {Γ₁} a x)))
  ≡⟨ refl ⟩
    [ f a , g a ]′ ((Sum.map (succ a) id) (split {Γ₁} {Γ₂} (in₁ {Γ₁} a x)))
  ≡⟨ refl ⟩
    (([ f a , g a ]′ ∘ (Sum.map (succ a) id)) (split {Γ₁} {Γ₂} (in₁ {Γ₁} a x)))
  ≡⟨ copair-sum-map-merge {f₁ = succ a} (split {Γ₁} {Γ₂} (in₁ {Γ₁} a x)) ⟩
    ([ (f ● succ) a , g a ]′ (split {Γ₁} {Γ₂} (in₁ {Γ₁} a x)))
  ≡⟨ cong ([ (f ● succ) a , g a ]′) (split-lemma₁ Γ₁ Γ₂ x) ⟩
    f a (succ a x)
  ∎

commute-in₁ : (Γ₁ : Ctx) → (Γ₂ : Ctx) → {Δ : Ctx} {f : Γ₁ ▹ Δ} {g : Γ₂ ▹ Δ}
              → ([ f , g ] ● in₁) ≡C f
commute-in₁ Γ₁ Γ₂ {Δ} {f} {g} =
  record { ≡C-proof = λ {a} {x} → commute-in₁-arg {f = f} {g} a x }

commute-in₂-arg : ∀ {Γ₁ Γ₂ Δ : Ctx} {f : Γ₁ ▹ Δ} {g : Γ₂ ▹ Δ}
                    (a : Ty) (x : Var Γ₂ a) →
                  ([ f , g ] ● in₂) a x ≡ g a x
commute-in₂-arg {[]} _ _ = refl
commute-in₂-arg {tt ∷ Γ₁} {Γ₂} {Δ} {f} {g} a x =
  begin
    ([ f , g ] ● in₂ {{tt ∷ Γ₁}} ) a x
  ≡⟨ refl ⟩
    [ f , g ] a ((succ ● in₂) a x)
  ≡⟨ refl ⟩
    [ f a , g a ]′ (split {tt ∷ Γ₁} (succ a (in₂ a x)))
  ≡⟨ cong (λ u → [ f a , g a ]′ u) {x = split {tt ∷ Γ₁} (succ a (in₂ a x))} refl ⟩
    [ f a , g a ]′ ((Sum.map (succ a) id) (split {Γ₁} (in₂ a x)))
  ≡⟨ cong (λ u → [ f a , g a ]′ (Sum.map (succ a) id u)) (split-lemma₂ Γ₁ Γ₂ x) ⟩
    [ f a , g a ]′ ((Sum.map (succ a) id) (inj₂ x))
  ≡⟨ copair-sum-map-merge {f₁ = succ {Γ₁} a} {f₂ = id} {g₁ = f a} {g₂ = g a} (inj₂ x) ⟩
    [ (f ● succ) a , (g ● ctx-id) a ]′ (inj₂ x)
  ≡⟨ copair-elimʳ {f = (f ● succ) a} {g = (g ● ctx-id) a} x ⟩
    g a x
  ∎

commute-in₂ : (Γ₁ : Ctx) → (Γ₂ : Ctx) → {Δ : Ctx} {f : Γ₁ ▹ Δ} {g : Γ₂ ▹ Δ}
              → ([ f , g ] ● in₂) ≡C g
commute-in₂ Γ₁ Γ₂ {Δ} {f} {g} =
  record { ≡C-proof = λ {a} {x} → commute-in₂-arg {f = f} {g} a x }

open import Categories.Object.Coproduct ctx-cat

ctx-coproduct : ∀{Γ₁ Γ₂ : Ctx} → Coproduct Γ₁ Γ₂
ctx-coproduct {Γ₁} {Γ₂} = record
                  { A+B = Γ₁ ⊕ Γ₂
                  ; i₁ = in₁
                  ; i₂ = in₂
                  ; [_,_] = [_,_]
                  ; commute₁ = commute-in₁ Γ₁ Γ₂
                  ; commute₂ = commute-in₂ Γ₁ Γ₂
                  ; universal = ⊕-is-coprod₁
                  }

open import Categories.Object.BinaryCoproducts ctx-cat

ctx-bin-coproducts : BinaryCoproducts
ctx-bin-coproducts = record { coproduct = ctx-coproduct }

open BinaryCoproducts ctx-bin-coproducts

-}


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

open import Agda.Builtin.Bool
open import Data.Maybe.Base using (just; nothing)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary
open import Data.Integer.Base
open import Data.Integer.Properties using (+-*-commutativeRing)

open import Tactic.RingSolver.Core.AlmostCommutativeRing using (fromCommutativeRing)
open import Tactic.RingSolver.NonReflective (fromCommutativeRing +-*-commutativeRing λ { +0 -> just refl; _ -> nothing}) public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Bundles of parameters for passing to the Ring Solver
------------------------------------------------------------------------

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

-- This module packages up all the stuff that's passed to the other
-- modules in a convenient form.

module Tactic.RingSolver.Core.Polynomial.Parameters where

open import Algebra.Bundles using (RawRing)
open import Data.Bool.Base using (Bool; T)
open import Function
open import Level
open import Relation.Unary
open import Tactic.RingSolver.Core.AlmostCommutativeRing

-- This record stores all the stuff we need for the coefficients:
--
--  * A raw ring
--  * A (decidable) predicate on "zeroeness"
--
-- It's used for defining the operations on the Horner normal form.
record RawCoeff ℓ₁ ℓ₂ : Set (suc (ℓ₁ ⊔ ℓ₂)) where
  field
    rawRing : RawRing ℓ₁ ℓ₂
    isZero  : RawRing.Carrier rawRing → Bool

  open RawRing rawRing public

-- This record stores the full information we need for converting
-- to the final ring.
record Homomorphism ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Set (suc (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄)) where
  field
    from : RawCoeff ℓ₁ ℓ₂
    to   : AlmostCommutativeRing ℓ₃ ℓ₄

  module Raw = RawCoeff from
  open AlmostCommutativeRing to public

  field
    morphism : Raw.rawRing -Raw-AlmostCommutative⟶ to
  open _-Raw-AlmostCommutative⟶_ morphism renaming (⟦_⟧ to ⟦_⟧ᵣ) public
  field
    Zero-C⟶Zero-R : ∀ x → T (Raw.isZero x) → 0# ≈  ⟦ x ⟧ᵣ


open import Poly
open import Function
open import Data.Nat
open import Data.Empty
open import Data.Unit
open import Data.Product as Prod
open import Data.Sum
open import Relation.Binary.PropositionalEquality

data ℕ∞ : Set where
  fin : ℕ → ℕ∞
  ω : ℕ∞

data _<'_ : ℕ∞ → ℕ∞ → Set where
  ltSuc : (n : ℕ) → fin n <' fin (suc n)
  ltω : (n : ℕ) → fin n <' ω

z : ⊤ → ℕ∞
z _ = fin 0

suc' : ℕ∞ → ℕ∞
suc' (fin x) = fin (suc x)
suc' ω = ω

F : (ℕ∞ → Set) → (ℕ∞ → Set)
F X n = (n ≡ z tt → ⊥)
        × ((k : ℕ∞) → n ≡ suc' k → X k)
        × ((n ≡ ω) → (∃ λ k → k <' ω × X k))

A = ℕ∞ × (⊥ ⊎ ⊤ ⊎ (∃ λ k → k <' ω))
B = ⊥ ⊎ ℕ∞ ⊎ (∃ λ k → k <' ω)

f : B → A
f (inj₁ x) = (z tt , inj₁ x)
f (inj₂ (inj₁ x)) = (suc' x , inj₂ (inj₁ tt))
f (inj₂ (inj₂ y)) = (ω , inj₂ (inj₂ y))

s : B → ℕ∞
s (inj₁ x) = ⊥-elim x
s (inj₂ (inj₁ x)) = x
s (inj₂ (inj₂ y)) = proj₁ y

t : A → ℕ∞
t = proj₁

P : DPoly
P = dpoly A t B f s

-- Claim : F ≅ ⟦ P ⟧

F→P : ∀{X} n → F X n → T P X n
F→P {X} (fin zero) v = ins a (abs'' a u)
  where
    a = (z tt , inj₁ (proj₁ v refl))
    u : (b : B) → f b ≡ a → X (s b)
    u b p with b
    u b refl | inj₁ _ = ⊥-elim (proj₁ v refl)
    u b ()   | inj₂ (inj₁ x)
    u b ()   | inj₂ (inj₂ y)

F→P {X} (fin (suc k)) (_ , v , _) = ins a (abs'' a u)
  where
    a = (fin (suc k) , inj₂ (inj₁ tt))
    u : (b : B) → f b ≡ a → X (s b)
    u b p with b
    u b ()   | inj₁ x
    u b refl | inj₂ (inj₁ (fin .k)) = v (fin k) refl
    u b ()   | inj₂ (inj₁ ω)
    u b ()   | inj₂ (inj₂ y)

F→P {X} ω (_ , _ , v) = ins a (abs'' a u)
  where
    i : ∃ λ k → k <' ω
    i = Prod.map id proj₁ (v refl)

    a = (ω , inj₂ (inj₂ i))

    u : (b : B) → f b ≡ a → X (s b)
    u b p with b
    u b ()   | inj₁ x
    u b ()   | inj₂ (inj₁ x)
    u b refl | inj₂ (inj₂ _) = proj₂ (proj₂ (v refl))

P→F : ∀{X} n → T P X n → F X n
P→F (fin zero) (ins (.(fin 0) , v) x) = ? -- ({!!} , {!!})
P→F (fin (suc n)) v = {!!}
P→F ω v = {!!}


-- Moved from the successfull test-suite. See Issue 1481.

module tests.Nat where

data Nat : Set where
  Z : Nat
  S : Nat → Nat

{-# BUILTIN NATURAL Nat #-}

_+_ : Nat → Nat → Nat
Z   + m = m
S n + m = S (n + m)

{-# BUILTIN NATPLUS _+_ #-}

_*_ : Nat → Nat → Nat
Z   * m = Z
S n * m = m + (n * m)

{-# BUILTIN NATTIMES _*_ #-}

data Unit : Set where
  unit : Unit

postulate
  IO          : Set → Set
  String      : Set
  natToString : Nat → String
  putStr      : String → IO Unit

printNat : Nat → IO Unit
printNat n = putStr (natToString n)

{-# COMPILED_TYPE IO IO #-}

{-# COMPILED_EPIC natToString (n : Any) -> String = bigToStr(n) #-}

{-# COMPILED_EPIC putStr (a : String, u : Unit) ->
                  Unit = foreign Int "wputStr" (a : String); primUnit #-}

main : IO Unit
main = printNat (7 * 191)

-- should print 1337


module UniDB.Subst.Sum where

open import UniDB.Subst.Core
open import UniDB.Morph.Sum

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

module _
  (T : STX) {{vrT : Vr T}} {{wkT : Wk T}}
  (X : STX) {{wkX : Wk X}} {{apTX : Ap T X}} {{apRelTX : ApRel T X}}
  (Ξ : MOR) {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}}
  (Ζ : MOR) {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}}
  where

  ap-inl : {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (x : X γ₁) →
    ap {T} {X} {Sum Ξ Ζ} (inl ξ) x ≡ ap {T} ξ x
  ap-inl ξ = ap-rel≅ {T} (≃-to-≅` lem)
    where
      lem : (δ : Dom) → [ T ] inl {Ξ} {Ζ} ξ ↑ δ ≃ ξ ↑ δ
      lk≃ (lem δ) i rewrite inl-↑ Ξ Ζ ξ δ = refl

  ap-inr : {γ₁ γ₂ : Dom} (ζ : Ζ γ₁ γ₂) (x : X γ₁) →
    ap {T} {X} {Sum Ξ Ζ} (inr ζ) x ≡ ap {T} ζ x
  ap-inr ζ = ap-rel≅ {T} (≃-to-≅` lem)
    where
      lem : (δ : Dom) → [ T ] inr {Ξ} {Ζ} ζ ↑ δ ≃ ζ ↑ δ
      lk≃ (lem δ) i rewrite inr-↑ Ξ Ζ ζ δ = refl

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


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

module Data.Real.CReal where

import Prelude
import Data.Bool
import Data.String
import Data.Real.Complete
import Data.Real.Base
import Data.Nat
import Data.Integer
import Data.Rational as Rational
import Data.Interval
import Data.Real.Gauge
import Data.Show
import Data.List
import Data.Tuple

open Prelude
open Data.Real.Base
open Data.Real.Complete
open Data.Integer using (Int; pos) renaming (_-_ to _-i_; _<_ to _<i_)
open Rational hiding (fromInt)
open Data.Bool
open Data.String
open Data.Interval
open Data.Real.Gauge
open Data.Nat using (Nat)
open Data.Tuple

data CReal : Set where
  cReal : Complete Base -> CReal

approx : CReal -> Complete Base
approx (cReal f) ε = f ε

inject : Base -> CReal
inject x = cReal (unit x)

data BoundedCReal : Set where
  _∈_ : CReal -> Interval Base -> BoundedCReal

around : CReal -> Int
around (cReal f) = round (f (pos 1 % pos 2))

integerInterval : CReal -> Interval Base
integerInterval f = [ i - fromNat 1 ▻ i + fromNat 1 ]
  where
    i = Rational.fromInt (around f)

compact : CReal -> BoundedCReal
compact x = x ∈ integerInterval x

choke : BoundedCReal -> CReal
choke (cReal x ∈ [ lb ▻ ub ]) = cReal f
  where
    f : Complete Base
    f ε = ! y < lb => lb
          ! ub < y => ub
          ! otherwise y
      where
        y = x ε

compress : Complete Base -> Complete Base
compress x ε = approxBase (x ε2) ε2
  where
    ε2 = ε / fromNat 2

mapCR : (Base ==> Base) -> CReal -> CReal
mapCR f (cReal x) = cReal $ mapC f (compress x)

mapCR2 : (Base ==> Base ==> Base) -> CReal -> CReal -> CReal
mapCR2 f (cReal x) (cReal y) = cReal $ mapC2 f (compress x) (compress y)

bindR : (Base ==> Complete Base) -> CReal -> CReal
bindR f (cReal x) = cReal $ bind f (compress x)

approxRange : CReal -> Gauge -> Interval Base
approxRange x ε = [ r - ε ▻ r + ε ]
  where
    r = approx x ε

-- non-terminates for 0
proveNonZeroFrom : Gauge -> CReal -> Base
proveNonZeroFrom g r =
  ! high < fromNat 0 => high
  ! fromNat 0 < low  => low
  ! otherwise           proveNonZeroFrom (g / fromNat 2) r
  where
    i    = approxRange r g
    low  = lowerBound i
    high = upperBound i

proveNonZero : CReal -> Base
proveNonZero = proveNonZeroFrom (fromNat 1)

-- Negation

negateCts : Base ==> Base
negateCts = uniformCts id -_

realNegate : CReal -> CReal
realNegate = mapCR negateCts

-- Addition

plusBaseCts : Base -> Base ==> Base
plusBaseCts a = uniformCts id (_+_ a)

plusCts : Base ==> Base ==> Base
plusCts = uniformCts id plusBaseCts

realPlus : CReal -> CReal -> CReal
realPlus = mapCR2 plusCts

realTranslate : Base -> CReal -> CReal
realTranslate a = mapCR (plusBaseCts a)

-- Multiplication

multBaseCts : Base -> Base ==> Base
multBaseCts (pos 0 %' _) = constCts (fromNat 0)
multBaseCts a            = uniformCts μ (_*_ a)
  where
    μ = \ε -> ε / ! a !

-- First argument must be ≠ 0
multCts : Base -> Base ==> Base ==> Base
multCts maxy = uniformCts μ multBaseCts
  where
    μ = \ε -> ε / maxy

realScale : Base -> CReal -> CReal
realScale a = mapCR (multBaseCts a)

bound : Interval Base -> Base
bound [ lb ▻ ub ] = max ub (- lb)

realMultBound : BoundedCReal -> CReal -> CReal
realMultBound (x ∈ i) y = mapCR2 (multCts b) y (choke (x ∈ i))
  where
    b = bound i

realMult : CReal -> CReal -> CReal
realMult x y = realMultBound (compact x) y

-- Absolute value
absCts : Base ==> Base
absCts = uniformCts id !_!

realAbs : CReal -> CReal
realAbs = mapCR absCts

fromInt : Int -> CReal
fromInt x = inject (Rational.fromInt x)

fromRational : Rational -> CReal
fromRational = inject

-- Reciprocal

recipCts : Base -> Base ==> Base
recipCts nz = uniformCts μ f
  where
    f : Base -> Base
    f a = ! fromNat 0 ≤ nz => recip (max nz a)
          ! otherwise         recip (min a nz)

    μ = \ε -> ε * nz ^ pos 2

realRecipWitness : Base -> CReal -> CReal
realRecipWitness nz = mapCR (recipCts nz)

realRecip : CReal -> CReal
realRecip x = realRecipWitness (proveNonZero x) x

-- Exponentiation

intPowerCts : Gauge -> Int -> Base ==> Base
intPowerCts _ (pos 0) = constCts (fromNat 1)
intPowerCts maxx n = uniformCts μ (flip _^_ n)
  where
    μ = \ε -> ε / (Rational.fromInt n * maxx ^ (n -i pos 1))

realPowerIntBound : BoundedCReal -> Int -> CReal
realPowerIntBound (x ∈ i) n = mapCR (intPowerCts b n) (choke (x ∈ i))
  where
    b = bound i

realPowerInt : CReal -> Int -> CReal
realPowerInt = realPowerIntBound ∘ compact

showReal : Nat -> CReal -> String
showReal n x =
  ! len ≤' n => sign ++ "0." ++ fromList (replicate (n -' len) '0') ++ s
  ! otherwise   sign ++ i ++ "." ++ f
  where
    open Data.Nat using () renaming
              ( _^_ to _^'_
              ; div to div'; mod to mod'
              ; _==_ to _=='_; _≤_ to _≤'_
              ; _-_ to _-'_
              )
    open Data.Show
    open Data.List hiding (_++_)
    open Data.Integer using () renaming (-_ to -i_)

    k = 10 ^' n
    m = around $ realScale (fromNat k) x
    m' = if m <i pos 0 then -i m else m
    s = showInt m'

    sign = if m <i pos 0 then "-" else ""

    len = length (toList s)

    p = splitAt (len -' n) $ toList s
    i = fromList $ fst p
    f = fromList $ snd p


data Bool : Set where
  true  : Bool
  false : Bool

data Nat : Set where
  suc : Nat -> Nat
  zer : Nat
{-# BUILTIN NATURAL Nat #-}

data Vec (A : Set) : (n : Nat) -> Set where
  _,_ : ∀ {n} -> A -> Vec A n -> Vec A (suc n)
  []  : Vec A zer

data Sig (A : Set) (B : A → Set) : Set where
  sig : (a : A) → B a → Sig A B

Exists : ∀ {A : Set} → (A → Set) → Set
Exists = Sig _

Pair : ∀ (A B : Set) → Set
Pair A B = Sig A (λ x → B)

-- variable
  -- m n : Nat
  -- b : Bool
  -- Γ Δ Ξ T I O : Vec Bool n

-- A Linear term has an output and an output usage annotation
-- For each variable (i.e. index in the Vec):
--  * true: available
--  * false: already consumed
Linear : Set₁
Linear = ∀ n (Γa Γb : Vec Bool n) → Set

data Var : Linear where
  z : ∀ {n Γ} → Var (suc n) (true , Γ) (false , Γ)
  s : ∀ {n Γa Γb x} → Var n Γa Γb → Var (suc n) (x , Γa) (x , Γb)

data Lam : Linear where
  var : ∀ {n Γa Γb} → Var n Γa Γb → Lam n Γa Γb
  app : ∀ {n Γa Γb Γc} → Lam n Γa Γb → Lam n Γb Γc → Lam n Γa Γc
  lam : ∀ {n Γa Γb} → Lam (suc n) (true , Γa) (false , Γb) → Lam n Γa Γb

-- Γi Γo: input and output usage of the env
-- Γt: target usage covered by the content of the env
data Env : ∀ n m → (Γi Γo : Vec Bool n) (Γt : Vec Bool m) → Set where
  -- empty environment
  []  : ∀ {n Γi Γo} → Env n zer Γi Γo []
  -- 0th variable is available so we have a value for it
  _,_ : ∀ {n m Γi Γm Γo Γt} → Lam n Γi Γm → Env n m Γm Γo Γt → Env n (suc m) Γi Γo (true , Γt)
  -- -- 0th variable has already been consumed: we don't have a term for it anymore
  ─,_ : ∀ {n m Γi Γo Γt} → Env n m Γi Γo Γt → Env n (suc m) Γi Γo (false , Γt)
  -- -- When we go under binders, we need to be able to extend the input/output
  -- -- context to cope with the extended context
  [v]∷_ : ∀ {n m Γi Γo Γt} → Env n m Γi Γo Γt → Env (suc n) (suc m) (true , Γi)  (false , Γo) (false , Γt)
  ]v[∷_ : ∀ {n m Γi Γo Γt} → Env n m Γi Γo Γt → Env (suc n) (suc m) (false , Γi) (false , Γo) (false , Γt)

-- Input/output usage pairs that have the same consumption pattern
data Equiv : ∀ n → (Γ0i Γ0o Γ1i Γ1o : Vec Bool n) → Set where
  -- Empty pairs have the same consumption pattern
  empty   : Equiv zer [] [] [] []
  -- If a resource is untouched in one side, then it must be untouched on the other
  skip    : ∀ {n} Γ0i Γ0o Γ1i Γ1o A B → Equiv (suc n) (A , Γ0i) (A , Γ0o) (B , Γ1i) (B , Γ1o)
  -- If a resource is used in one side, then it must be used on the other
  consume : ∀ {n} Γ0i Γ0o Γ1i Γ1o → Equiv (suc n) (true , Γ0i) (false , Γ0o) (true , Γ1i) (false , Γ1o)

-- R: target of the substitution
-- V: output (e.g. substituting for vars yields terms)
Subst : (R : Linear) (V : Linear) → Set
Subst R V = ∀ {n m Γi Γo I O}
          -- environment targetting I
          → Env n m Γi Γo I
          -- R consuming resources in I, returning O leftovers
          → R m I O
          -- the result is a usage annotation, a value V consuming in the input, returning M leftovers, an environment of leftovers for whatever is still true in O
          → Exists (λ M → Pair (V n Γi M) (Env n m M Γo O))

-- substVar : Subst Var Lam
-- substVar (t ∷ ρ)  z     = -, t     , ─∷ ρ
-- substVar (x ∷ ρ)  (s v) = {!!}
-- substVar (─∷ ρ)   (s v) = {!!}
-- substVar ([v]∷ ρ) (s v) = {!!}
-- substVar (]v[∷ ρ) (s v) = {!!}


module Reflexivity where
import PolyDepPrelude
open PolyDepPrelude using(Bool; True)

-- Local reflexivity

lref : {X : Set} -> (X -> X -> Bool) -> X -> Set
lref _R_ = \x -> True (x R x)

-- Reflexive = locally reflexive everywhere

data Refl {X : Set} (r : X -> X -> Bool) : Set where
  refl : ((x : X) -> lref r x) -> Refl r


module Everything where

import Data.BitVector
import Data.BitVector.ContainmentOrder
import Data.BitVector.NumericOrder
import Data.BitVector.Peano
import Data.BitVector.Properties
import Data.BitVector.Properties.LatticeProperties


{-# OPTIONS --without-K #-}
module K where

open import NTypes.Contractible
open import PathOperations
open import PathStructure.Sigma
open import Types

-- Not strictly related to the lectures.
--
-- Here we show that the various forms of extending
-- pure ITT to propositionally extensional TT are
-- (logically) equivalent.

-- The most general form of axiom K.
K-gen : ∀ a p → Set _
K-gen a p = {A : Set a} (x : A) (P : x ≡ x → Set p) (h : x ≡ x) →
  P refl → P h

-- Specialized form of axiom K.
K : ∀ a → Set _
K a = {A : Set a} (x : A) (p : x ≡ x) → p ≡ refl

uip : ∀ a → Set _
uip a = {A : Set a} (x y : A) (p q : x ≡ y) → p ≡ q

π₂-Id : ∀ a b → Set _
π₂-Id a b = {A : Set a} {B : A → Set b} (a : A) (b₁ b₂ : B a) →
  Id (Σ A B) (a , b₁) (a , b₂) → b₁ ≡ b₂

-- Relation between K and its specialized version.
K-gen→K : ∀ {a} → K-gen a a → K a
K-gen→K K x p = K x (λ p → p ≡ refl) p refl

K→K-gen : ∀ {a p} → K a → K-gen a p
K→K-gen K x P h p = tr P (K x h ⁻¹) p

-- Relation between K and UIP.
K→uip : ∀ {a} → K a → uip a
K→uip K x y p q = J (λ _ _ p → ∀ q → q ≡ p) K _ _ q p

uip→K : ∀ {a} → uip a → K a
uip→K uip x p = uip x x p refl

-- Relation between K and π₂-Id.
K→π₂-Id : ∀ {a b} → K a → π₂-Id a b
K→π₂-Id K {B = B} _ b₁ b₂ p = tr
  (λ z → tr B z b₁ ≡ b₂)
  (K _ (π₁ (split-path p)))
  (π₂ (split-path p))

π₂-Id→K : ∀ {a} → π₂-Id a a → K a
π₂-Id→K πId x p =
  πId x p refl (π₂ (pp-space-contr x) (x , p) ⁻¹)


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

open import Cubical.Foundations.Prelude

open import Cubical.Data.FinData
open import Cubical.Data.Nat using (ℕ)
open import Cubical.Data.Nat.Order using (zero-≤)
open import Cubical.Data.Vec.Base
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.Ring
open import Cubical.Algebra.RingSolver.RawAlgebra renaming (⟨_⟩ to ⟨_⟩ᵣ)
open import Cubical.Algebra.RingSolver.AlgebraExpression public
open import Cubical.Algebra.RingSolver.CommRingHornerForms
open import Cubical.Algebra.RingSolver.CommRingEvalHom

private
  variable
    ℓ : Level

module EqualityToNormalform (R : CommRing {ℓ}) where
  νR = CommRing→RawℤAlgebra R
  open CommRingStr (snd R)
  open Theory (CommRing→Ring R)
  open Eval ℤAsRawRing νR
  open IteratedHornerOperations νR
  open HomomorphismProperties R

  ℤExpr : (n : ℕ) → Type _
  ℤExpr = Expr ℤAsRawRing (fst R)

  normalize : (n : ℕ) → ℤExpr n → IteratedHornerForms νR n
  normalize n (K r) = Constant n νR r
  normalize n (∣ k) = Variable n νR k
  normalize n (x +' y) =
    (normalize n x) +ₕ (normalize n y)
  normalize n (x ·' y) =
    (normalize n x) ·ₕ (normalize n y)
  normalize n (-' x) =  -ₕ (normalize n x)

  isEqualToNormalform :
            (n : ℕ)
            (e : ℤExpr n) (xs : Vec (fst R) n)
          → eval n (normalize n e) xs ≡ ⟦ e ⟧ xs
  isEqualToNormalform ℕ.zero (K r) [] = refl
  isEqualToNormalform (ℕ.suc n) (K r) (x ∷ xs) =
     eval (ℕ.suc n) (Constant (ℕ.suc n) νR r) (x ∷ xs)           ≡⟨ refl ⟩
     eval (ℕ.suc n) (0ₕ ·X+ Constant n νR r) (x ∷ xs)             ≡⟨ combineCasesEval 0ₕ (Constant n νR r) x xs ⟩
     eval (ℕ.suc n) 0ₕ (x ∷ xs) · x + eval n (Constant n νR r) xs
    ≡⟨ cong (λ u → u · x + eval n (Constant n νR r) xs) (Eval0H _ (x ∷ xs)) ⟩
     0r · x + eval n (Constant n νR r) xs
    ≡⟨ cong (λ u → u + eval n (Constant n νR r) xs) (0LeftAnnihilates _) ⟩
     0r + eval n (Constant n νR r) xs                             ≡⟨ +Lid _ ⟩
     eval n (Constant n νR r) xs                                  ≡⟨ isEqualToNormalform n (K r) xs ⟩
     _ ∎

  isEqualToNormalform (ℕ.suc n) (∣ zero) (x ∷ xs) =
    eval (ℕ.suc n) (1ₕ ·X+ 0ₕ) (x ∷ xs)           ≡⟨ refl ⟩
    eval (ℕ.suc n) 1ₕ (x ∷ xs) · x + eval n 0ₕ xs ≡⟨ cong (λ u → u · x + eval n 0ₕ xs)
                                                          (Eval1ₕ _ (x ∷ xs)) ⟩
    1r · x + eval n 0ₕ xs                         ≡⟨ cong (λ u → 1r · x + u ) (Eval0H _ xs) ⟩
    1r · x + 0r                                   ≡⟨ +Rid _ ⟩
    1r · x                                        ≡⟨ ·Lid _ ⟩
    x ∎
  isEqualToNormalform (ℕ.suc n) (∣ (suc k)) (x ∷ xs) =
      eval (ℕ.suc n) (0ₕ ·X+ Variable n νR k) (x ∷ xs)             ≡⟨ combineCasesEval 0ₕ (Variable n νR k) x xs ⟩
      eval (ℕ.suc n) 0ₕ (x ∷ xs) · x + eval n (Variable n νR k) xs
    ≡⟨ cong (λ u → u · x + eval n (Variable n νR k) xs) (Eval0H _ (x ∷ xs)) ⟩
      0r · x + eval n (Variable n νR k) xs
    ≡⟨ cong (λ u → u + eval n (Variable n νR k) xs) (0LeftAnnihilates _) ⟩
      0r + eval n (Variable n νR k) xs                             ≡⟨ +Lid _ ⟩
      eval n (Variable n νR k) xs
    ≡⟨ isEqualToNormalform n (∣ k) xs ⟩
      ⟦ ∣ (suc k) ⟧ (x ∷ xs) ∎

  isEqualToNormalform ℕ.zero (-' e) [] =
    eval ℕ.zero (-ₕ (normalize ℕ.zero e)) [] ≡⟨ -EvalDist ℕ.zero
                                                                  (normalize ℕ.zero e)
                                                                  [] ⟩
    - eval ℕ.zero (normalize ℕ.zero e) []    ≡⟨ cong -_
                                                          (isEqualToNormalform
                                                            ℕ.zero e [] ) ⟩
    - ⟦ e ⟧ [] ∎
  isEqualToNormalform (ℕ.suc n) (-' e) (x ∷ xs) =
    eval (ℕ.suc n) (-ₕ (normalize (ℕ.suc n) e)) (x ∷ xs) ≡⟨ -EvalDist (ℕ.suc n)
                                                                  (normalize
                                                                    (ℕ.suc n) e)
                                                                  (x ∷ xs) ⟩
    - eval (ℕ.suc n) (normalize (ℕ.suc n) e) (x ∷ xs)    ≡⟨ cong -_
                                                          (isEqualToNormalform
                                                            (ℕ.suc n) e (x ∷ xs) ) ⟩
    - ⟦ e ⟧ (x ∷ xs) ∎

  isEqualToNormalform ℕ.zero (e +' e₁) [] =
        eval ℕ.zero (normalize ℕ.zero e +ₕ normalize ℕ.zero e₁) []
      ≡⟨ +Homeval ℕ.zero (normalize ℕ.zero e) _ [] ⟩
        eval ℕ.zero (normalize ℕ.zero e) []
        + eval ℕ.zero (normalize ℕ.zero e₁) []
      ≡⟨ cong (λ u → u + eval ℕ.zero (normalize ℕ.zero e₁) [])
              (isEqualToNormalform ℕ.zero e []) ⟩
        ⟦ e ⟧ []
        + eval ℕ.zero (normalize ℕ.zero e₁) []
      ≡⟨ cong (λ u → ⟦ e ⟧ [] + u) (isEqualToNormalform ℕ.zero e₁ []) ⟩
        ⟦ e ⟧ [] + ⟦ e₁ ⟧ [] ∎
  isEqualToNormalform (ℕ.suc n) (e +' e₁) (x ∷ xs) =
        eval (ℕ.suc n) (normalize (ℕ.suc n) e
                         +ₕ normalize (ℕ.suc n) e₁) (x ∷ xs)
      ≡⟨ +Homeval (ℕ.suc n) (normalize (ℕ.suc n) e) _ (x ∷ xs) ⟩
        eval (ℕ.suc n) (normalize (ℕ.suc n) e) (x ∷ xs)
        + eval (ℕ.suc n) (normalize (ℕ.suc n) e₁) (x ∷ xs)
      ≡⟨ cong (λ u → u + eval (ℕ.suc n) (normalize (ℕ.suc n) e₁) (x ∷ xs))
              (isEqualToNormalform (ℕ.suc n) e (x ∷ xs)) ⟩
        ⟦ e ⟧ (x ∷ xs)
        + eval (ℕ.suc n) (normalize (ℕ.suc n) e₁) (x ∷ xs)
      ≡⟨ cong (λ u → ⟦ e ⟧ (x ∷ xs) + u)
              (isEqualToNormalform (ℕ.suc n) e₁ (x ∷ xs)) ⟩
        ⟦ e ⟧ (x ∷ xs) + ⟦ e₁ ⟧ (x ∷ xs) ∎

  isEqualToNormalform ℕ.zero (e ·' e₁) [] =
        eval ℕ.zero (normalize ℕ.zero e ·ₕ normalize ℕ.zero e₁) []
      ≡⟨ ·Homeval ℕ.zero (normalize ℕ.zero e) _ [] ⟩
        eval ℕ.zero (normalize ℕ.zero e) []
        · eval ℕ.zero (normalize ℕ.zero e₁) []
      ≡⟨ cong (λ u → u · eval ℕ.zero (normalize ℕ.zero e₁) [])
              (isEqualToNormalform ℕ.zero e []) ⟩
        ⟦ e ⟧ []
        · eval ℕ.zero (normalize ℕ.zero e₁) []
      ≡⟨ cong (λ u → ⟦ e ⟧ [] · u) (isEqualToNormalform ℕ.zero e₁ []) ⟩
        ⟦ e ⟧ [] · ⟦ e₁ ⟧ [] ∎

  isEqualToNormalform (ℕ.suc n) (e ·' e₁) (x ∷ xs) =
        eval (ℕ.suc n) (normalize (ℕ.suc n) e
                         ·ₕ normalize (ℕ.suc n) e₁) (x ∷ xs)
      ≡⟨ ·Homeval (ℕ.suc n) (normalize (ℕ.suc n) e) _ (x ∷ xs) ⟩
        eval (ℕ.suc n) (normalize (ℕ.suc n) e) (x ∷ xs)
        · eval (ℕ.suc n) (normalize (ℕ.suc n) e₁) (x ∷ xs)
      ≡⟨ cong (λ u → u · eval (ℕ.suc n) (normalize (ℕ.suc n) e₁) (x ∷ xs))
              (isEqualToNormalform (ℕ.suc n) e (x ∷ xs)) ⟩
        ⟦ e ⟧ (x ∷ xs)
        · eval (ℕ.suc n) (normalize (ℕ.suc n) e₁) (x ∷ xs)
      ≡⟨ cong (λ u → ⟦ e ⟧ (x ∷ xs) · u)
              (isEqualToNormalform (ℕ.suc n) e₁ (x ∷ xs)) ⟩
        ⟦ e ⟧ (x ∷ xs) · ⟦ e₁ ⟧ (x ∷ xs) ∎

  solve :
    {n : ℕ} (e₁ e₂ : ℤExpr n) (xs : Vec (fst R) n)
    (p : eval n (normalize n e₁) xs ≡ eval n (normalize n e₂) xs)
    → ⟦ e₁ ⟧ xs ≡ ⟦ e₂ ⟧ xs
  solve e₁ e₂ xs p =
    ⟦ e₁ ⟧ xs                  ≡⟨ sym (isEqualToNormalform _ e₁ xs) ⟩
    eval _ (normalize _ e₁) xs ≡⟨ p ⟩
    eval _ (normalize _ e₂) xs ≡⟨ isEqualToNormalform _ e₂ xs ⟩
    ⟦ e₂ ⟧ xs ∎

ℤExpr : (R : CommRing {ℓ}) (n : ℕ)
        → _
ℤExpr R n = EqualityToNormalform.ℤExpr R n

solve : (R : CommRing {ℓ})
        {n : ℕ} (e₁ e₂ : ℤExpr R n) (xs : Vec (fst R) n)
        (p : eval n (EqualityToNormalform.normalize R n e₁) xs ≡ eval n (EqualityToNormalform.normalize R n e₂) xs)
        → _
solve R = EqualityToNormalform.solve R

module VarNames3 (R : CommRing {ℓ}) where
  X1 : ℤExpr R 3
  X1 = ∣ Fin.zero

  X2 : ℤExpr R 3
  X2 = ∣ (suc Fin.zero)

  X3 : ℤExpr R 3
  X3 = ∣ (suc (suc Fin.zero))

module VarNames4 (R : CommRing {ℓ}) where
  X1 : ℤExpr R 4
  X1 = ∣ Fin.zero

  X2 : ℤExpr R 4
  X2 = ∣ (suc Fin.zero)

  X3 : ℤExpr R 4
  X3 = ∣ (suc (suc Fin.zero))

  X4 : ℤExpr R 4
  X4 = ∣ (suc (suc (suc Fin.zero)))

module VarNames5 (R : CommRing {ℓ}) where
  X1 : ℤExpr R 5
  X1 = ∣ Fin.zero

  X2 : ℤExpr R 5
  X2 = ∣ (suc Fin.zero)

  X3 : ℤExpr R 5
  X3 = ∣ (suc (suc Fin.zero))

  X4 : ℤExpr R 5
  X4 = ∣ (suc (suc (suc Fin.zero)))

  X5 : ℤExpr R 5
  X5 = ∣ (suc (suc (suc (suc Fin.zero))))

module VarNames6 (R : CommRing {ℓ}) where
  X1 : ℤExpr R 6
  X1 = ∣ Fin.zero

  X2 : ℤExpr R 6
  X2 = ∣ (suc Fin.zero)

  X3 : ℤExpr R 6
  X3 = ∣ (suc (suc Fin.zero))

  X4 : ℤExpr R 6
  X4 = ∣ (suc (suc (suc Fin.zero)))

  X5 : ℤExpr R 6
  X5 = ∣ (suc (suc (suc (suc Fin.zero))))

  X6 : ℤExpr R 6
  X6 = ∣ (suc (suc (suc (suc (suc Fin.zero)))))


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

module Classifying where
  open import Basics

  open import Flat
  open import lib.types.Sigma
  open import lib.Equivalence2
  open import lib.types.Truncation

  BAut : ∀ {i} {X : Type i} (x : X) → Type i
  BAut {X = X} x = Σ X $ (\y → ∥ x == y ∥)

  ♭-commutes-with-BAut : {@♭ i : ULevel } (@♭ X : Type i) (@♭ x : X)
                         → (♭ (BAut x)) ≃ BAut (x ^♭)
  ♭-commutes-with-BAut X x =  ♭ (BAut x)
                           ≃⟨ ♭-commutes-with-Σ ⟩
                              Σ (♭ X) (\u → let♭ y ^♭:= u in♭ (♭ ∥ x == y ∥))
                           ≃⟨ Σ-emap-r lemma₂ ⟩
                               Σ (♭ X) (\u → let♭ y ^♭:= u in♭ ∥ ♭ (x == y) ∥)
                           ≃⟨ Σ-emap-r lemma₁ ⟩
                              BAut (x ^♭)
                           ≃∎
     where
       lemma₁ : (z : ♭ X) → (let♭ y ^♭:= z in♭ ∥ ♭ (x == y) ∥) ≃ ∥ (x ^♭) == z ∥
       lemma₁ (z ^♭) = Trunc-emap (♭-identity-eq x z)

       lemma₂ : (z : ♭ X) → (let♭ y ^♭:= z in♭ (♭ ∥ x == y ∥)) ≃ (let♭ y ^♭:= z in♭ ∥ ♭ (x == y) ∥)
       lemma₂ (z ^♭) = (♭-Trunc-eq (x == z)) ⁻¹

  _is-locally-crisply-discrete : {@♭ i : ULevel} (@♭ X : Type i) → Type i
  _is-locally-crisply-discrete X = (@♭ x y : X) → (x == y) is-discrete


------------------------------------------------------------------------
-- The Agda standard library
--
-- Predicate lifting for refinement types
------------------------------------------------------------------------

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

module Data.Refinement.Relation.Unary.All where

open import Level
open import Data.Refinement
open import Function.Base
open import Relation.Unary

private
  variable
    a b p q : Level
    A : Set a
    B : Set b

module _ {P : A → Set p} where

  All : (A → Set q) → Refinement A P → Set q
  All P (a , _) = P a


------------------------------------------------------------------------
-- The Agda standard library
--
-- Containers, based on the work of Abbott and others
------------------------------------------------------------------------

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

module Data.Container where

open import Level using (_⊔_)
open import Codata.M hiding (map)
open import Data.W
open import Size

------------------------------------------------------------------------
-- Re-exporting content to maintain backwards compatibility

open import Data.Container.Core public
open import Data.Container.Relation.Unary.Any
  using (◇) renaming (map to ◇-map) public
open import Data.Container.Relation.Unary.All
  using (□) renaming (map to □-map) public
open import Data.Container.Membership
  using (_∈_) public
open import Data.Container.Relation.Binary.Pointwise
  using () renaming (Pointwise to Eq) public
open import Data.Container.Relation.Binary.Pointwise.Properties
  using (refl; sym; trans) public
open import Data.Container.Relation.Binary.Equality.Setoid
  using (isEquivalence; setoid) public
open import Data.Container.Properties
  using () renaming (map-identity to identity; map-compose to composition) public
open import Data.Container.Related public

module Morphism where

  open import Data.Container.Morphism.Properties
    using (Natural; NT; natural; complete; id-correct; ∘-correct) public

  open import Data.Container.Morphism
    using (id; _∘_) public

-- The least and greatest fixpoints of a container.

μ : ∀ {s p} → Container s p → Set (s ⊔ p)
μ = W

ν : ∀ {s p} → Container s p → Set (s ⊔ p)
ν C = M C ∞


---------------------------------------------------------------------------
-- Normalization by Evaluation for Intuitionistic Propositional Logic
--
-- We employ a monadic interpreter for the soundness part,
-- and a special class of monads, called cover monads,
-- for the completeness part.
--
-- Normalization is completeness after soundness.
--
-- We give two instances of a cover monad: the free cover monad
-- and the continuation monad with normal forms as answer type.
---------------------------------------------------------------------------

{-# OPTIONS --postfix-projections #-}

open import Library

module NfModelMonad (Base : Set) where

import Formulas   ; open module Form = Formulas    Base
import Derivations; open module Der  = Derivations Base

---------------------------------------------------------------------------
-- Specification of a strong monad on presheaves.
-- Devoid of monad laws.

record Monad : Set₁ where

  -- Presheaf transformer.

  field
    C     : (P : Cxt → Set) (Γ : Cxt) → Set
    monC  : ∀{P} (monP : Mon P) → Mon (C P)

  -- Strong functor.

  field
    mapC' : ∀{P Q} → ⟨ P ⇒̂ Q ⊙ C P ⟩→̇ C Q

  -- Ordinary functor: an instance of mapC'.

  mapC : ∀{P Q} → (P →̇ Q) → (C P →̇ C Q)
  mapC f = mapC' λ τ → f

  -- Monad.

  field
    return : ∀{P} (monP : Mon P) → P →̇ C P
    joinC  : ∀{P} → C (C P) →̇ C P

  -- Kleisli extension.

  extC : ∀{P Q} → (P →̇ C Q) → C P →̇ C Q
  extC f = joinC ∘ mapC f

  -- Strong bind.

  bindC' : ∀{P Q} (monP : Mon P) → C P →̇ (P ⇒̂ C Q) ⇒̂ C Q
  bindC' monP c τ k = joinC (mapC' k (monC monP τ c))

---------------------------------------------------------------------------
-- A model of IPL parametrized by a strong monad.

module Soundness (monad : Monad) (open Monad monad) where

  -- The negative connectives True, ∧, and ⇒ are explained as usual by η-expansion
  -- and the meta-level connective.

  -- The positive connectives False and ∨ are inhabited by case trees.
  -- In case False, the tree has no leaves.
  -- In case A ∨ B, each leaf must be in the semantics of either A or B.

  T⟦_⟧ : (A : Form) (Γ : Cxt) → Set
  T⟦ Atom P ⟧   = C (Ne' (Atom P))
  T⟦ False  ⟧   = C λ Δ → ⊥
  T⟦ A ∨ B  ⟧   = C λ Δ → T⟦ A ⟧ Δ ⊎ T⟦ B ⟧ Δ
  T⟦ True   ⟧ Γ = ⊤
  T⟦ A ∧ B  ⟧ Γ = T⟦ A ⟧ Γ × T⟦ B ⟧ Γ
  T⟦ A ⇒ B  ⟧ Γ = ∀{Δ} (τ : Δ ≤ Γ) → T⟦ A ⟧ Δ → T⟦ B ⟧ Δ

  -- Monotonicity of the model is proven by induction on the proposition,
  -- using monotonicity of covers and the built-in monotonicity at implication.

  -- monT : ∀ A {Γ Δ} (τ : Δ ≤ Γ) → T⟦ A ⟧ Γ → T⟦ A ⟧ Δ

  monFalse : Mon (λ Γ → ⊥)
  monFalse τ ()

  mutual
    monT : ∀ A → Mon T⟦ A ⟧
    monT (Atom P)          = monC monNe
    monT False             = monC monFalse
    monT (A ∨ B)           = monC (monOr A B)
    monT True              = _
    monT (A ∧ B) τ (a , b) = monT A τ a , monT B τ b
    monT (A ⇒ B) τ f σ     = f (σ • τ)

    monOr : ∀ A B → Mon (λ Γ → T⟦ A ⟧ Γ ⊎ T⟦ B ⟧ Γ)
    monOr A B τ = map-⊎ (monT A τ) (monT B τ)

  returnOr : ∀ A B {Γ} → T⟦ A ⟧ Γ ⊎ T⟦ B ⟧ Γ → T⟦ A ∨ B ⟧ Γ
  returnOr A B = return (monOr A B)

  -- We can run computations of semantic values.
  -- This replaces the paste (weak sheaf condition) of Beth models.

  run : ∀ A → C T⟦ A ⟧ →̇ T⟦ A ⟧
  run (Atom P)      = joinC
  run False         = joinC
  run (A ∨ B)       = joinC
  run True          = _
  run (A ∧ B)       = < run A ∘ mapC proj₁ , run B ∘ mapC proj₂  >
  run (A ⇒ B) c τ a = run B $ mapC' (λ δ f → f id≤ (monT A δ a)) $ monC (monT (A ⇒ B)) τ c

  -- Remark: A variant of run in the style of bind.

  run' : ∀ {P} (monP : Mon P) A → C P →̇ (P ⇒̂ T⟦ A ⟧) ⇒̂ T⟦ A ⟧
  run' monP (Atom p)          = bindC' monP
  run' monP False             = bindC' monP
  run' monP (A ∨ B)           = bindC' monP
  run' monP True              = _
  run' monP (A ∧ B) c τ k     = run' monP A c τ (λ σ → proj₁ ∘ k σ) , run' monP B c τ (λ σ → proj₂ ∘ k σ)
  run' monP (A ⇒ B) c τ k σ a = run' monP B c (σ • τ) λ σ' p → k (σ' • σ) p id≤ (monT A σ' a)

  -- Fundamental theorem (interpretation / soundness).

  -- Pointwise extension of T⟦_⟧ to contexts.

  G⟦_⟧ : ∀ (Γ Δ : Cxt) → Set
  G⟦ ε     ⟧ Δ = ⊤
  G⟦ Γ ∙ A ⟧ Δ = G⟦ Γ ⟧ Δ × T⟦ A ⟧ Δ

  -- monG : ∀{Γ Δ Φ} (τ : Φ ≤ Δ) → G⟦ Γ ⟧ Δ → G⟦ Γ ⟧ Φ

  monG : ∀{Γ} → Mon G⟦ Γ ⟧
  monG {ε}     τ _       = _
  monG {Γ ∙ A} τ (γ , a) = monG τ γ , monT A τ a

  -- Variable case.

  lookup : ∀{Γ A} (x : Hyp A Γ) → G⟦ Γ ⟧ →̇ T⟦ A ⟧
  lookup top     = proj₂
  lookup (pop x) = lookup x ∘ proj₁

  -- A lemma for the orE case.

  orElim : ∀ A B C → ⟨ T⟦ A ∨ B ⟧ ⊙ T⟦ A ⇒ C ⟧ ⊙ T⟦ B ⇒ C ⟧ ⟩→̇ T⟦ C ⟧
  orElim A B C c g h = run C (mapC' (λ τ → [ g τ , h τ ]) c)

  orElim' : ∀ A B C → ⟨ T⟦ A ∨ B ⟧ ⊙ T⟦ A ⇒ C ⟧ ⊙ T⟦ B ⇒ C ⟧ ⟩→̇ T⟦ C ⟧
  orElim' A B C c g h = run' (monOr A B) C c id≤ λ τ → [ g τ , h τ ]

  -- A lemma for the falseE case.
  -- Casts an empty cover into any semantic value (by contradiction).

  falseElim : ∀ C → T⟦ False ⟧ →̇ T⟦ C ⟧
  falseElim C = run C ∘ mapC ⊥-elim

  -- The fundamental theorem

  eval :  ∀{A Γ} (t : Γ ⊢ A) → G⟦ Γ ⟧ →̇ T⟦ A ⟧
  eval (hyp x)           = lookup x
  eval (impI t)    γ τ a = eval t (monG τ γ , a)
  eval (impE t u)  γ     = eval t γ id≤ (eval u γ)
  eval (andI t u)  γ     = eval t γ , eval u γ
  eval (andE₁ t)         = proj₁ ∘ eval t
  eval (andE₂ t)         = proj₂ ∘ eval t
  eval (orI₁ {A} {B} t) γ = returnOr A B (inj₁ (eval t γ))
  eval (orI₂ {A} {B} t) γ = returnOr A B (inj₂ (eval t γ))
  eval (orE {A = A} {B} {C} t u v) γ = orElim A B C (eval t γ)
    (λ τ a → eval u (monG τ γ , a))
    (λ τ b → eval v (monG τ γ , b))
  eval {C} (falseE t) γ  = falseElim C (eval t γ)
  eval trueI       γ     = _

---------------------------------------------------------------------------
-- A strong monad with services to provide a cover.
-- Devoid of laws.

record CoverMonad : Set₁ where
  field
    monad : Monad
  open Monad monad public renaming (C to Cover)

  -- Services for case distinction.

  field
    falseC  : ∀{P} → Ne' False →̇ Cover P
    orC     : ∀{P Γ C D} (t : Ne Γ (C ∨ D))
                (c : Cover P (Γ ∙ C))
                (d : Cover P (Γ ∙ D)) → Cover P Γ

  -- Service for reification of into case trees.

  field
    runNf : ∀{A} → Cover (Nf' A) →̇ Nf' A

  -- A continuation version of runNf.

  runNf' : ∀ {A P} (monP : Mon P) → Cover P →̇ (P ⇒̂ Nf' A) ⇒̂ Nf' A
  runNf' monP c τ k = runNf (mapC' k (monC monP τ c))

---------------------------------------------------------------------------
-- Completeness of IPL via a cover monad.

module Completeness (covM : CoverMonad) (open CoverMonad covM) where
  open Soundness monad

  -- Reflection / reification, proven simultaneously by induction on the proposition.

  -- Reflection is η-expansion (and recursively reflection);
  -- at positive connections we build a case tree with a single scrutinee: the neutral
  -- we are reflecting.

  -- At implication, we need reification, which produces introductions
  -- and reifies the stored case trees.

  mutual

    fresh : ∀ {Γ} A → T⟦ A ⟧ (Γ ∙ A)
    fresh A = reflect A (hyp top)

    reflect : ∀ A → Ne' A →̇ T⟦ A ⟧
    reflect (Atom P) t     = return monNe t
    reflect False    t     = falseC t
    reflect (A ∨ B)  t     = orC t (returnOr A B (inj₁ (fresh A)))
                                   (returnOr A B (inj₂ (fresh B)))
    reflect True     t     = _
    reflect (A ∧ B)  t     = reflect A (andE₁ t) , reflect B (andE₂ t)
    reflect (A ⇒ B)  t τ a = reflect B (impE (monNe τ t) (reify A a))

    reify : ∀ A → T⟦ A ⟧ →̇ Nf' A
    reify (Atom P)        = runNf ∘ mapC ne
    reify False           = runNf ∘ mapC ⊥-elim
    reify (A ∨ B)         = runNf ∘ mapC [ orI₁ ∘ reify A , orI₂ ∘ reify B ]
    reify True _          = trueI
    reify (A ∧ B) (a , b) = andI (reify A a) (reify B b)
    reify (A ⇒ B) ⟦f⟧     = impI (reify B (⟦f⟧ (weak id≤) (fresh A)))

---------------------------------------------------------------------------
-- Normalization is completeness (reification) after soundness (evaluation)

module Normalization (covM : CoverMonad) (open CoverMonad covM) where
  open Soundness monad
  open Completeness covM

  -- Identity environment, constructed by reflection.

  freshG : ∀ Γ → G⟦ Γ ⟧ Γ
  freshG ε       = _
  freshG (Γ ∙ A) = monG (weak id≤) (freshG Γ) , fresh A

  -- A variant (no improvement).

  freshG' : ∀ Γ {Δ} (τ : Δ ≤ Γ) → G⟦ Γ ⟧ Δ
  freshG' ε       τ = _
  freshG' (Γ ∙ A) τ = freshG' Γ (τ • weak id≤) , monT A τ (fresh A)

  -- Normalization

  norm : ∀{A} → Tm A →̇ Nf' A
  norm t = reify _ (eval t (freshG _))

---------------------------------------------------------------------------
-- Case tree instance of cover monad

module CaseTree where

  data Cover (P : Cxt → Set) (Γ : Cxt) : Set where
    returnC : (p : P Γ) → Cover P Γ
    falseC  : (t : Ne Γ False) → Cover P Γ
    orC     : ∀{C D} (t : Ne Γ (C ∨ D))
                (c : Cover P (Γ ∙ C))
                (d : Cover P (Γ ∙ D)) → Cover P Γ

  return : ∀{P} (monP : Mon P) → P →̇ Cover P
  return monP p = returnC p

  -- Syntactic paste.

  runNf : ∀{A} → Cover (Nf' A) →̇ Nf' A
  runNf (returnC p) = p
  runNf (falseC t)  = falseE t
  runNf (orC t c d) = orE t (runNf c) (runNf d)

  -- Weakening covers:  A case tree in Γ can be transported to a thinning Δ
  -- by weakening all the scrutinees.

  monC : ∀{P} → (monP : Mon P) → Mon (Cover P)
  monC monP τ (returnC p) = returnC (monP τ p)
  monC monP τ (falseC t)  = falseC (monNe τ t)
  monC monP τ (orC t c d) = orC (monNe τ t) (monC monP (lift τ) c)
                                            (monC monP (lift τ) d)
  -- Monad.

  mapC : ∀{P Q} → (P →̇ Q) → (Cover P →̇ Cover Q)
  mapC f (returnC p) = returnC (f p)
  mapC f (falseC t)  = falseC t
  mapC f (orC t c d) = orC t (mapC f c) (mapC f d)

  joinC : ∀{P} → Cover (Cover P) →̇ Cover P
  joinC (returnC p) = p
  joinC (falseC t)  = falseC t
  joinC (orC t c d) = orC t (joinC c) (joinC d)

  -- Strong functoriality.

  mapC' : ∀{P Q Γ} → KFun P Q Γ → Cover P Γ → Cover Q Γ
  mapC' f (returnC p) = returnC (f id≤ p)
  mapC' f (falseC t)  = falseC t
  mapC' f (orC t c d) = orC t (mapC' (λ τ → f (τ • weak id≤)) c)
                              (mapC' (λ τ → f (τ • weak id≤)) d)

caseTreeMonad : CoverMonad
caseTreeMonad = record {monad = record{CaseTree}; CaseTree}

-- A normalization function using case trees.

open Normalization caseTreeMonad using () renaming (norm to normCaseTree)

---------------------------------------------------------------------------
-- Continuation instance of cover monad

module Continuation where

  record Cover (P : Cxt → Set) (Γ : Cxt) : Set where
    field runNf' : ∀ {A} → ((P ⇒̂ Nf' A) ⇒̂ Nf' A) Γ
  open Cover

  -- Services.

  runNf : ∀{A} → Cover (Nf' A) →̇ Nf' A
  runNf {A} {Γ} c = c .runNf' id≤ (λ τ → id)

  falseC : ∀{P} → Ne' False →̇ Cover P
  falseC t .runNf' τ k = falseE (monNe τ t)

  orC : ∀{P Γ C D} (t : Ne Γ (C ∨ D))
          (c : Cover P (Γ ∙ C))
          (d : Cover P (Γ ∙ D)) → Cover P Γ

  orC t c d .runNf' τ k = orE (monNe τ t)
    (c .runNf' (lift τ) (λ δ → k (δ • weak id≤)))
    (d .runNf' (lift τ) (λ δ → k (δ • weak id≤)))

  -- Monad infrastructure.

  monC : ∀{P} → (monP : Mon P) → Mon (Cover P)
  monC monP τ c .runNf' τ₁ k = c .runNf' (τ₁ • τ) k

  mapC' : ∀{P Q} → ⟨ P ⇒̂ Q ⊙ Cover P ⟩→̇ Cover Q
  mapC' k c .runNf' τ l = c .runNf' τ λ δ p → l δ (k (δ • τ) p)

  mapC : ∀{P Q} → (P →̇ Q) → (Cover P →̇ Cover Q)
  mapC f = mapC' λ τ → f

  return : ∀{P} (monP : Mon P) → P →̇ Cover P
  return monP p .runNf' τ k = k id≤ (monP τ p)

  joinC : ∀{P} → Cover (Cover P) →̇ Cover P
  joinC c .runNf' τ k = c .runNf' τ λ δ c' → c' .runNf' id≤ λ δ' → k (δ' • δ)

  extC : ∀{P Q} → (P →̇ Cover Q) → Cover P →̇ Cover Q
  extC f = joinC ∘ mapC f

  bindC' : ∀{P Q} → Cover P →̇ (P ⇒̂ Cover Q) ⇒̂ Cover Q
  bindC' c τ k .runNf' τ' k' = c .runNf' (τ' • τ) λ σ p → k (σ • τ') p .runNf' id≤ λ σ' → k' (σ' • σ)

continuationMonad : CoverMonad
continuationMonad = record{monad = record{Continuation}; Continuation}

-- A normalization function using continuations.

open Normalization continuationMonad using () renaming (norm to normContinuation)

-- Q.E.D.

-- -}
-- -}
-- -}


module InterpretationEqualityExceptAtVariableName where

open import OscarPrelude
open import VariableName
open import FunctionName
open import PredicateName
open import Elements
open import Interpretation

record _≞_/_ (𝓘 : Interpretation) (I : Interpretation) (𝑥 : VariableName) : Set
 where
  field
    μEquality : {𝑥′ : VariableName} → 𝑥′ ≢ 𝑥 → μ⟦ 𝓘 ⟧ 𝑥 ≡ μ⟦ I ⟧ 𝑥′
    𝑓Equality : (𝑓 : FunctionName) (μs : Elements) → 𝑓⟦ 𝓘 ⟧ 𝑓 μs ≡ 𝑓⟦ I ⟧ 𝑓 μs
    𝑃Equality : (𝑃 : PredicateName) → (μs : Elements) → 𝑃⟦ 𝓘 ⟧ 𝑃 μs ≡ 𝑃⟦ I ⟧ 𝑃 μs


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

module Definition.Typed.Consequences.SucCong where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Typed.Properties
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Substitution

open import Tools.Product

-- Congurence of the type of the successor case in natrec.
sucCong : ∀ {F G Γ} → Γ ∙ ℕ ⊢ F ≡ G
        → Γ ⊢ Π ℕ ▹ (F ▹▹ F [ suc (var 0) ]↑)
            ≡ Π ℕ ▹ (G ▹▹ G [ suc (var 0) ]↑)
sucCong F≡G with wfEq F≡G
sucCong F≡G | ⊢Γ ∙ ⊢ℕ =
  let ⊢F , _ = syntacticEq F≡G
  in  Π-cong ⊢ℕ (refl ⊢ℕ)
             (Π-cong ⊢F F≡G
                     (wkEq (step id) (⊢Γ ∙ ⊢ℕ ∙ ⊢F)
                           (subst↑TypeEq F≡G
                                         (refl (sucⱼ (var (⊢Γ ∙ ⊢ℕ) here))))))


module Numeral.Ordinal where

import      Lvl
open import Numeral.Natural
open import Syntax.Function
open import Type

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

-- Ordinal numbers up to a certain level as a type.
-- 𝟎 is the zero ordinal, the smallest ordinal number.
-- 𝐒 is the successor ordinal function, the smallest ordinal greater than the given argument.
-- lim is the limit ordinal function, the "limit" of the given sequence. The smallest ordinal greater than all values of the given sequence. Note that this is not the usual definition of a "limit ordinal" because `lim` allows arbitrary sequences, specifically those with a maximum, resulting in an equivalent to the successor ordinal `𝐒` (TODO: If this is the case, then 𝐒 is actually unnecessary? Just define it by (lim ∘ const)?
-- Note: Usually the indexing in a limit ordinal should be the class of ordinals before it, so this definition is probably unable to express all ordinals.
data Ordinal(T : Type{ℓ}) : Type{ℓ} where
  𝟎   : Ordinal(T)
  𝐒   : Ordinal(T) → Ordinal(T)
  lim : (T → Ordinal(T)) → Ordinal(T)

{-
data Ordinal' : (ℓ : Lvl.Level) → Typeω where
  𝟎   : Ordinal'(ℓ)
  𝐒   : Ordinal'(ℓ) → Ordinal'(ℓ)
  lim : (Ordinal'(ℓ) → Ordinal'(Lvl.𝐒(ℓ))) → Ordinal'(Lvl.𝐒(ℓ)) -- When the next ordinal have the current ordinal as its index

data Ordinal(T : Type{ℓ}) : Type{ℓ} where
  𝟎   : Ordinal(T)
  lim : (T → Ordinal(T)) → Ordinal(T) -- 𝐒 is expressable through lim

data Ordinal(T : Type{ℓ}) : Type{ℓ} where
  𝟎   : Ordinal(T)
  𝐒   : Ordinal(T) → Ordinal(T)
  lim : (f : T → Ordinal(T)) → ∃(IncreasingSubsequence(_<_)(f)) → Ordinal(T) -- This excludes the cases where f have a maximum, resulting in no intersection between 𝐒 and lim
-}

_+_ : Ordinal(T) → Ordinal(T) → Ordinal(T)
x + 𝟎     = x
x + 𝐒(y)  = 𝐒(x + y)
x + lim f = lim(y ↦ (x + f(y)))

_⋅_ : Ordinal(T) → Ordinal(T) → Ordinal(T)
x ⋅ 𝟎      = 𝟎
x ⋅ 𝐒(y)   = (x ⋅ y) + x
x ⋅ lim f  = lim(y ↦ (x ⋅ f(y)))

_^_ : Ordinal(T) → Ordinal(T) → Ordinal(T)
x ^ 𝟎     = x
x ^ 𝐒(y)  = (x ^ y) ⋅ x
x ^ lim f = lim(y ↦ (x ^ f(y)))

open import Logic.Propositional

private variable x y z x₁ x₂ y₁ y₂ z₁ z₂ : Ordinal(T)

module _ {T : Type{ℓ}} where
  open import Functional
  open import Logic.Propositional

  -- TODO: Not sure if this is correct
  data _<_ : Ordinal(T) → Ordinal(T) → Type{ℓ} where
    minimal : ∀{x} → (𝟎 < 𝐒(x))
    step    : ∀{x y} → (x < y) → (𝐒(x) < 𝐒(y))
    limitₗ  : ∀{f}{x} → (∀{i} → (f(i) < x)) → (lim f < 𝐒(x))
    limitᵣ  : ∀{i}{f}{x} → (x < 𝐒(f(i))) → (x < lim f)

  _>_ = swap(_<_)

  _≤_ : Ordinal(T) → Ordinal(T) → Type
  x ≤ y = x < 𝐒(y)

  _≥_ = swap(_≤_)

  _≡_ : Ordinal(T) → Ordinal(T) → Type
  x ≡ y = (y ≤ x) ∧ (x ≤ y)

  open import Numeral.Natural.Induction
  from-ℕ : ℕ → Ordinal(T)
  from-ℕ = ℕ-elim 𝟎 (const 𝐒)

  _+ₙ_ : Ordinal(T) → ℕ → Ordinal(T)
  _+ₙ_ x = ℕ-elim x (const 𝐒)

  private variable f g : T → Ordinal(T)
  private variable n : T

  [<]-limitₗ-inv : (lim f < 𝐒(x)) → (∀{n} → (f(n) < x))
  [<]-limitₗ-inv (limitₗ p) = p

  open import Logic.Predicate
  open import Type.Properties.Inhabited
  [<]-limitᵣ-inv : (x < lim f) → ∃(n ↦ (x < 𝐒(f(n))))
  [<]-limitᵣ-inv (limitᵣ{n} p) = [∃]-intro n ⦃ p ⦄

  [<]-lim-minimal : ⦃ ◊ T ⦄ → (𝟎 < lim f)
  [<]-lim-minimal = limitᵣ{i = [◊]-existence} minimal

  [<]-lim-maximum : (f(n) < lim f)
  [<]-of-step : (x < 𝐒(x))

  [<]-lim-maximum{f}{n} = limitᵣ{n} [<]-of-step

  [<]-without-step : (𝐒(x) < 𝐒(y)) → (x < y)
  [<]-without-step (step p) = p

  [<]-of-step {𝟎}     = minimal
  [<]-of-step {𝐒(x)}  = step [<]-of-step
  [<]-of-step {lim f} = limitₗ [<]-lim-maximum

  [<]-transitivity : (x < y) → (y < z) → (x < z)
  [<]-transitivity minimal     (step yz)          = minimal
  [<]-transitivity minimal     (limitᵣ {n}{f} yz) = limitᵣ {n}{f} minimal
  [<]-transitivity (step xy)   (step yz)          = step ([<]-transitivity xy yz)
  [<]-transitivity (step xy)   (limitᵣ yz)        = limitᵣ ([<]-transitivity (step xy) yz)
  [<]-transitivity (limitₗ xy) (step yz)          = limitₗ ([<]-transitivity xy yz)
  [<]-transitivity (limitₗ xy) (limitᵣ yz)        = limitᵣ (limitₗ ([<]-without-step([<]-transitivity (step xy) yz)))
  [<]-transitivity (limitᵣ xy) (limitₗ yz)        = [<]-transitivity xy (step yz)
  [<]-transitivity (limitᵣ xy) (limitᵣ yz)        = limitᵣ ([<]-transitivity (limitᵣ xy) yz)

  [<]-stepᵣ : (x < y) → (x < 𝐒(y))
  [<]-stepᵣ minimal    = minimal
  [<]-stepᵣ (step p)   = step ([<]-stepᵣ p)
  [<]-stepᵣ (limitₗ p) = limitₗ ([<]-stepᵣ p)
  [<]-stepᵣ (limitᵣ p) = [<]-transitivity p (step [<]-lim-maximum)

  [<]-to-[≤] : (x < y) → (x ≤ y)
  [<]-to-[≤] = [<]-stepᵣ

  [<]-irreflexivity : ¬(x < x)
  [<]-irreflexivity (step p)            = [<]-irreflexivity p
  [<]-irreflexivity (limitᵣ (limitₗ x)) = [<]-irreflexivity x

  [<]-asymmetry : (x < y) → (y < x) → ⊥
  [<]-asymmetry xy yx = [<]-irreflexivity([<]-transitivity xy yx)

  [<]-without-stepₗ : (𝐒(x) < y) → (x < y)
  [<]-without-stepₗ (step p)   = [<]-stepᵣ p
  [<]-without-stepₗ (limitᵣ p) = limitᵣ ([<]-without-stepₗ p)

  [<]-no-less-than-minimum : ¬(x < 𝟎)
  [<]-no-less-than-minimum ()

  [≤]-minimal : (𝟎 ≤ x)
  [≤]-minimal = minimal

  [≤]-step : (x ≤ y) → (𝐒(x) ≤ 𝐒(y))
  [≤]-step = step

  [≤]-reflexivity : (x ≤ x)
  [≤]-reflexivity = [<]-of-step

  [≡]-reflexivity : (x ≡ x)
  [≡]-reflexivity = [∧]-intro [≤]-reflexivity [≤]-reflexivity

  open import Logic.Propositional.Theorems
  [≡]-symmetry : (x ≡ y) → (y ≡ x)
  [≡]-symmetry = [∧]-symmetry

  [≡]-step : (x ≡ y) → (𝐒(x) ≡ 𝐒(y))
  [≡]-step = [∧]-map step step

  open import Relator.Equals renaming (_≡_ to _≡ₑ_)
  [<]-less-than-one : ⦃ ◊ T ⦄ → (x < 𝐒(𝟎)) → (x ≡ₑ 𝟎)
  [<]-less-than-one minimal = [≡]-intro
  [<]-less-than-one (limitₗ p) with () ← p{[◊]-existence}

  [<][≤]-semitransitivityₗ : ⦃ ◊ T ⦄ → (x ≤ y) → (y < z) → (x < z)
  [<][≤]-semitransitivityₗ {_}        {y}        {.(lim _)} xy                 (limitᵣ yz)  = limitᵣ ([<][≤]-semitransitivityₗ xy yz)
  [<][≤]-semitransitivityₗ {.𝟎}       {.𝟎}       {.(𝐒 _)}    minimal            minimal     = minimal
  [<][≤]-semitransitivityₗ {.𝟎}       {.(𝐒 _)}   {.(𝐒 _)}    minimal            (step yz)   = minimal
  [<][≤]-semitransitivityₗ {.𝟎}       {.(lim _)} {.(𝐒 _)}    minimal            (limitₗ x)  = minimal
  [<][≤]-semitransitivityₗ {.(𝐒 _)}   {.(𝐒 _)}   {.(𝐒 _)}    (step xy)          (step yz)   = step ([<][≤]-semitransitivityₗ xy yz)
  [<][≤]-semitransitivityₗ {.(𝐒 _)}   {.(lim _)} {.(𝐒 _)}    (step (limitᵣ xy)) (limitₗ yz) = step ([<][≤]-semitransitivityₗ xy yz)
  [<][≤]-semitransitivityₗ {.(lim _)} {.𝟎}       {.(𝐒 _)}    (limitₗ xy)        minimal     with () ← xy{[◊]-existence}
  [<][≤]-semitransitivityₗ {.(lim _)} {.(𝐒 _)}   {.(𝐒 _)}    (limitₗ xy)        (step yz)   = limitₗ ([<][≤]-semitransitivityₗ xy yz)
  [<][≤]-semitransitivityₗ {.(lim _)} {.(lim _)} {.(𝐒 _)}    (limitₗ xy)        (limitₗ yz) = limitₗ ([<][≤]-semitransitivityₗ ([∃]-proof([<]-limitᵣ-inv xy)) yz)

  [≤]-transitivity : ⦃ ◊ T ⦄ → (x ≤ y) → (y ≤ z) → (x ≤ z)
  [≤]-transitivity = [<][≤]-semitransitivityₗ

  [≡]-transitivity : ⦃ ◊ T ⦄ → (x ≡ y) → (y ≡ z) → (x ≡ z)
  [≡]-transitivity ([∧]-intro yx xy) ([∧]-intro zy yz) = [∧]-intro ([≤]-transitivity zy yx) ([≤]-transitivity xy yz)

  [<][≤]-semitransitivityᵣ : ⦃ ◊ T ⦄ → (x < y) → (y ≤ z) → (x < z)
  [<][≤]-semitransitivityᵣ {.𝟎}       {.(𝐒 𝟎)}       {.(𝐒 _)}   minimal (step minimal)         = minimal
  [<][≤]-semitransitivityᵣ {.𝟎}       {.(𝐒 (𝐒 _))}   {.(𝐒 _)}   minimal (step (step yz))       = minimal
  [<][≤]-semitransitivityᵣ {.𝟎}       {.(𝐒 (lim _))} {.(𝐒 _)}   minimal (step (limitₗ yz))     = minimal
  [<][≤]-semitransitivityᵣ {.𝟎}       {.(𝐒 _)}       {.(lim _)} minimal (step (limitᵣ yz))     = limitᵣ{[◊]-existence} minimal
  [<][≤]-semitransitivityᵣ {.(𝐒 _)}   {.(𝐒 _)}       {𝐒 z}      (step xy) (step yz)            = step ([<][≤]-semitransitivityᵣ xy yz)
  [<][≤]-semitransitivityᵣ {.(𝐒 _)}   {.(𝐒 _)}       {lim z}    (step xy) (step (limitᵣ yz))   = limitᵣ (step ([<][≤]-semitransitivityᵣ xy yz))
  [<][≤]-semitransitivityᵣ {.(lim _)} {.(𝐒 _)}       {𝐒 z}      (limitₗ xy) (step yz)          = limitₗ ([<][≤]-semitransitivityᵣ xy yz)
  [<][≤]-semitransitivityᵣ {.(lim _)} {.(𝐒 _)}       {lim z}    (limitₗ xy) (step (limitᵣ yz)) = limitᵣ ([<][≤]-semitransitivityᵣ (limitₗ xy) (step yz))
  [<][≤]-semitransitivityᵣ {x}        {.(lim _)}     {z}        (limitᵣ xy) (limitₗ yz)        = [<][≤]-semitransitivityᵣ xy (step yz)

  {-
  StrictlyIncreasingSubsequenceExistence : ∀{ℓ}{I : Type{ℓ}} → (I → Ordinal(T)) → Type
  StrictlyIncreasingSubsequenceExistence{I = I} (f) = ∃{Obj = ℕ → I}(g ↦ ∀{n} → (f(g(n)) < f(g(𝐒(n)))))

  -- TODO: Requires some kind of search for T
  StrictlyIncreasingSubsequenceExistence-to-no-maximum : StrictlyIncreasingSubsequenceExistence(f) → ¬ ∃(max ↦ ∀{x} → (f(x) < f(max)))
  StrictlyIncreasingSubsequenceExistence-to-no-maximum ([∃]-intro witness) ([∃]-intro witness₁) = [<]-asymmetry {!!} {!!}
  -}

  {- TODO: Maybe unprovable constructively
  [<]-classical : (x < y) ∨ ¬(x < y)
  [<]-classical {𝟎}     {𝟎}     = [∨]-introᵣ \()
  [<]-classical {𝟎}     {𝐒 y}   = [∨]-introₗ minimal
  [<]-classical {𝟎}     {lim y} = [∨]-introₗ (limitᵣ{𝟎} minimal)
  [<]-classical {𝐒 x}   {𝟎}     = [∨]-introᵣ \()
  [<]-classical {𝐒 x}   {𝐒 y}   = [∨]-elim2 step (_∘ [<]-without-step) ([<]-classical {x} {y})
  [<]-classical {𝐒 x}   {lim y} with [<]-classical {x} {lim y}
  ... | [∨]-introₗ p = {!!}
  ... | [∨]-introᵣ p = {!!}
  [<]-classical {lim x} {𝟎}     = [∨]-introᵣ \()
  [<]-classical {lim x} {𝐒 y}   with [<]-classical {lim x} {y}
  ... | [∨]-introₗ (limitₗ p)          = [∨]-introₗ (limitₗ ([<]-stepᵣ p))
  ... | [∨]-introₗ (limitᵣ (limitₗ p)) = [∨]-introₗ (limitₗ (limitᵣ ([<]-stepᵣ p)))
  ... | [∨]-introᵣ p = [∨]-introᵣ (p ∘ (q ↦ {![<]-limitₗ-inv q!}))
  [<]-classical {lim x} {lim y} = {!!}
  -}

  {- TODO: This is true when there is no maximum for f
  ∀{x} → ∃(y ↦ (x < y) ∧ (f(x) < f(y)))
  test : (x < lim f) → (𝐒(x) < lim f)
  test {𝟎} (limitᵣ minimal) = limitᵣ (step {!!})
  test {𝐒 x} (limitᵣ (step p)) = limitᵣ (step {!!})
  test {lim x} (limitᵣ (limitₗ x₁)) = {!!}
  -}

  {- TODO: Also unprovable constructively?
  f either have a maximum value or is unbounded (so, this would require some kind of search?)

  [<]-sequence-limit : ∀{n} → (f(n) < lim g) → ((∀{n} → (f(n) < lim g)) ∨ (f(n) ≡ x))

  [≤]-total : ⦃ ◊ T ⦄ → ((x ≤ y) ∨ (y ≤ x))
  [≤]-total {𝟎} {_} = [∨]-introₗ minimal
  [≤]-total {_} {𝟎} = [∨]-introᵣ minimal
  [≤]-total {𝐒 x} {𝐒 y} = [∨]-elim2 step step ([≤]-total {x} {y})
  [≤]-total {𝐒 x} {lim y} with [≤]-total {x} {lim y}
  ... | [∨]-introₗ minimal = [∨]-introₗ (step [<]-lim-minimal)
  ... | [∨]-introₗ (step (limitᵣ p)) = [∨]-introₗ (step (limitᵣ (step {!!})))
  ... | [∨]-introₗ (limitₗ p) = [∨]-introₗ (step (limitᵣ (limitₗ (\{n} → {![<]-limitᵣ-inv (p{n})!}))))
  ... | [∨]-introᵣ p = [∨]-introᵣ ([<]-stepᵣ p)
  [≤]-total {lim x} {𝐒 y} = {!!} -- [∨]-symmetry ([≤]-total {𝐒 y} {lim x})
  [≤]-total {lim x} {lim y} = {!!}
  -}

  {-
  [≤]-to-[<][≡] : ⦃ ◊ T ⦄ → (x ≤ y)  → ((x < y) ∨ (x ≡ y))
  [≤]-to-[<][≡] {𝟎}     {𝟎}     minimal    = [∨]-introᵣ ([∧]-intro minimal minimal)
  [≤]-to-[<][≡] {𝟎}     {𝐒 y}   minimal    = [∨]-introₗ minimal
  [≤]-to-[<][≡] {𝟎}     {lim y} minimal    = [∨]-introₗ [<]-lim-minimal
  [≤]-to-[<][≡] {𝐒 x}   {𝐒 y}   (step p)   = [∨]-elim2 step [≡]-step ([≤]-to-[<][≡] {x}{y} p)
  [≤]-to-[<][≡] {𝐒 x} {lim y} (step (limitᵣ p)) with [≤]-to-[<][≡] p
  ... | [∨]-introₗ pp = [∨]-introₗ (limitᵣ (step pp))
  ... | [∨]-introᵣ ([∧]-intro l r) = {!!}
  -- [∨]-introᵣ ([∧]-intro (limitₗ (\{n} → {!!})) (step (limitᵣ r)))
  -- [∨]-elim2 (limitᵣ ∘ step) (\([∧]-intro l r) → [∧]-intro (limitₗ {![<]-stepᵣ l!}) (step (limitᵣ r))) ([≤]-to-[<][≡] p)
  [≤]-to-[<][≡] {lim x} {𝟎}     (limitₗ p) = [∨]-introᵣ ([∧]-intro minimal (limitₗ p))
  [≤]-to-[<][≡] {lim x} {𝐒 y}   (limitₗ p) = {!!}
  [≤]-to-[<][≡] {lim x} {lim y} (limitₗ p) = {!!}

  [<]-trichotomy : ⦃ ◊ T ⦄ → ((x < y) ∨ (x ≡ y) ∨ (x > y))
  [<]-trichotomy {𝟎}     {𝟎}     = [∨]-introₗ ([∨]-introᵣ [≡]-reflexivity)
  [<]-trichotomy {𝟎}     {𝐒 y}   = [∨]-introₗ ([∨]-introₗ minimal)
  [<]-trichotomy {𝟎}     {lim y} = [∨]-introₗ ([∨]-introₗ [<]-lim-minimal)
  [<]-trichotomy {𝐒 x}   {𝟎}     = [∨]-introᵣ minimal
  [<]-trichotomy {lim x} {𝟎}     = [∨]-introᵣ [<]-lim-minimal
  [<]-trichotomy {𝐒 x}   {𝐒 y}   = [∨]-elim2 ([∨]-elim2 step [≡]-step) step ([<]-trichotomy {x}{y})
  [<]-trichotomy {𝐒 x}   {lim y} with [<]-trichotomy {x} {lim y}
  ... | [∨]-introₗ ([∨]-introᵣ ([∧]-intro p _)) = [∨]-introᵣ p
  ... | [∨]-introᵣ p                            = [∨]-introᵣ ([<]-stepᵣ p)
  ... | [∨]-introₗ ([∨]-introₗ (limitᵣ{n} p))   = {!!}
  [<]-trichotomy {lim x} {𝐒 y}   = {!!}
  [<]-trichotomy {lim x} {lim y} = {!!}
  -}

  lim-of-constant : ⦃ ◊ T ⦄ → (lim(const x) ≡ 𝐒(x))
  lim-of-constant = [∧]-intro (step (limitᵣ{[◊]-existence} [<]-of-step)) (limitₗ [<]-of-step)

  lim-of-sequence-with-maximum : ∀{max} → (∀{n} → (f(n) ≤ f(max))) → (lim f ≡ 𝐒(f(max)))
  lim-of-sequence-with-maximum{max = max} p = [∧]-intro (step (limitᵣ{max} [<]-of-step)) (limitₗ p)

  -- ∃(max ↦ (∀{n} → (f(n) ≤ f(max))) ∧ (lim f ≡ 𝐒(f(max)))) ∨ (∀{x} → (𝐒(f(x)) < lim f)) -- or maybe (∀{x y} → (f(x) + f(y) < lim f))

  lim-[≤]-function : (∀{x} → (f(x) ≤ g(x))) → (lim f ≤ lim g)
  lim-[≤]-function p = limitₗ(limitᵣ p)

  lim-function : (∀{x} → (f(x) ≡ g(x))) → (lim f ≡ lim g)
  lim-function p = [∧]-intro (lim-[≤]-function([∧]-elimₗ p)) (lim-[≤]-function([∧]-elimᵣ p))

  [+]-identityᵣ : ((x + 𝟎) ≡ x)
  [+]-identityᵣ = [≡]-reflexivity

  [+]-identityₗ : ((𝟎 + x) ≡ x)
  [+]-identityₗ {𝟎}     = [+]-identityᵣ
  [+]-identityₗ {𝐒 x}   = [≡]-step ([+]-identityₗ {x})
  [+]-identityₗ {lim x} = lim-function [+]-identityₗ

  [+]-associativity : (((x + y) + z) ≡ (x + (y + z)))
  [+]-associativity {x}{y}{𝟎}     = [≡]-reflexivity
  [+]-associativity {x}{y}{𝐒 z}   = [≡]-step ([+]-associativity {x}{y}{z})
  [+]-associativity {x}{y}{lim z} = lim-function ([+]-associativity {x}{y}{_})

  [+]ₗ-[<][≤]-semifunction : (x < y) → ((x + z) ≤ (y + z))
  [+]ₗ-[<][≤]-semifunction {z = 𝟎}     p = [<]-to-[≤] p
  [+]ₗ-[<][≤]-semifunction {z = 𝐒 z}   p = [≤]-step([+]ₗ-[<][≤]-semifunction {z = z} p)
  [+]ₗ-[<][≤]-semifunction {z = lim x} p = limitₗ (limitᵣ ([+]ₗ-[<][≤]-semifunction p))

  [+]ᵣ-[<]-function : ⦃ ◊ T ⦄ → (y < z) → ((x + y) < (x + z))
  [+]ᵣ-[<]-function (minimal {𝟎})     = [<]-of-step
  [+]ᵣ-[<]-function (minimal {𝐒 x})   = [<]-stepᵣ ([+]ᵣ-[<]-function minimal)
  [+]ᵣ-[<]-function (minimal {lim x}) = [<]-stepᵣ (limitᵣ{[◊]-existence} ([+]ᵣ-[<]-function minimal))
  [+]ᵣ-[<]-function (step p)   = step ([+]ᵣ-[<]-function p)
  [+]ᵣ-[<]-function (limitₗ p) = limitₗ ([+]ᵣ-[<]-function p)
  [+]ᵣ-[<]-function (limitᵣ p) = limitᵣ ([+]ᵣ-[<]-function p)

  {-
  [+]-operator : ⦃ ◊ T ⦄ → (x₁ ≡ x₂) → (y₁ ≡ y₂) → ((x₁ + y₁) ≡ (x₂ + y₂))
  [+]-operator ([∧]-intro pxl pxr) ([∧]-intro pyl pyr) = [∧]-intro {!!} {!!} where
    l : (x₁ ≡ x₂) → ((x₁ + y) ≡ (x₂ + y))
    l {𝟎}      {x₂} ([∧]-intro pl pr) = [∧]-intro {!!} {!!}
    l {𝐒 x₁}   {x₂} ([∧]-intro pl pr) = [∧]-intro {!!} {!!}
    l {lim x₁} {x₂} ([∧]-intro pl pr) = [∧]-intro {!!} {!!}

    r : (y₁ ≡ y₂) → ((x + y₁) ≡ (x + y₂))
    r ([∧]-intro pl pr) = [∧]-intro ([+]ᵣ-[<]-function pl) ([+]ᵣ-[<]-function pr)
  -}

  open import Structure.Relator.Ordering
  open        Structure.Relator.Ordering.Strict.Properties using (intro)

  Ordinal-accessibleₗ : ⦃ ◊ T ⦄ → Strict.Properties.Accessibleₗ(_<_)(x)
  Ordinal-accessibleₗ {n} = intro ⦃ proof{n} ⦄ where
    proof : ∀{y x} → ⦃ _ : (x < y) ⦄ → Strict.Properties.Accessibleₗ(_<_)(x)
    proof {_}        {𝟎}                          = intro ⦃ \ ⦃ ⦄ ⦄
    proof {𝐒 𝟎}      {lim y} ⦃ limitₗ p ⦄         with () ← p{[◊]-existence}
    proof {𝐒 x}      {𝐒 y}   ⦃ step p ⦄           = intro ⦃ \{z} ⦃ pz ⦄ → Strict.Properties.Accessibleₗ.proof (Ordinal-accessibleₗ {x}) ⦃ [<][≤]-semitransitivityₗ pz p ⦄ ⦄
    proof {𝐒(𝐒 x)}   {lim y} ⦃ limitₗ p ⦄         = intro ⦃ \{z} ⦃ pz ⦄ → Strict.Properties.Accessibleₗ.proof (Ordinal-accessibleₗ {𝐒 x}) ⦃ [<][≤]-semitransitivityₗ ([∃]-proof([<]-limitᵣ-inv pz)) p ⦄ ⦄
    proof {𝐒(lim x)} {lim y} ⦃ limitₗ p ⦄         = intro ⦃ \{z} ⦃ pz ⦄ → Strict.Properties.Accessibleₗ.proof (Ordinal-accessibleₗ {lim x}) ⦃ [<][≤]-semitransitivityₗ ([∃]-proof([<]-limitᵣ-inv pz)) p ⦄ ⦄
    proof {lim x}    {𝐒 y}   ⦃ limitᵣ(step p) ⦄   = intro ⦃ \{z} ⦃ pz ⦄ → Strict.Properties.Accessibleₗ.proof Ordinal-accessibleₗ ⦃ [<][≤]-semitransitivityₗ pz p ⦄ ⦄
    proof {lim x}    {lim y} ⦃ limitᵣ(limitₗ p) ⦄ = intro ⦃ \{z} ⦃ pz ⦄ → Strict.Properties.Accessibleₗ.proof Ordinal-accessibleₗ ⦃ [<][≤]-semitransitivityₗ ([∃]-proof([<]-limitᵣ-inv pz)) p ⦄ ⦄

module _ where
  open import Functional
  open import Function.Iteration
  open import Numeral.Natural.Induction

  private variable n : ℕ

  _⋅ₙ_ : Ordinal(ℕ) → ℕ → Ordinal(ℕ)
  _⋅ₙ_ x = ℕ-elim 𝟎 (const(lim ∘ (_+ₙ_)))

  ω : Ordinal(ℕ)
  ω = lim from-ℕ

  ω² : Ordinal(ℕ)
  ω² = lim(ω ⋅ₙ_)

  ω-[<]-correctness : from-ℕ(n) < ω
  ω-[<]-correctness {𝟎}    = limitᵣ{i = 𝟎}    minimal
  ω-[<]-correctness {𝐒(n)} = limitᵣ{i = 𝐒(n)} (step [<]-of-step)

  open import Relator.Equals renaming (_≡_ to _≡ₑ_)
  open import Relator.Equals.Proofs
  open import Type.Properties.Inhabited
  open import Structure.Relator

  private variable f : ℕ → Ordinal(ℕ)

  instance
    ℕ-inhabited : ◊ ℕ
    ℕ-inhabited = intro ⦃ 𝟎 ⦄

  strictly-increasing-sequence-when-zero : (∀{n} → (f(n) < f(𝐒(n)))) → (f(n) ≡ₑ 𝟎) → (n ≡ₑ 𝟎)
  strictly-increasing-sequence-when-zero {f = f}{n = 𝟎} ord p = [≡]-intro
  strictly-increasing-sequence-when-zero {f = f}{n = 𝐒 n} ord p with f(n) | ord{n}
  ... | 𝟎     | ord' with () ← [<]-irreflexivity (substitute₂ᵣ(_<_) p ord')
  ... | 𝐒 fn  | ord' with () ← [<]-asymmetry minimal (substitute₂ᵣ(_<_) p ord')
  ... | lim x | ord' with () ← [<]-asymmetry [<]-lim-minimal (substitute₂ᵣ(_<_) p ord')